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