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