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
|
module Dwarf (
dwarfGen
) where
import CLabel
import CmmExpr ( GlobalReg(..) )
import Config ( cProjectName, cProjectVersion )
import CoreSyn ( Tickish(..) )
import Debug
import DynFlags
import FastString
import Module
import Outputable
import Platform
import Unique
import UniqSupply
import Dwarf.Constants
import Dwarf.Types
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 Compiler.Hoopl as H
-- | Generate DWARF/debug information
dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen df modLoc us blocks = do
-- Convert debug data structures to DWARF info records
-- We strip out block information, as it is not currently useful for
-- anything. In future we might want to only do this for -g1.
let procs = debugSplitProcs blocks
stripBlocks dbg = dbg { dblBlocks = [] }
compPath <- getCurrentDirectory
let dwarfUnit = DwarfCompileUnit
{ dwChildren = map (procToDwarf df) (map stripBlocks procs)
, dwName = fromMaybe "" (ml_hs_file modLoc)
, dwCompDir = addTrailingPathSeparator compPath
, dwProducer = cProjectName ++ " " ++ cProjectVersion
, 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 haveSrc
-- .debug_info section: Information records on procedures and blocks
let (unitU, us') = takeUniqFromSupply us
infoSct = vcat [ dwarfInfoSection
, compileUnitHeader unitU
, pprDwarfInfo haveSrc dwarfUnit
, compileUnitFooter unitU
]
-- .debug_line section: Generated mainly by the assembler, but we
-- need to label it
let lineSct = dwarfLineSection $$
ptext dwarfLineLabel <> colon
-- .debug_frame section: Information about the layout of the GHC stack
let (framesU, us'') = takeUniqFromSupply us'
frameSct = dwarfFrameSection $$
ptext dwarfFrameLabel <> colon $$
pprDwarfFrame (debugFrame framesU procs)
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct, us'')
-- | Header for a compilation unit, establishing global format
-- parameters
compileUnitHeader :: Unique -> SDoc
compileUnitHeader unitU = sdocWithPlatform $ \plat ->
let cuLabel = mkAsmTempLabel unitU
length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
in vcat [ ptext (sLit "\t.long ") <> length -- compilation unit size
, ppr cuLabel <> colon
, ptext (sLit "\t.word 3") -- DWARF version
, pprDwWord (sectionOffset dwarfAbbrevLabel dwarfAbbrevLabel)
-- abbrevs offset
, ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size
]
-- | Compilation unit footer, mainly establishing size of debug sections
compileUnitFooter :: Unique -> SDoc
compileUnitFooter unitU =
let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
in ppr cuEndLabel <> colon
-- | Splits the blocks by procedures. In the result all nested blocks
-- will come from the same procedure as the top-level block.
debugSplitProcs :: [DebugBlock] -> [DebugBlock]
debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map split b
where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
split :: DebugBlock -> H.LabelMap [DebugBlock]
split blk = H.mapInsert prc [blk {dblBlocks = own_blks}] nested
where prc = dblProcedure blk
own_blks = fromMaybe [] $ H.mapLookup prc nested
nested = mergeMaps $ map split $ dblBlocks blk
-- Note that we are rebuilding the tree here, so tick scopes
-- might change. We could fix that - but we actually only care
-- about dblSourceTick in the result, so this is okay.
-- | Generate DWARF info for a procedure debug block
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf df prc
= DwarfSubprogram { dwChildren = foldr blockToDwarf [] $ dblBlocks prc
, dwName = case dblSourceTick prc of
Just s@SourceNote{} -> sourceName s
_otherwise -> showSDocDump df $ ppr $ dblLabel prc
, dwLabel = dblCLabel prc
}
-- | Generate DWARF info for a block
blockToDwarf :: DebugBlock -> [DwarfInfo] -> [DwarfInfo]
blockToDwarf blk dws
| isJust (dblPosition blk) = dw : dws
| otherwise = nested ++ dws -- block was optimized out, flatten
where nested = foldr blockToDwarf [] $ dblBlocks blk
dw = DwarfBlock { dwChildren = nested
, dwLabel = dblCLabel blk
, dwMarker = mkAsmTempLabel (dblLabel blk)
}
-- | 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 = Map.fromList [(Sp, 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) blockUws
}
where blockUws :: [(DebugBlock, UnwindTable)]
blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk
flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws,
dblBlocks=blocks }
| Just p <- pos = (p, (b, uws')):nested
| otherwise = nested -- block was optimized out
where uws' = uws `Map.union` uws0
nested = concatMap (flatten uws') blocks
blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock
blockToFrame blk uws
= DwarfFrameBlock { dwFdeBlock = mkAsmTempLabel $ dblLabel blk
, dwFdeBlkHasInfo = dblHasInfoTbl blk
, dwFdeUnwind = uws
}
|
