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