Implement function-sections for Haskell code, #8405
[ghc.git] / compiler / nativeGen / Dwarf.hs
1 module Dwarf (
2 dwarfGen
3 ) where
4
5 import CLabel
6 import CmmExpr ( GlobalReg(..) )
7 import Config ( cProjectName, cProjectVersion )
8 import CoreSyn ( Tickish(..) )
9 import Debug
10 import DynFlags
11 import FastString
12 import Module
13 import Outputable
14 import Platform
15 import Unique
16 import UniqSupply
17
18 import Dwarf.Constants
19 import Dwarf.Types
20
21 import Data.Maybe
22 import Data.List ( sortBy )
23 import Data.Ord ( comparing )
24 import qualified Data.Map as Map
25 import System.FilePath
26 import System.Directory ( getCurrentDirectory )
27
28 import qualified Compiler.Hoopl as H
29
30 -- | Generate DWARF/debug information
31 dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
32 -> IO (SDoc, UniqSupply)
33 dwarfGen _ _ us [] = return (empty, us)
34 dwarfGen df modLoc us blocks = do
35
36 -- Convert debug data structures to DWARF info records
37 -- We strip out block information, as it is not currently useful for
38 -- anything. In future we might want to only do this for -g1.
39 let procs = debugSplitProcs blocks
40 stripBlocks dbg = dbg { dblBlocks = [] }
41 compPath <- getCurrentDirectory
42 let lowLabel = dblCLabel $ head procs
43 highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
44 dwarfUnit = DwarfCompileUnit
45 { dwChildren = map (procToDwarf df) (map stripBlocks procs)
46 , dwName = fromMaybe "" (ml_hs_file modLoc)
47 , dwCompDir = addTrailingPathSeparator compPath
48 , dwProducer = cProjectName ++ " " ++ cProjectVersion
49 , dwLowLabel = lowLabel
50 , dwHighLabel = highLabel
51 , dwLineLabel = dwarfLineLabel
52 }
53
54 -- Check whether we have any source code information, so we do not
55 -- end up writing a pointer to an empty .debug_line section
56 -- (dsymutil on Mac Os gets confused by this).
57 let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
58 || any haveSrcIn (dblBlocks blk)
59 haveSrc = any haveSrcIn procs
60
61 -- .debug_abbrev section: Declare the format we're using
62 let abbrevSct = pprAbbrevDecls haveSrc
63
64 -- .debug_info section: Information records on procedures and blocks
65 let -- unique to identify start and end compilation unit .debug_inf
66 (unitU, us') = takeUniqFromSupply us
67 infoSct = vcat [ ptext dwarfInfoLabel <> colon
68 , dwarfInfoSection
69 , compileUnitHeader unitU
70 , pprDwarfInfo haveSrc dwarfUnit
71 , compileUnitFooter unitU
72 ]
73
74 -- .debug_line section: Generated mainly by the assembler, but we
75 -- need to label it
76 let lineSct = dwarfLineSection $$
77 ptext dwarfLineLabel <> colon
78
79 -- .debug_frame section: Information about the layout of the GHC stack
80 let (framesU, us'') = takeUniqFromSupply us'
81 frameSct = dwarfFrameSection $$
82 ptext dwarfFrameLabel <> colon $$
83 pprDwarfFrame (debugFrame framesU procs)
84
85 -- .aranges section: Information about the bounds of compilation units
86 let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
87 | otherwise = [DwarfARange lowLabel highLabel]
88 let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
89
90 return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
91
92 -- | Build an address range entry for one proc.
93 -- With split sections, each proc needs its own entry, since they may get
94 -- scattered in the final binary. Without split sections, we could make a
95 -- single arange based on the first/last proc.
96 mkDwarfARange :: DebugBlock -> DwarfARange
97 mkDwarfARange proc = DwarfARange start end
98 where
99 start = dblCLabel proc
100 end = mkAsmTempEndLabel start
101
102 -- | Header for a compilation unit, establishing global format
103 -- parameters
104 compileUnitHeader :: Unique -> SDoc
105 compileUnitHeader unitU = sdocWithPlatform $ \plat ->
106 let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field
107 length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
108 <> ptext (sLit "-4") -- length of initialLength field
109 in vcat [ ppr cuLabel <> colon
110 , ptext (sLit "\t.long ") <> length -- compilation unit size
111 , pprHalf 3 -- DWARF version
112 , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
113 -- abbrevs offset
114 , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size
115 ]
116
117 -- | Compilation unit footer, mainly establishing size of debug sections
118 compileUnitFooter :: Unique -> SDoc
119 compileUnitFooter unitU =
120 let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
121 in ppr cuEndLabel <> colon
122
123 -- | Splits the blocks by procedures. In the result all nested blocks
124 -- will come from the same procedure as the top-level block.
125 debugSplitProcs :: [DebugBlock] -> [DebugBlock]
126 debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map split b
127 where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
128 split :: DebugBlock -> H.LabelMap [DebugBlock]
129 split blk = H.mapInsert prc [blk {dblBlocks = own_blks}] nested
130 where prc = dblProcedure blk
131 own_blks = fromMaybe [] $ H.mapLookup prc nested
132 nested = mergeMaps $ map split $ dblBlocks blk
133 -- Note that we are rebuilding the tree here, so tick scopes
134 -- might change. We could fix that - but we actually only care
135 -- about dblSourceTick in the result, so this is okay.
136
137 -- | Generate DWARF info for a procedure debug block
138 procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
139 procToDwarf df prc
140 = DwarfSubprogram { dwChildren = foldr blockToDwarf [] $ dblBlocks prc
141 , dwName = case dblSourceTick prc of
142 Just s@SourceNote{} -> sourceName s
143 _otherwise -> showSDocDump df $ ppr $ dblLabel prc
144 , dwLabel = dblCLabel prc
145 }
146
147 -- | Generate DWARF info for a block
148 blockToDwarf :: DebugBlock -> [DwarfInfo] -> [DwarfInfo]
149 blockToDwarf blk dws
150 | isJust (dblPosition blk) = dw : dws
151 | otherwise = nested ++ dws -- block was optimized out, flatten
152 where nested = foldr blockToDwarf [] $ dblBlocks blk
153 dw = DwarfBlock { dwChildren = nested
154 , dwLabel = dblCLabel blk
155 , dwMarker = mkAsmTempLabel (dblLabel blk)
156 }
157
158 -- | Generates the data for the debug frame section, which encodes the
159 -- desired stack unwind behaviour for the debugger
160 debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
161 debugFrame u procs
162 = DwarfFrame { dwCieLabel = mkAsmTempLabel u
163 , dwCieInit = initUws
164 , dwCieProcs = map (procToFrame initUws) procs
165 }
166 where initUws = Map.fromList [(Sp, UwReg Sp 0)]
167
168 -- | Generates unwind information for a procedure debug block
169 procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
170 procToFrame initUws blk
171 = DwarfFrameProc { dwFdeProc = dblCLabel blk
172 , dwFdeHasInfo = dblHasInfoTbl blk
173 , dwFdeBlocks = map (uncurry blockToFrame) blockUws
174 }
175 where blockUws :: [(DebugBlock, UnwindTable)]
176 blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk
177 flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws,
178 dblBlocks=blocks }
179 | Just p <- pos = (p, (b, uws')):nested
180 | otherwise = nested -- block was optimized out
181 where uws' = uws `Map.union` uws0
182 nested = concatMap (flatten uws') blocks
183
184 blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock
185 blockToFrame blk uws
186 = DwarfFrameBlock { dwFdeBlock = mkAsmTempLabel $ dblLabel blk
187 , dwFdeBlkHasInfo = dblHasInfoTbl blk
188 , dwFdeUnwind = uws
189 }