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