Generalize CmmUnwind and pass unwind information through NCG
[ghc.git] / compiler / cmm / Debug.hs
1 {-# LANGUAGE GADTs #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Debugging data
6 --
7 -- Association of debug data on the Cmm level, with methods to encode it in
8 -- event log format for later inclusion in profiling event logs.
9 --
10 -----------------------------------------------------------------------------
11
12 module Debug (
13
14 DebugBlock(..), dblIsEntry,
15 cmmDebugGen,
16 cmmDebugLabels,
17 cmmDebugLink,
18 debugToMap,
19
20 -- * Unwinding information
21 UnwindTable, UnwindPoint(..),
22 UnwindExpr(..), toUnwindExpr
23 ) where
24
25 import BlockId
26 import CLabel
27 import Cmm
28 import CmmUtils
29 import CoreSyn
30 import FastString ( nilFS, mkFastString )
31 import Module
32 import Outputable
33 import PprCore ()
34 import PprCmmExpr ( pprExpr )
35 import SrcLoc
36 import Util
37
38 import Compiler.Hoopl
39
40 import Data.Maybe
41 import Data.List ( minimumBy, nubBy )
42 import Data.Ord ( comparing )
43 import qualified Data.Map as Map
44
45 -- | Debug information about a block of code. Ticks scope over nested
46 -- blocks.
47 data DebugBlock =
48 DebugBlock
49 { dblProcedure :: !Label -- ^ Entry label of containing proc
50 , dblLabel :: !Label -- ^ Hoopl label
51 , dblCLabel :: !CLabel -- ^ Output label
52 , dblHasInfoTbl :: !Bool -- ^ Has an info table?
53 , dblParent :: !(Maybe DebugBlock)
54 -- ^ The parent of this proc. See Note [Splitting DebugBlocks]
55 , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block
56 , dblSourceTick
57 :: !(Maybe CmmTickish) -- ^ Best source tick covering block
58 , dblPosition :: !(Maybe Int) -- ^ Output position relative to
59 -- other blocks. @Nothing@ means
60 -- the block was optimized out
61 , dblUnwind :: [UnwindPoint]
62 , dblBlocks :: ![DebugBlock] -- ^ Nested blocks
63 }
64
65 -- | Is this the entry block?
66 dblIsEntry :: DebugBlock -> Bool
67 dblIsEntry blk = dblProcedure blk == dblLabel blk
68
69 instance Outputable DebugBlock where
70 ppr blk = (if dblProcedure blk == dblLabel blk
71 then text "proc "
72 else if dblHasInfoTbl blk
73 then text "pp-blk "
74 else text "blk ") <>
75 ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
76 (maybe empty ppr (dblSourceTick blk)) <+>
77 (maybe (text "removed") ((text "pos " <>) . ppr)
78 (dblPosition blk)) <+>
79 (ppr (dblUnwind blk)) <+>
80 (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
81
82 -- | Intermediate data structure holding debug-relevant context information
83 -- about a block.
84 type BlockContext = (CmmBlock, RawCmmDecl)
85
86 -- | Extract debug data from a group of procedures. We will prefer
87 -- source notes that come from the given module (presumably the module
88 -- that we are currently compiling).
89 cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
90 cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
91 where
92 blockCtxs :: Map.Map CmmTickScope [BlockContext]
93 blockCtxs = blockContexts decls
94
95 -- Analyse tick scope structure: Each one is either a top-level
96 -- tick scope, or the child of another.
97 (topScopes, childScopes)
98 = splitEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
99 findP tsc GlobalScope = Left tsc -- top scope
100 findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
101 | otherwise = findP tsc scp'
102 where -- Note that we only following the left parent of
103 -- combined scopes. This loses us ticks, which we will
104 -- recover by copying ticks below.
105 scp' | SubScope _ scp' <- scp = scp'
106 | CombinedScope scp' _ <- scp = scp'
107 | otherwise = panic "findP impossible"
108
109 scopeMap = foldr (uncurry insertMulti) Map.empty childScopes
110
111 -- This allows us to recover ticks that we lost by flattening
112 -- the graph. Basically, if the parent is A but the child is
113 -- CBA, we know that there is no BA, because it would have taken
114 -- priority - but there might be a B scope, with ticks that
115 -- would not be associated with our child anymore. Note however
116 -- that there might be other childs (DB), which we have to
117 -- filter out.
118 --
119 -- We expect this to be called rarely, which is why we are not
120 -- trying too hard to be efficient here. In many cases we won't
121 -- have to construct blockCtxsU in the first place.
122 ticksToCopy :: CmmTickScope -> [CmmTickish]
123 ticksToCopy (CombinedScope scp s) = go s
124 where go s | scp `isTickSubScope` s = [] -- done
125 | SubScope _ s' <- s = ticks ++ go s'
126 | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2
127 | otherwise = panic "ticksToCopy impossible"
128 where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
129 ticksToCopy _ = []
130 bCtxsTicks = concatMap (blockTicks . fst)
131
132 -- Finding the "best" source tick is somewhat arbitrary -- we
133 -- select the first source span, while preferring source ticks
134 -- from the same source file. Furthermore, dumps take priority
135 -- (if we generated one, we probably want debug information to
136 -- refer to it).
137 bestSrcTick = minimumBy (comparing rangeRating)
138 rangeRating (SourceNote span _)
139 | srcSpanFile span == thisFile = 1
140 | otherwise = 2 :: Int
141 rangeRating note = pprPanic "rangeRating" (ppr note)
142 thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
143
144 -- Returns block tree for this scope as well as all nested
145 -- scopes. Note that if there are multiple blocks in the (exact)
146 -- same scope we elect one as the "branch" node and add the rest
147 -- as children.
148 blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
149 blocksForScope cstick scope = mkBlock True (head bctxs)
150 where bctxs = fromJust $ Map.lookup scope blockCtxs
151 nested = fromMaybe [] $ Map.lookup scope scopeMap
152 childs = map (mkBlock False) (tail bctxs) ++
153 map (blocksForScope stick) nested
154
155 mkBlock :: Bool -> BlockContext -> DebugBlock
156 mkBlock top (block, prc)
157 = DebugBlock { dblProcedure = g_entry graph
158 , dblLabel = label
159 , dblCLabel = case info of
160 Just (Statics infoLbl _) -> infoLbl
161 Nothing
162 | g_entry graph == label -> entryLbl
163 | otherwise -> blockLbl label
164 , dblHasInfoTbl = isJust info
165 , dblParent = Nothing
166 , dblTicks = ticks
167 , dblPosition = Nothing -- see cmmDebugLink
168 , dblSourceTick = stick
169 , dblBlocks = blocks
170 , dblUnwind = []
171 }
172 where (CmmProc infos entryLbl _ graph) = prc
173 label = entryLabel block
174 info = mapLookup label infos
175 blocks | top = seqList childs childs
176 | otherwise = []
177
178 -- A source tick scopes over all nested blocks. However
179 -- their source ticks might take priority.
180 isSourceTick SourceNote {} = True
181 isSourceTick _ = False
182 -- Collect ticks from all blocks inside the tick scope.
183 -- We attempt to filter out duplicates while we're at it.
184 ticks = nubBy (flip tickishContains) $
185 bCtxsTicks bctxs ++ ticksToCopy scope
186 stick = case filter isSourceTick ticks of
187 [] -> cstick
188 sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
189
190 -- | Build a map of blocks sorted by their tick scopes
191 --
192 -- This involves a pre-order traversal, as we want blocks in rough
193 -- control flow order (so ticks have a chance to be sorted in the
194 -- right order).
195 blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
196 blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
197 where walkProc :: RawCmmDecl
198 -> Map.Map CmmTickScope [BlockContext]
199 -> Map.Map CmmTickScope [BlockContext]
200 walkProc CmmData{} m = m
201 walkProc prc@(CmmProc _ _ _ graph) m
202 | mapNull blocks = m
203 | otherwise = snd $ walkBlock prc entry (emptyLbls, m)
204 where blocks = toBlockMap graph
205 entry = [mapFind (g_entry graph) blocks]
206 emptyLbls = setEmpty :: LabelSet
207
208 walkBlock :: RawCmmDecl -> [Block CmmNode C C]
209 -> (LabelSet, Map.Map CmmTickScope [BlockContext])
210 -> (LabelSet, Map.Map CmmTickScope [BlockContext])
211 walkBlock _ [] c = c
212 walkBlock prc (block:blocks) (visited, m)
213 | lbl `setMember` visited
214 = walkBlock prc blocks (visited, m)
215 | otherwise
216 = walkBlock prc blocks $
217 walkBlock prc succs
218 (lbl `setInsert` visited,
219 insertMulti scope (block, prc) m)
220 where CmmEntry lbl scope = firstNode block
221 (CmmProc _ _ _ graph) = prc
222 succs = map (flip mapFind (toBlockMap graph))
223 (successors (lastNode block))
224 mapFind = mapFindWithDefault (error "contextTree: block not found!")
225
226 insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
227 insertMulti k v = Map.insertWith (const (v:)) k [v]
228
229 cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
230 cmmDebugLabels isMeta nats = seqList lbls lbls
231 where -- Find order in which procedures will be generated by the
232 -- back-end (that actually matters for DWARF generation).
233 --
234 -- Note that we might encounter blocks that are missing or only
235 -- consist of meta instructions -- we will declare them missing,
236 -- which will skip debug data generation without messing up the
237 -- block hierarchy.
238 lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
239 getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
240 getBlocks _other = []
241 allMeta (BasicBlock _ instrs) = all isMeta instrs
242
243 -- | Sets position and unwind table fields in the debug block tree according to
244 -- native generated code.
245 cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
246 -> [DebugBlock] -> [DebugBlock]
247 cmmDebugLink labels unwindPts blocks = map link blocks
248 where blockPos :: LabelMap Int
249 blockPos = mapFromList $ flip zip [0..] labels
250 link block = block { dblPosition = mapLookup (dblLabel block) blockPos
251 , dblBlocks = map link (dblBlocks block)
252 , dblUnwind = fromMaybe mempty
253 $ mapLookup (dblLabel block) unwindPts
254 }
255
256 -- | Converts debug blocks into a label map for easier lookups
257 debugToMap :: [DebugBlock] -> LabelMap DebugBlock
258 debugToMap = mapUnions . map go
259 where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
260
261 {-
262 Note [What is this unwinding business?]
263 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
264
265 Unwinding tables are a variety of debugging information used by debugging tools
266 to reconstruct the execution history of a program at runtime. These tables
267 consist of sets of "instructions", one set for every instruction in the program,
268 which describe how to reconstruct the state of the machine at the point where
269 the current procedure was called. For instance, consider the following annotated
270 pseudo-code,
271
272 a_fun:
273 add rsp, 8 -- unwind: rsp = rsp - 8
274 mov rax, 1 -- unwind: rax = unknown
275 call another_block
276 sub rsp, 8 -- unwind: rsp = rsp
277
278 We see that attached to each instruction there is an "unwind" annotation, which
279 provides a relationship between each updated register and its value at the
280 time of entry to a_fun. This is the sort of information that allows gdb to give
281 you a stack backtrace given the execution state of your program. This
282 unwinding information is captured in various ways by various debug information
283 formats; in the case of DWARF (the only format supported by GHC) it is known as
284 Call Frame Information (CFI) and can be found in the .debug.frames section of
285 your object files.
286
287 Currently we only bother to produce unwinding information for registers which
288 are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp
289 (which is the STG stack pointer) and $rsp (the C stack pointer).
290
291 Let's consider how GHC would annotate a C-- program with unwinding information
292 with a typical C-- procedure as would come from the STG-to-Cmm code generator,
293
294 entry()
295 { c2fe:
296 v :: P64 = R2;
297 if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
298 c2ff:
299 R2 = v :: P64;
300 R1 = test_closure;
301 call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
302 c2fg:
303 I64[Sp - 8] = c2dD;
304 R1 = v :: P64;
305 Sp = Sp - 8; // Sp updated here
306 if (R1 & 7 != 0) goto c2dD; else goto c2dE;
307 c2dE:
308 call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
309 c2dD:
310 w :: P64 = R1;
311 Hp = Hp + 48;
312 if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
313 ...
314 },
315
316 Let's consider how this procedure will be decorated with unwind information
317 (largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the
318 value of Sp is no different from what it was at its call site. Therefore we will
319 add an `unwind` statement saying this at the beginning of its unwind-annotated
320 code,
321
322 entry()
323 { c2fe:
324 unwind Sp = Just Sp + 0;
325 v :: P64 = R2;
326 if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
327
328 After c2fe we we may pass to either c2ff or c2fg; let's first consider the
329 former. In this case there is nothing in particular that we need to do other
330 than reiterate what we already know about Sp,
331
332 c2ff:
333 unwind Sp = Just Sp + 0;
334 R2 = v :: P64;
335 R1 = test_closure;
336 call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
337
338 In contrast, c2fg updates Sp midway through its body. To ensure that unwinding
339 can happen correctly after this point we must include an unwind statement there,
340 in addition to the usual beginning-of-block statement,
341
342 c2fg:
343 unwind Sp = Just Sp + 0;
344 I64[Sp - 8] = c2dD;
345 R1 = v :: P64;
346 unwind Sp = Just Sp + 8;
347 Sp = Sp - 8;
348 if (R1 & 7 != 0) goto c2dD; else goto c2dE;
349
350 The remaining blocks are simple,
351
352 c2dE:
353 unwind Sp = Just Sp + 8;
354 call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
355 c2dD:
356 unwind Sp = Just Sp + 8;
357 w :: P64 = R1;
358 Hp = Hp + 48;
359 if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
360 ...
361 },
362
363
364 The flow of unwinding information through the compiler is a bit convoluted:
365
366 * C-- begins life in StgCmm without any unwind information. This is because we
367 haven't actually done any register assignment or stack layout yet, so there
368 is no need for unwind information.
369
370 * CmmLayoutStack figures out how to layout each procedure's stack, and produces
371 appropriate unwinding nodes for each adjustment of the STG Sp register.
372
373 * The unwind nodes are carried through the sinking pass. Currently this is
374 guaranteed not to invalidate unwind information since it won't touch stores
375 to Sp, but this will need revisiting if CmmSink gets smarter in the future.
376
377 * Eventually we make it to the native code generator backend which can then
378 preserve the unwind nodes in its machine-specific instructions. In so doing
379 the backend can also modify or add unwinding information; this is necessary,
380 for instance, in the case of x86-64, where adjustment of $rsp may be
381 necessary during calls to native foreign code due to the native calling
382 convention.
383
384 * The NCG then retrieves the final unwinding table for each block from the
385 backend with extractUnwindPoints.
386
387 * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen
388
389 * These DebugBlcosk are then converted to, e.g., DWARF unwinding tables
390 (by the Dwarf module) and emitted in the final object.
391
392 See also: Note [Unwinding information in the NCG] in AsmCodeGen.
393 -}
394
395 -- | A label associated with an 'UnwindTable'
396 data UnwindPoint = UnwindPoint !Label !UnwindTable
397
398 instance Outputable UnwindPoint where
399 ppr (UnwindPoint lbl uws) =
400 braces $ ppr lbl<>colon
401 <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
402 where
403 pprUw (g, expr) = ppr g <> char '=' <> ppr expr
404
405 -- | Maps registers to expressions that yield their "old" values
406 -- further up the stack. Most interesting for the stack pointer Sp,
407 -- but might be useful to document saved registers, too.
408 type UnwindTable = Map.Map GlobalReg UnwindExpr
409
410 -- | Expressions, used for unwind information
411 data UnwindExpr = UwConst !Int -- ^ literal value
412 | UwReg !GlobalReg !Int -- ^ register plus offset
413 | UwDeref UnwindExpr -- ^ pointer dereferencing
414 | UwLabel CLabel
415 | UwPlus UnwindExpr UnwindExpr
416 | UwMinus UnwindExpr UnwindExpr
417 | UwTimes UnwindExpr UnwindExpr
418 deriving (Eq)
419
420 instance Outputable UnwindExpr where
421 pprPrec _ (UwConst i) = ppr i
422 pprPrec _ (UwReg g 0) = ppr g
423 pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
424 pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e
425 pprPrec _ (UwLabel l) = pprPrec 3 l
426 pprPrec p (UwPlus e0 e1) | p <= 0
427 = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
428 pprPrec p (UwMinus e0 e1) | p <= 0
429 = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1
430 pprPrec p (UwTimes e0 e1) | p <= 1
431 = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
432 pprPrec _ other = parens (pprPrec 0 other)
433
434 -- | Conversion of Cmm expressions to unwind expressions. We check for
435 -- unsupported operator usages and simplify the expression as far as
436 -- possible.
437 toUnwindExpr :: CmmExpr -> UnwindExpr
438 toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
439 toUnwindExpr (CmmLit (CmmLabel l)) = UwLabel l
440 toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
441 toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0
442 toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e)
443 toUnwindExpr e@(CmmMachOp op [e1, e2]) =
444 case (op, toUnwindExpr e1, toUnwindExpr e2) of
445 (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
446 (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
447 (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
448 (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)
449 (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)
450 (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)
451 (MO_Add{}, u1, u2 ) -> UwPlus u1 u2
452 (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
453 (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
454 _otherwise -> pprPanic "Unsupported operator in unwind expression!"
455 (pprExpr e)
456 toUnwindExpr e
457 = pprPanic "Unsupported unwind expression!" (ppr e)