Fix #11407.
[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 UnwindTable, UnwindExpr(..),
16 cmmDebugGen,
17 cmmDebugLabels,
18 cmmDebugLink,
19 debugToMap
20
21 ) where
22
23 import BlockId ( blockLbl )
24 import CLabel
25 import Cmm
26 import CmmUtils
27 import CoreSyn
28 import FastString ( nilFS, mkFastString )
29 import Module
30 import Outputable
31 import PprCore ()
32 import PprCmmExpr ( pprExpr )
33 import SrcLoc
34 import Util
35
36 import Compiler.Hoopl
37
38 import Data.Maybe
39 import Data.List ( minimumBy, nubBy )
40 import Data.Ord ( comparing )
41 import qualified Data.Map as Map
42
43 -- | Debug information about a block of code. Ticks scope over nested
44 -- blocks.
45 data DebugBlock =
46 DebugBlock
47 { dblProcedure :: !Label -- ^ Entry label of containing proc
48 , dblLabel :: !Label -- ^ Hoopl label
49 , dblCLabel :: !CLabel -- ^ Output label
50 , dblHasInfoTbl :: !Bool -- ^ Has an info table?
51 , dblParent :: !(Maybe DebugBlock)
52 -- ^ The parent of this proc. See Note [Splitting DebugBlocks]
53 , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block
54 , dblSourceTick
55 :: !(Maybe CmmTickish) -- ^ Best source tick covering block
56 , dblPosition :: !(Maybe Int) -- ^ Output position relative to
57 -- other blocks. @Nothing@ means
58 -- the block was optimized out
59 , dblUnwind :: !UnwindTable -- ^ Unwind information
60 , dblBlocks :: ![DebugBlock] -- ^ Nested blocks
61 }
62
63 -- | Is this the entry block?
64 dblIsEntry :: DebugBlock -> Bool
65 dblIsEntry blk = dblProcedure blk == dblLabel blk
66
67 instance Outputable DebugBlock where
68 ppr blk = (if dblProcedure blk == dblLabel blk
69 then text "proc "
70 else if dblHasInfoTbl blk
71 then text "pp-blk "
72 else text "blk ") <>
73 ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
74 (maybe empty ppr (dblSourceTick blk)) <+>
75 (maybe (text "removed") ((text "pos " <>) . ppr)
76 (dblPosition blk)) <+>
77 pprUwMap (dblUnwind blk) $$
78 (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
79 where pprUw (g, expr) = ppr g <> char '=' <> ppr expr
80 pprUwMap = braces . hsep . punctuate comma . map pprUw . Map.toList
81
82 -- | Intermediate data structure holding debug-relevant context information
83 -- about a block.
84 type BlockContext = (CmmBlock, RawCmmDecl, UnwindTable)
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 . fstOf3)
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 mkBlock top (block, prc, unwind)
155 = DebugBlock { dblProcedure = g_entry graph
156 , dblLabel = label
157 , dblCLabel = case info of
158 Just (Statics infoLbl _) -> infoLbl
159 Nothing
160 | g_entry graph == label -> entryLbl
161 | otherwise -> blockLbl label
162 , dblHasInfoTbl = isJust info
163 , dblParent = Nothing
164 , dblTicks = ticks
165 , dblPosition = Nothing -- see cmmDebugLink
166 , dblUnwind = unwind
167 , dblSourceTick = stick
168 , dblBlocks = blocks
169 }
170 where (CmmProc infos entryLbl _ graph) = prc
171 label = entryLabel block
172 info = mapLookup label infos
173 blocks | top = seqList childs childs
174 | otherwise = []
175
176 -- A source tick scopes over all nested blocks. However
177 -- their source ticks might take priority.
178 isSourceTick SourceNote {} = True
179 isSourceTick _ = False
180 -- Collect ticks from all blocks inside the tick scope.
181 -- We attempt to filter out duplicates while we're at it.
182 ticks = nubBy (flip tickishContains) $
183 bCtxsTicks bctxs ++ ticksToCopy scope
184 stick = case filter isSourceTick ticks of
185 [] -> cstick
186 sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
187
188 -- | Build a map of blocks sorted by their tick scopes
189 --
190 -- This involves a pre-order traversal, as we want blocks in rough
191 -- control flow order (so ticks have a chance to be sorted in the
192 -- right order). We also use this opportunity to have blocks inherit
193 -- unwind information from their predecessor blocks where it is
194 -- lacking.
195 blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
196 blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
197 where walkProc CmmData{} m = m
198 walkProc prc@(CmmProc _ _ _ graph) m
199 | mapNull blocks = m
200 | otherwise = snd $ walkBlock prc entry Map.empty (emptyLbls, m)
201 where blocks = toBlockMap graph
202 entry = [mapFind (g_entry graph) blocks]
203 emptyLbls = setEmpty :: LabelSet
204 walkBlock _ [] _ c = c
205 walkBlock prc (block:blocks) unwind (visited, m)
206 | lbl `setMember` visited
207 = walkBlock prc blocks unwind (visited, m)
208 | otherwise
209 = walkBlock prc blocks unwind $
210 walkBlock prc succs unwind'
211 (lbl `setInsert` visited,
212 insertMulti scope (block, prc, unwind') m)
213 where CmmEntry lbl scope = firstNode block
214 unwind' = extractUnwind block `Map.union` unwind
215 (CmmProc _ _ _ graph) = prc
216 succs = map (flip mapFind (toBlockMap graph))
217 (successors (lastNode block))
218 mapFind = mapFindWithDefault (error "contextTree: block not found!")
219
220 insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
221 insertMulti k v = Map.insertWith (const (v:)) k [v]
222
223 cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
224 cmmDebugLabels isMeta nats = seqList lbls lbls
225 where -- Find order in which procedures will be generated by the
226 -- back-end (that actually matters for DWARF generation).
227 --
228 -- Note that we might encounter blocks that are missing or only
229 -- consist of meta instructions -- we will declare them missing,
230 -- which will skip debug data generation without messing up the
231 -- block hierarchy.
232 lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
233 getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
234 getBlocks _other = []
235 allMeta (BasicBlock _ instrs) = all isMeta instrs
236
237 -- | Sets position fields in the debug block tree according to native
238 -- generated code.
239 cmmDebugLink :: [Label] -> [DebugBlock] -> [DebugBlock]
240 cmmDebugLink labels blocks = map link blocks
241 where blockPos :: LabelMap Int
242 blockPos = mapFromList $ flip zip [0..] labels
243 link block = block { dblPosition = mapLookup (dblLabel block) blockPos
244 , dblBlocks = map link (dblBlocks block)
245 }
246
247 -- | Converts debug blocks into a label map for easier lookups
248 debugToMap :: [DebugBlock] -> LabelMap DebugBlock
249 debugToMap = mapUnions . map go
250 where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
251
252 -- | Maps registers to expressions that yield their "old" values
253 -- further up the stack. Most interesting for the stack pointer Sp,
254 -- but might be useful to document saved registers, too.
255 type UnwindTable = Map.Map GlobalReg UnwindExpr
256
257 -- | Expressions, used for unwind information
258 data UnwindExpr = UwConst Int -- ^ literal value
259 | UwReg GlobalReg Int -- ^ register plus offset
260 | UwDeref UnwindExpr -- ^ pointer dereferencing
261 | UwPlus UnwindExpr UnwindExpr
262 | UwMinus UnwindExpr UnwindExpr
263 | UwTimes UnwindExpr UnwindExpr
264 deriving (Eq)
265
266 instance Outputable UnwindExpr where
267 pprPrec _ (UwConst i) = ppr i
268 pprPrec _ (UwReg g 0) = ppr g
269 pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
270 pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e
271 pprPrec p (UwPlus e0 e1) | p <= 0
272 = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
273 pprPrec p (UwMinus e0 e1) | p <= 0
274 = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1
275 pprPrec p (UwTimes e0 e1) | p <= 1
276 = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
277 pprPrec _ other = parens (pprPrec 0 other)
278
279 extractUnwind :: CmmBlock -> UnwindTable
280 extractUnwind b = go $ blockToList mid
281 where (_, mid, _) = blockSplit b
282 go :: [CmmNode O O] -> UnwindTable
283 go [] = Map.empty
284 go (x : xs) = case x of
285 CmmUnwind g so -> Map.insert g (toUnwindExpr so) $! go xs
286 CmmTick {} -> go xs
287 _other -> Map.empty
288 -- TODO: Unwind statements after actual instructions
289
290 -- | Conversion of Cmm expressions to unwind expressions. We check for
291 -- unsupported operator usages and simplify the expression as far as
292 -- possible.
293 toUnwindExpr :: CmmExpr -> UnwindExpr
294 toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
295 toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
296 toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0
297 toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e)
298 toUnwindExpr e@(CmmMachOp op [e1, e2]) =
299 case (op, toUnwindExpr e1, toUnwindExpr e2) of
300 (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
301 (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
302 (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
303 (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)
304 (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)
305 (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)
306 (MO_Add{}, u1, u2 ) -> UwPlus u1 u2
307 (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
308 (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
309 _otherwise -> pprPanic "Unsupported operator in unwind expression!"
310 (pprExpr e)
311 toUnwindExpr e
312 = pprPanic "Unsupported unwind expression!" (ppr e)