never executed always true always false
1 module GHC.CmmToAsm.Dwarf (
2 dwarfGen
3 ) where
4
5 import GHC.Prelude
6
7 import GHC.Cmm.CLabel
8 import GHC.Cmm.Expr ( GlobalReg(..) )
9 import GHC.Settings.Config ( cProjectName, cProjectVersion )
10 import GHC.Types.Tickish ( CmmTickish, GenTickish(..) )
11 import GHC.Cmm.DebugBlock
12 import GHC.Unit.Module
13 import GHC.Utils.Outputable
14 import GHC.Platform
15 import GHC.Types.Unique
16 import GHC.Types.Unique.Supply
17
18 import GHC.CmmToAsm.Dwarf.Constants
19 import GHC.CmmToAsm.Dwarf.Types
20 import GHC.CmmToAsm.Config
21
22 import Control.Arrow ( first )
23 import Control.Monad ( mfilter )
24 import Data.Maybe
25 import Data.List ( sortBy )
26 import Data.Ord ( comparing )
27 import qualified Data.Map as Map
28 import System.FilePath
29 import System.Directory ( getCurrentDirectory )
30
31 import qualified GHC.Cmm.Dataflow.Label as H
32 import qualified GHC.Cmm.Dataflow.Collections as H
33
34 -- | Generate DWARF/debug information
35 dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
36 -> IO (SDoc, UniqSupply)
37 dwarfGen _ _ us [] = return (empty, us)
38 dwarfGen config modLoc us blocks = do
39 let platform = ncgPlatform config
40
41 -- Convert debug data structures to DWARF info records
42 let procs = debugSplitProcs blocks
43 stripBlocks dbg
44 | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
45 | otherwise = dbg
46 compPath <- getCurrentDirectory
47 let lowLabel = dblCLabel $ head procs
48 highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs
49 dwarfUnit = DwarfCompileUnit
50 { dwChildren = map (procToDwarf config) (map stripBlocks procs)
51 , dwName = fromMaybe "" (ml_hs_file modLoc)
52 , dwCompDir = addTrailingPathSeparator compPath
53 , dwProducer = cProjectName ++ " " ++ cProjectVersion
54 , dwLowLabel = pdoc platform lowLabel
55 , dwHighLabel = pdoc platform highLabel
56 , dwLineLabel = dwarfLineLabel
57 }
58
59 -- Check whether we have any source code information, so we do not
60 -- end up writing a pointer to an empty .debug_line section
61 -- (dsymutil on Mac Os gets confused by this).
62 let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
63 || any haveSrcIn (dblBlocks blk)
64 haveSrc = any haveSrcIn procs
65
66 -- .debug_abbrev section: Declare the format we're using
67 let abbrevSct = pprAbbrevDecls platform haveSrc
68
69 -- .debug_info section: Information records on procedures and blocks
70 let -- unique to identify start and end compilation unit .debug_inf
71 (unitU, us') = takeUniqFromSupply us
72 infoSct = vcat [ dwarfInfoLabel <> colon
73 , dwarfInfoSection platform
74 , compileUnitHeader platform unitU
75 , pprDwarfInfo platform haveSrc dwarfUnit
76 , compileUnitFooter platform unitU
77 ]
78
79 -- .debug_line section: Generated mainly by the assembler, but we
80 -- need to label it
81 let lineSct = dwarfLineSection platform $$
82 dwarfLineLabel <> colon
83
84 -- .debug_frame section: Information about the layout of the GHC stack
85 let (framesU, us'') = takeUniqFromSupply us'
86 frameSct = dwarfFrameSection platform $$
87 dwarfFrameLabel <> colon $$
88 pprDwarfFrame platform (debugFrame framesU procs)
89
90 -- .aranges section: Information about the bounds of compilation units
91 let aranges' | ncgSplitSections config = map mkDwarfARange procs
92 | otherwise = [DwarfARange lowLabel highLabel]
93 let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
94
95 return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
96
97 -- | Build an address range entry for one proc.
98 -- With split sections, each proc needs its own entry, since they may get
99 -- scattered in the final binary. Without split sections, we could make a
100 -- single arange based on the first/last proc.
101 mkDwarfARange :: DebugBlock -> DwarfARange
102 mkDwarfARange proc = DwarfARange lbl end
103 where
104 lbl = dblCLabel proc
105 end = mkAsmTempProcEndLabel lbl
106
107 -- | Header for a compilation unit, establishing global format
108 -- parameters
109 compileUnitHeader :: Platform -> Unique -> SDoc
110 compileUnitHeader platform unitU =
111 let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field
112 length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel
113 <> text "-4" -- length of initialLength field
114 in vcat [ pdoc platform cuLabel <> colon
115 , text "\t.long " <> length -- compilation unit size
116 , pprHalf 3 -- DWARF version
117 , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel
118 -- abbrevs offset
119 , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size
120 ]
121
122 -- | Compilation unit footer, mainly establishing size of debug sections
123 compileUnitFooter :: Platform -> Unique -> SDoc
124 compileUnitFooter platform unitU =
125 let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
126 in pdoc platform cuEndLabel <> colon
127
128 -- | Splits the blocks by procedures. In the result all nested blocks
129 -- will come from the same procedure as the top-level block. See
130 -- Note [Splitting DebugBlocks] for details.
131 debugSplitProcs :: [DebugBlock] -> [DebugBlock]
132 debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
133 where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
134 split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
135 split parent blk = H.mapInsert prc [blk'] nested
136 where prc = dblProcedure blk
137 blk' = blk { dblBlocks = own_blks
138 , dblParent = parent
139 }
140 own_blks = fromMaybe [] $ H.mapLookup prc nested
141 nested = mergeMaps $ map (split parent') $ dblBlocks blk
142 -- Figure out who should be the parent of nested blocks.
143 -- If @blk@ is optimized out then it isn't a good choice
144 -- and we just use its parent.
145 parent'
146 | Nothing <- dblPosition blk = parent
147 | otherwise = Just blk
148
149 {-
150 Note [Splitting DebugBlocks]
151
152 DWARF requires that we break up the nested DebugBlocks produced from
153 the C-- AST. For instance, we begin with tick trees containing nested procs.
154 For example,
155
156 proc A [tick1, tick2]
157 block B [tick3]
158 proc C [tick4]
159
160 when producing DWARF we need to procs (which are represented in DWARF as
161 TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for
162 this transform, pulling out the nested procs into top-level procs.
163
164 However, in doing this we need to be careful to preserve the parentage of the
165 nested procs. This is the reason DebugBlocks carry the dblParent field, allowing
166 us to reorganize the above tree as,
167
168 proc A [tick1, tick2]
169 block B [tick3]
170 proc C [tick4] parent=B
171
172 Here we have annotated the new proc C with an attribute giving its original
173 parent, B.
174 -}
175
176 -- | Generate DWARF info for a procedure debug block
177 procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
178 procToDwarf config prc
179 = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)
180 , dwName = case dblSourceTick prc of
181 Just s@SourceNote{} -> sourceName s
182 _otherwise -> show (dblLabel prc)
183 , dwLabel = dblCLabel prc
184 , dwParent = fmap mkAsmTempDieLabel
185 $ mfilter goodParent
186 $ fmap dblCLabel (dblParent prc)
187 }
188 where
189 goodParent a | a == dblCLabel prc = False
190 -- Omit parent if it would be self-referential
191 goodParent a | not (externallyVisibleCLabel a)
192 , ncgDwarfStripBlockInfo config = False
193 -- If we strip block information, don't refer to blocks.
194 -- Fixes #14894.
195 goodParent _ = True
196
197 -- | Generate DWARF info for a block
198 blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
199 blockToDwarf config blk
200 = DwarfBlock { dwChildren = map (blockToDwarf config) (dblBlocks blk) ++ srcNotes
201 , dwLabel = dblCLabel blk
202 , dwMarker = marker
203 }
204 where
205 srcNotes
206 | ncgDwarfSourceNotes config = concatMap tickToDwarf (dblTicks blk)
207 | otherwise = []
208
209 marker
210 | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
211 | otherwise = Nothing -- block was optimized out
212
213 tickToDwarf :: CmmTickish -> [DwarfInfo]
214 tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss]
215 tickToDwarf _ = []
216
217 -- | Generates the data for the debug frame section, which encodes the
218 -- desired stack unwind behaviour for the debugger
219 debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
220 debugFrame u procs
221 = DwarfFrame { dwCieLabel = mkAsmTempLabel u
222 , dwCieInit = initUws
223 , dwCieProcs = map (procToFrame initUws) procs
224 }
225 where
226 initUws :: UnwindTable
227 initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]
228
229 -- | Generates unwind information for a procedure debug block
230 procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
231 procToFrame initUws blk
232 = DwarfFrameProc { dwFdeProc = dblCLabel blk
233 , dwFdeHasInfo = dblHasInfoTbl blk
234 , dwFdeBlocks = map (uncurry blockToFrame)
235 (setHasInfo blockUws)
236 }
237 where blockUws :: [(DebugBlock, [UnwindPoint])]
238 blockUws = map snd $ sortBy (comparing fst) $ flatten blk
239
240 flatten :: DebugBlock
241 -> [(Int, (DebugBlock, [UnwindPoint]))]
242 flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
243 | Just p <- pos = (p, (b, uws')):nested
244 | otherwise = nested -- block was optimized out
245 where uws' = addDefaultUnwindings initUws uws
246 nested = concatMap flatten blocks
247
248 -- | If the current procedure has an info table, then we also say that
249 -- its first block has one to ensure that it gets the necessary -1
250 -- offset applied to its start address.
251 -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types".
252 setHasInfo :: [(DebugBlock, [UnwindPoint])]
253 -> [(DebugBlock, [UnwindPoint])]
254 setHasInfo [] = []
255 setHasInfo (c0:cs) = first setIt c0 : cs
256 where
257 setIt child =
258 child { dblHasInfoTbl = dblHasInfoTbl child
259 || dblHasInfoTbl blk }
260
261 blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
262 blockToFrame blk uws
263 = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
264 , dwFdeUnwind = uws
265 }
266
267 addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
268 addDefaultUnwindings tbl pts =
269 [ UnwindPoint lbl (tbl' `mappend` tbl)
270 -- mappend is left-biased
271 | UnwindPoint lbl tbl' <- pts
272 ]