never executed always true always false
1 {-# LANGUAGE MultiParamTypeClasses #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE UndecidableInstances #-}
5
6 module GHC.CmmToAsm.Dwarf.Types
7 ( -- * Dwarf information
8 DwarfInfo(..)
9 , pprDwarfInfo
10 , pprAbbrevDecls
11 -- * Dwarf address range table
12 , DwarfARange(..)
13 , pprDwarfARanges
14 -- * Dwarf frame
15 , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
16 , pprDwarfFrame
17 -- * Utilities
18 , pprByte
19 , pprHalf
20 , pprData4'
21 , pprDwWord
22 , pprWord
23 , pprLEBWord
24 , pprLEBInt
25 , wordAlign
26 , sectionOffset
27 )
28 where
29
30 import GHC.Prelude
31
32 import GHC.Cmm.DebugBlock
33 import GHC.Cmm.CLabel
34 import GHC.Cmm.Expr ( GlobalReg(..) )
35 import GHC.Utils.Encoding
36 import GHC.Data.FastString
37 import GHC.Utils.Outputable
38 import GHC.Platform
39 import GHC.Types.Unique
40 import GHC.Platform.Reg
41 import GHC.Types.SrcLoc
42 import GHC.Utils.Misc
43
44 import GHC.CmmToAsm.Dwarf.Constants
45
46 import qualified Data.ByteString as BS
47 import qualified GHC.Utils.Monad.State.Strict as S
48 import Control.Monad (zipWithM, join)
49 import qualified Data.Map as Map
50 import Data.Word
51 import Data.Char
52
53 import GHC.Platform.Regs
54
55 -- | Individual dwarf records. Each one will be encoded as an entry in
56 -- the @.debug_info@ section.
57 data DwarfInfo
58 = DwarfCompileUnit { dwChildren :: [DwarfInfo]
59 , dwName :: String
60 , dwProducer :: String
61 , dwCompDir :: String
62 , dwLowLabel :: SDoc
63 , dwHighLabel :: SDoc
64 , dwLineLabel :: SDoc }
65 | DwarfSubprogram { dwChildren :: [DwarfInfo]
66 , dwName :: String
67 , dwLabel :: CLabel
68 , dwParent :: Maybe CLabel
69 -- ^ label of DIE belonging to the parent tick
70 }
71 | DwarfBlock { dwChildren :: [DwarfInfo]
72 , dwLabel :: CLabel
73 , dwMarker :: Maybe CLabel
74 }
75 | DwarfSrcNote { dwSrcSpan :: RealSrcSpan
76 }
77
78 -- | Abbreviation codes used for encoding above records in the
79 -- @.debug_info@ section.
80 data DwarfAbbrev
81 = DwAbbrNull -- ^ Pseudo, used for marking the end of lists
82 | DwAbbrCompileUnit
83 | DwAbbrSubprogram
84 | DwAbbrSubprogramWithParent
85 | DwAbbrBlockWithoutCode
86 | DwAbbrBlock
87 | DwAbbrGhcSrcNote
88 deriving (Eq, Enum)
89
90 -- | Generate assembly for the given abbreviation code
91 pprAbbrev :: DwarfAbbrev -> SDoc
92 pprAbbrev = pprLEBWord . fromIntegral . fromEnum
93
94 -- | Abbreviation declaration. This explains the binary encoding we
95 -- use for representing 'DwarfInfo'. Be aware that this must be updated
96 -- along with 'pprDwarfInfo'.
97 pprAbbrevDecls :: Platform -> Bool -> SDoc
98 pprAbbrevDecls platform haveDebugLine =
99 let mkAbbrev abbr tag chld flds =
100 let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
101 in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
102 vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
103 -- These are shared between DwAbbrSubprogram and
104 -- DwAbbrSubprogramWithParent
105 subprogramAttrs =
106 [ (dW_AT_name, dW_FORM_string)
107 , (dW_AT_linkage_name, dW_FORM_string)
108 , (dW_AT_external, dW_FORM_flag)
109 , (dW_AT_low_pc, dW_FORM_addr)
110 , (dW_AT_high_pc, dW_FORM_addr)
111 , (dW_AT_frame_base, dW_FORM_block1)
112 ]
113 in dwarfAbbrevSection platform $$
114 dwarfAbbrevLabel <> colon $$
115 mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
116 ([(dW_AT_name, dW_FORM_string)
117 , (dW_AT_producer, dW_FORM_string)
118 , (dW_AT_language, dW_FORM_data4)
119 , (dW_AT_comp_dir, dW_FORM_string)
120 , (dW_AT_use_UTF8, dW_FORM_flag_present) -- not represented in body
121 , (dW_AT_low_pc, dW_FORM_addr)
122 , (dW_AT_high_pc, dW_FORM_addr)
123 ] ++
124 (if haveDebugLine
125 then [ (dW_AT_stmt_list, dW_FORM_data4) ]
126 else [])) $$
127 mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
128 subprogramAttrs $$
129 mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes
130 (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$
131 mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes
132 [ (dW_AT_name, dW_FORM_string)
133 ] $$
134 mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes
135 [ (dW_AT_name, dW_FORM_string)
136 , (dW_AT_low_pc, dW_FORM_addr)
137 , (dW_AT_high_pc, dW_FORM_addr)
138 ] $$
139 mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no
140 [ (dW_AT_ghc_span_file, dW_FORM_string)
141 , (dW_AT_ghc_span_start_line, dW_FORM_data4)
142 , (dW_AT_ghc_span_start_col, dW_FORM_data2)
143 , (dW_AT_ghc_span_end_line, dW_FORM_data4)
144 , (dW_AT_ghc_span_end_col, dW_FORM_data2)
145 ] $$
146 pprByte 0
147
148 -- | Generate assembly for DWARF data
149 pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc
150 pprDwarfInfo platform haveSrc d
151 = case d of
152 DwarfCompileUnit {} -> hasChildren
153 DwarfSubprogram {} -> hasChildren
154 DwarfBlock {} -> hasChildren
155 DwarfSrcNote {} -> noChildren
156 where
157 hasChildren =
158 pprDwarfInfoOpen platform haveSrc d $$
159 vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
160 pprDwarfInfoClose
161 noChildren = pprDwarfInfoOpen platform haveSrc d
162
163 -- | Print a CLabel name in a ".stringz \"LABEL\""
164 pprLabelString :: Platform -> CLabel -> SDoc
165 pprLabelString platform label =
166 pprString' -- we don't need to escape the string as labels don't contain exotic characters
167 $ pprCLabel platform CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm)
168
169 -- | Prints assembler data corresponding to DWARF info records. Note
170 -- that the binary format of this is parameterized in @abbrevDecls@ and
171 -- has to be kept in synch.
172 pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc
173 pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
174 highLabel lineLbl) =
175 pprAbbrev DwAbbrCompileUnit
176 $$ pprString name
177 $$ pprString producer
178 $$ pprData4 dW_LANG_Haskell
179 $$ pprString compDir
180 -- Offset due to Note [Info Offset]
181 $$ pprWord platform (lowLabel <> text "-1")
182 $$ pprWord platform highLabel
183 $$ if haveSrc
184 then sectionOffset platform lineLbl dwarfLineLabel
185 else empty
186 pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
187 pdoc platform (mkAsmTempDieLabel label) <> colon
188 $$ pprAbbrev abbrev
189 $$ pprString name
190 $$ pprLabelString platform label
191 $$ pprFlag (externallyVisibleCLabel label)
192 -- Offset due to Note [Info Offset]
193 $$ pprWord platform (pdoc platform label <> text "-1")
194 $$ pprWord platform (pdoc platform $ mkAsmTempProcEndLabel label)
195 $$ pprByte 1
196 $$ pprByte dW_OP_call_frame_cfa
197 $$ parentValue
198 where
199 abbrev = case parent of Nothing -> DwAbbrSubprogram
200 Just _ -> DwAbbrSubprogramWithParent
201 parentValue = maybe empty pprParentDie parent
202 pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel
203 pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =
204 pdoc platform (mkAsmTempDieLabel label) <> colon
205 $$ pprAbbrev DwAbbrBlockWithoutCode
206 $$ pprLabelString platform label
207 pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =
208 pdoc platform (mkAsmTempDieLabel label) <> colon
209 $$ pprAbbrev DwAbbrBlock
210 $$ pprLabelString platform label
211 $$ pprWord platform (pdoc platform marker)
212 $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel marker)
213 pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
214 pprAbbrev DwAbbrGhcSrcNote
215 $$ pprString' (ftext $ srcSpanFile ss)
216 $$ pprData4 (fromIntegral $ srcSpanStartLine ss)
217 $$ pprHalf (fromIntegral $ srcSpanStartCol ss)
218 $$ pprData4 (fromIntegral $ srcSpanEndLine ss)
219 $$ pprHalf (fromIntegral $ srcSpanEndCol ss)
220
221 -- | Close a DWARF info record with children
222 pprDwarfInfoClose :: SDoc
223 pprDwarfInfoClose = pprAbbrev DwAbbrNull
224
225 -- | A DWARF address range. This is used by the debugger to quickly locate
226 -- which compilation unit a given address belongs to. This type assumes
227 -- a non-segmented address-space.
228 data DwarfARange
229 = DwarfARange
230 { dwArngStartLabel :: CLabel
231 , dwArngEndLabel :: CLabel
232 }
233
234 -- | Print assembler directives corresponding to a DWARF @.debug_aranges@
235 -- address table entry.
236 pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc
237 pprDwarfARanges platform arngs unitU =
238 let wordSize = platformWordSizeInBytes platform
239 paddingSize = 4 :: Int
240 -- header is 12 bytes long.
241 -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
242 -- pad such that first entry begins at multiple of entry size.
243 pad n = vcat $ replicate n $ pprByte 0
244 -- Fix for #17428
245 initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
246 in pprDwWord (ppr initialLength)
247 $$ pprHalf 2
248 $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel
249 $$ pprByte (fromIntegral wordSize)
250 $$ pprByte 0
251 $$ pad paddingSize
252 -- body
253 $$ vcat (map (pprDwarfARange platform) arngs)
254 -- terminus
255 $$ pprWord platform (char '0')
256 $$ pprWord platform (char '0')
257
258 pprDwarfARange :: Platform -> DwarfARange -> SDoc
259 pprDwarfARange platform arng =
260 -- Offset due to Note [Info offset].
261 pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1")
262 $$ pprWord platform length
263 where
264 length = pdoc platform (dwArngEndLabel arng)
265 <> char '-' <> pdoc platform (dwArngStartLabel arng)
266
267 -- | Information about unwind instructions for a procedure. This
268 -- corresponds to a "Common Information Entry" (CIE) in DWARF.
269 data DwarfFrame
270 = DwarfFrame
271 { dwCieLabel :: CLabel
272 , dwCieInit :: UnwindTable
273 , dwCieProcs :: [DwarfFrameProc]
274 }
275
276 -- | Unwind instructions for an individual procedure. Corresponds to a
277 -- "Frame Description Entry" (FDE) in DWARF.
278 data DwarfFrameProc
279 = DwarfFrameProc
280 { dwFdeProc :: CLabel
281 , dwFdeHasInfo :: Bool
282 , dwFdeBlocks :: [DwarfFrameBlock]
283 -- ^ List of blocks. Order must match asm!
284 }
285
286 -- | Unwind instructions for a block. Will become part of the
287 -- containing FDE.
288 data DwarfFrameBlock
289 = DwarfFrameBlock
290 { dwFdeBlkHasInfo :: Bool
291 , dwFdeUnwind :: [UnwindPoint]
292 -- ^ these unwind points must occur in the same order as they occur
293 -- in the block
294 }
295
296 instance OutputableP env CLabel => OutputableP env DwarfFrameBlock where
297 pdoc env (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc env unwinds
298
299 -- | Header for the @.debug_frame@ section. Here we emit the "Common
300 -- Information Entry" record that establishes general call frame
301 -- parameters and the default stack layout.
302 pprDwarfFrame :: Platform -> DwarfFrame -> SDoc
303 pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
304 = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
305 cieEndLabel = mkAsmTempEndLabel cieLabel
306 length = pdoc platform cieEndLabel <> char '-' <> pdoc platform cieStartLabel
307 spReg = dwarfGlobalRegNo platform Sp
308 retReg = dwarfReturnRegNo platform
309 wordSize = platformWordSizeInBytes platform
310 pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
311 pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)
312
313 -- Preserve C stack pointer: This necessary to override that default
314 -- unwinding behavior of setting $sp = CFA.
315 preserveSp = case platformArch platform of
316 ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4
317 ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
318 _ -> empty
319 in vcat [ pdoc platform cieLabel <> colon
320 , pprData4' length -- Length of CIE
321 , pdoc platform cieStartLabel <> colon
322 , pprData4' (text "-1")
323 -- Common Information Entry marker (-1 = 0xf..f)
324 , pprByte 3 -- CIE version (we require DWARF 3)
325 , pprByte 0 -- Augmentation (none)
326 , pprByte 1 -- Code offset multiplicator
327 , pprByte (128-fromIntegral wordSize)
328 -- Data offset multiplicator
329 -- (stacks grow down => "-w" in signed LEB128)
330 , pprByte retReg -- virtual register holding return address
331 ] $$
332 -- Initial unwind table
333 vcat (map pprInit $ Map.toList cieInit) $$
334 vcat [ -- RET = *CFA
335 pprByte (dW_CFA_offset+retReg)
336 , pprByte 0
337
338 -- Preserve C stack pointer
339 , preserveSp
340
341 -- Sp' = CFA
342 -- (we need to set this manually as our (STG) Sp register is
343 -- often not the architecture's default stack register)
344 , pprByte dW_CFA_val_offset
345 , pprLEBWord (fromIntegral spReg)
346 , pprLEBWord 0
347 ] $$
348 wordAlign platform $$
349 pdoc platform cieEndLabel <> colon $$
350 -- Procedure unwind tables
351 vcat (map (pprFrameProc platform cieLabel cieInit) procs)
352
353 -- | Writes a "Frame Description Entry" for a procedure. This consists
354 -- mainly of referencing the CIE and writing state machine
355 -- instructions to describe how the frame base (CFA) changes.
356 pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
357 pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
358 = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
359 fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
360 procEnd = mkAsmTempProcEndLabel procLbl
361 ifInfo str = if hasInfo then text str else empty
362 -- see Note [Info Offset]
363 in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon
364 , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel)
365 , pdoc platform fdeLabel <> colon
366 , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE
367 , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer
368 , pprWord platform (pdoc platform procEnd <> char '-' <>
369 pdoc platform procLbl <> ifInfo "+1") -- Block byte length
370 ] $$
371 vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$
372 wordAlign platform $$
373 pdoc platform fdeEndLabel <> colon
374
375 -- | Generates unwind information for a block. We only generate
376 -- instructions where unwind information actually changes. This small
377 -- optimisations saves a lot of space, as subsequent blocks often have
378 -- the same unwind information.
379 pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc
380 pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) =
381 vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
382 where
383 pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
384 pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
385 let -- Did a register's unwind expression change?
386 isChanged :: GlobalReg -> Maybe UnwindExpr
387 -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
388 isChanged g new
389 -- the value didn't change
390 | Just new == old = Nothing
391 -- the value was and still is undefined
392 | Nothing <- old
393 , Nothing <- new = Nothing
394 -- the value changed
395 | otherwise = Just (join old, new)
396 where
397 old = Map.lookup g oldUws
398
399 changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
400
401 in if oldUws == uws
402 then (empty, oldUws)
403 else let -- see Note [Info Offset]
404 needsOffset = firstDecl && hasInfo
405 lblDoc = pdoc platform lbl <>
406 if needsOffset then text "-1" else empty
407 doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$
408 vcat (map (uncurry $ pprSetUnwind platform) changed)
409 in (doc, uws)
410
411 -- Note [Info Offset]
412 -- ~~~~~~~~~~~~~~~~~~
413 --
414 -- GDB was pretty much written with C-like programs in mind, and as a
415 -- result they assume that once you have a return address, it is a
416 -- good idea to look at (PC-1) to unwind further - as that's where the
417 -- "call" instruction is supposed to be.
418 --
419 -- Now on one hand, code generated by GHC looks nothing like what GDB
420 -- expects, and in fact going up from a return pointer is guaranteed
421 -- to land us inside an info table! On the other hand, that actually
422 -- gives us some wiggle room, as we expect IP to never *actually* end
423 -- up inside the info table, so we can "cheat" by putting whatever GDB
424 -- expects to see there. This is probably pretty safe, as GDB cannot
425 -- assume (PC-1) to be a valid code pointer in the first place - and I
426 -- have seen no code trying to correct this.
427 --
428 -- Note that this will not prevent GDB from failing to look-up the
429 -- correct function name for the frame, as that uses the symbol table,
430 -- which we can not manipulate as easily.
431 --
432 -- We apply this offset in several places:
433 --
434 -- * unwind information in .debug_frames
435 -- * the subprogram and lexical_block DIEs in .debug_info
436 -- * the ranges in .debug_aranges
437 --
438 -- In the latter two cases we apply the offset unconditionally.
439 --
440 -- There's a GDB patch to address this at [1]. At the moment of writing
441 -- it's not merged, so I recommend building GDB with the patch if you
442 -- care about unwinding. The hack above doesn't cover every case.
443 --
444 -- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html
445
446 -- | Get DWARF register ID for a given GlobalReg
447 dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
448 dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
449 dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
450
451 -- | Generate code for setting the unwind information for a register,
452 -- optimized using its known old value in the table. Note that "Sp" is
453 -- special: We see it as synonym for the CFA.
454 pprSetUnwind :: Platform
455 -> GlobalReg
456 -- ^ the register to produce an unwinding table entry for
457 -> (Maybe UnwindExpr, Maybe UnwindExpr)
458 -- ^ the old and new values of the register
459 -> SDoc
460 pprSetUnwind plat g (_, Nothing)
461 = pprUndefUnwind plat g
462 pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
463 = if o' >= 0
464 then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
465 else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
466 pprSetUnwind plat Sp (_, Just (UwReg s' o'))
467 = if o' >= 0
468 then pprByte dW_CFA_def_cfa $$
469 pprLEBRegNo plat s' $$
470 pprLEBWord (fromIntegral o')
471 else pprByte dW_CFA_def_cfa_sf $$
472 pprLEBRegNo plat s' $$
473 pprLEBInt o'
474 pprSetUnwind plat Sp (_, Just uw)
475 = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw
476 pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o)))
477 | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case
478 = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
479 pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat))
480 | otherwise
481 = pprByte dW_CFA_offset_extended_sf $$
482 pprLEBRegNo plat g $$
483 pprLEBInt o
484 pprSetUnwind plat g (_, Just (UwDeref uw))
485 = pprByte dW_CFA_expression $$
486 pprLEBRegNo plat g $$
487 pprUnwindExpr plat True uw
488 pprSetUnwind plat g (_, Just (UwReg g' 0))
489 | g == g'
490 = pprByte dW_CFA_same_value $$
491 pprLEBRegNo plat g
492 pprSetUnwind plat g (_, Just uw)
493 = pprByte dW_CFA_val_expression $$
494 pprLEBRegNo plat g $$
495 pprUnwindExpr plat True uw
496
497 -- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
498 -- encoded number.
499 pprLEBRegNo :: Platform -> GlobalReg -> SDoc
500 pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
501
502 -- | Generates a DWARF expression for the given unwind expression. If
503 -- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
504 -- mentioned.
505 pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc
506 pprUnwindExpr platform spIsCFA expr
507 = let pprE (UwConst i)
508 | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
509 | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
510 pprE (UwReg Sp i) | spIsCFA
511 = if i == 0
512 then pprByte dW_OP_call_frame_cfa
513 else pprE (UwPlus (UwReg Sp 0) (UwConst i))
514 pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$
515 pprLEBInt i
516 pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref
517 pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pdoc platform l)
518 pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
519 pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
520 pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
521 in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length
522 -- computed as the difference of the following local labels 2: and 1:
523 text "1:" $$
524 pprE expr $$
525 text "2:"
526
527 -- | Generate code for re-setting the unwind information for a
528 -- register to @undefined@
529 pprUndefUnwind :: Platform -> GlobalReg -> SDoc
530 pprUndefUnwind plat g = pprByte dW_CFA_undefined $$
531 pprLEBRegNo plat g
532
533
534 -- | Align assembly at (machine) word boundary
535 wordAlign :: Platform -> SDoc
536 wordAlign plat =
537 text "\t.align " <> case platformOS plat of
538 OSDarwin -> case platformWordSize plat of
539 PW8 -> char '3'
540 PW4 -> char '2'
541 _other -> ppr (platformWordSizeInBytes plat)
542
543 -- | Assembly for a single byte of constant DWARF data
544 pprByte :: Word8 -> SDoc
545 pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)
546
547 -- | Assembly for a two-byte constant integer
548 pprHalf :: Word16 -> SDoc
549 pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)
550
551 -- | Assembly for a constant DWARF flag
552 pprFlag :: Bool -> SDoc
553 pprFlag f = pprByte (if f then 0xff else 0x00)
554
555 -- | Assembly for 4 bytes of dynamic DWARF data
556 pprData4' :: SDoc -> SDoc
557 pprData4' x = text "\t.long " <> x
558
559 -- | Assembly for 4 bytes of constant DWARF data
560 pprData4 :: Word -> SDoc
561 pprData4 = pprData4' . ppr
562
563 -- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
564 -- we are generating 32 bit DWARF.
565 pprDwWord :: SDoc -> SDoc
566 pprDwWord = pprData4'
567
568 -- | Assembly for a machine word of dynamic data. Depends on the
569 -- architecture we are currently generating code for.
570 pprWord :: Platform -> SDoc -> SDoc
571 pprWord plat s =
572 case platformWordSize plat of
573 PW4 -> text "\t.long " <> s
574 PW8 -> text "\t.quad " <> s
575
576 -- | Prints a number in "little endian base 128" format. The idea is
577 -- to optimize for small numbers by stopping once all further bytes
578 -- would be 0. The highest bit in every byte signals whether there
579 -- are further bytes to read.
580 pprLEBWord :: Word -> SDoc
581 pprLEBWord x | x < 128 = pprByte (fromIntegral x)
582 | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
583 pprLEBWord (x `shiftR` 7)
584
585 -- | Same as @pprLEBWord@, but for a signed number
586 pprLEBInt :: Int -> SDoc
587 pprLEBInt x | x >= -64 && x < 64
588 = pprByte (fromIntegral (x .&. 127))
589 | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
590 pprLEBInt (x `shiftR` 7)
591
592 -- | Generates a dynamic null-terminated string. If required the
593 -- caller needs to make sure that the string is escaped properly.
594 pprString' :: SDoc -> SDoc
595 pprString' str = text "\t.asciz \"" <> str <> char '"'
596
597 -- | Generate a string constant. We take care to escape the string.
598 pprString :: String -> SDoc
599 pprString str
600 = pprString' $ hcat $ map escapeChar $
601 if str `lengthIs` utf8EncodedLength str
602 then str
603 else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeString str
604
605 -- | Escape a single non-unicode character
606 escapeChar :: Char -> SDoc
607 escapeChar '\\' = text "\\\\"
608 escapeChar '\"' = text "\\\""
609 escapeChar '\n' = text "\\n"
610 escapeChar c
611 | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
612 = char c
613 | otherwise
614 = char '\\' <> char (intToDigit (ch `div` 64)) <>
615 char (intToDigit ((ch `div` 8) `mod` 8)) <>
616 char (intToDigit (ch `mod` 8))
617 where ch = ord c
618
619 -- | Generate an offset into another section. This is tricky because
620 -- this is handled differently depending on platform: Mac Os expects
621 -- us to calculate the offset using assembler arithmetic. Linux expects
622 -- us to just reference the target directly, and will figure out on
623 -- their own that we actually need an offset. Finally, Windows has
624 -- a special directive to refer to relative offsets. Fun.
625 sectionOffset :: Platform -> SDoc -> SDoc -> SDoc
626 sectionOffset plat target section =
627 case platformOS plat of
628 OSDarwin -> pprDwWord (target <> char '-' <> section)
629 OSMinGW32 -> text "\t.secrel32 " <> target
630 _other -> pprDwWord target