Generalize CmmUnwind and pass unwind information through NCG
[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)
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, 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 isChanged g v | old == Just v = Nothing
370 | otherwise = Just (old, v)
371 where old = Map.lookup g oldUws
372 changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
373 died = Map.toList $ Map.difference oldUws uws
374
375 in if oldUws == uws
376 then (empty, oldUws)
377 else let -- see [Note: Info Offset]
378 needsOffset = firstDecl && hasInfo
379 lblDoc = ppr lbl <>
380 if needsOffset then text "-1" else empty
381 doc = sdocWithPlatform $ \plat ->
382 pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
383 vcat (map (uncurry $ pprSetUnwind plat) changed) $$
384 vcat (map (pprUndefUnwind plat . fst) died)
385 in (doc, uws)
386
387 -- Note [Info Offset]
388 --
389 -- GDB was pretty much written with C-like programs in mind, and as a
390 -- result they assume that once you have a return address, it is a
391 -- good idea to look at (PC-1) to unwind further - as that's where the
392 -- "call" instruction is supposed to be.
393 --
394 -- Now on one hand, code generated by GHC looks nothing like what GDB
395 -- expects, and in fact going up from a return pointer is guaranteed
396 -- to land us inside an info table! On the other hand, that actually
397 -- gives us some wiggle room, as we expect IP to never *actually* end
398 -- up inside the info table, so we can "cheat" by putting whatever GDB
399 -- expects to see there. This is probably pretty safe, as GDB cannot
400 -- assume (PC-1) to be a valid code pointer in the first place - and I
401 -- have seen no code trying to correct this.
402 --
403 -- Note that this will not prevent GDB from failing to look-up the
404 -- correct function name for the frame, as that uses the symbol table,
405 -- which we can not manipulate as easily.
406
407 -- | Get DWARF register ID for a given GlobalReg
408 dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
409 dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
410 dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
411
412 -- | Generate code for setting the unwind information for a register,
413 -- optimized using its known old value in the table. Note that "Sp" is
414 -- special: We see it as synonym for the CFA.
415 pprSetUnwind :: Platform -> GlobalReg -> (Maybe UnwindExpr, UnwindExpr) -> SDoc
416 pprSetUnwind _ Sp (Just (UwReg s _), UwReg s' o') | s == s'
417 = if o' >= 0
418 then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
419 else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
420 pprSetUnwind plat Sp (_, UwReg s' o')
421 = if o' >= 0
422 then pprByte dW_CFA_def_cfa $$
423 pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$
424 pprLEBWord (fromIntegral o')
425 else pprByte dW_CFA_def_cfa_sf $$
426 pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$
427 pprLEBInt o'
428 pprSetUnwind _ Sp (_, uw)
429 = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
430 pprSetUnwind plat g (_, UwDeref (UwReg Sp o))
431 | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case
432 = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
433 pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))
434 | otherwise
435 = pprByte dW_CFA_offset_extended_sf $$
436 pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
437 pprLEBInt o
438 pprSetUnwind plat g (_, UwDeref uw)
439 = pprByte dW_CFA_expression $$
440 pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
441 pprUnwindExpr True uw
442 pprSetUnwind plat g (_, uw)
443 = pprByte dW_CFA_val_expression $$
444 pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
445 pprUnwindExpr True uw
446
447 -- | Generates a DWARF expression for the given unwind expression. If
448 -- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
449 -- mentioned.
450 pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
451 pprUnwindExpr spIsCFA expr
452 = sdocWithPlatform $ \plat ->
453 let pprE (UwConst i)
454 | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
455 | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
456 pprE (UwReg Sp i) | spIsCFA
457 = if i == 0
458 then pprByte dW_OP_call_frame_cfa
459 else pprE (UwPlus (UwReg Sp 0) (UwConst i))
460 pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
461 pprLEBInt i
462 pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref
463 pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord (ppr l)
464 pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
465 pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
466 pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
467 in text "\t.uleb128 1f-.-1" $$ -- DW_FORM_block length
468 pprE expr $$
469 text "1:"
470
471 -- | Generate code for re-setting the unwind information for a
472 -- register to @undefined@
473 pprUndefUnwind :: Platform -> GlobalReg -> SDoc
474 pprUndefUnwind _ Sp = panic "pprUndefUnwind Sp" -- should never happen
475 pprUndefUnwind plat g = pprByte dW_CFA_undefined $$
476 pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat g)
477
478
479 -- | Align assembly at (machine) word boundary
480 wordAlign :: SDoc
481 wordAlign = sdocWithPlatform $ \plat ->
482 text "\t.align " <> case platformOS plat of
483 OSDarwin -> case platformWordSize plat of
484 8 -> text "3"
485 4 -> text "2"
486 _other -> error "wordAlign: Unsupported word size!"
487 _other -> ppr (platformWordSize plat)
488
489 -- | Assembly for a single byte of constant DWARF data
490 pprByte :: Word8 -> SDoc
491 pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)
492
493 -- | Assembly for a two-byte constant integer
494 pprHalf :: Word16 -> SDoc
495 pprHalf x = sdocWithPlatform $ \plat ->
496 -- Naturally Darwin doesn't support `.hword` and binutils uses `.short`
497 -- as a synonym for `.word` (but only some of the time!). The madness
498 -- is nearly too much to bear.
499 let dir = case platformOS plat of
500 OSDarwin -> text ".short"
501 _ -> text ".hword"
502 in text "\t" <> dir <+> ppr (fromIntegral x :: Word)
503
504 -- | Assembly for a constant DWARF flag
505 pprFlag :: Bool -> SDoc
506 pprFlag f = pprByte (if f then 0xff else 0x00)
507
508 -- | Assembly for 4 bytes of dynamic DWARF data
509 pprData4' :: SDoc -> SDoc
510 pprData4' x = text "\t.long " <> x
511
512 -- | Assembly for 4 bytes of constant DWARF data
513 pprData4 :: Word -> SDoc
514 pprData4 = pprData4' . ppr
515
516 -- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
517 -- we are generating 32 bit DWARF.
518 pprDwWord :: SDoc -> SDoc
519 pprDwWord = pprData4'
520
521 -- | Assembly for a machine word of dynamic data. Depends on the
522 -- architecture we are currently generating code for.
523 pprWord :: SDoc -> SDoc
524 pprWord s = (<> s) . sdocWithPlatform $ \plat ->
525 case platformWordSize plat of
526 4 -> text "\t.long "
527 8 -> text "\t.quad "
528 n -> panic $ "pprWord: Unsupported target platform word length " ++
529 show n ++ "!"
530
531 -- | Prints a number in "little endian base 128" format. The idea is
532 -- to optimize for small numbers by stopping once all further bytes
533 -- would be 0. The highest bit in every byte signals whether there
534 -- are further bytes to read.
535 pprLEBWord :: Word -> SDoc
536 pprLEBWord x | x < 128 = pprByte (fromIntegral x)
537 | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
538 pprLEBWord (x `shiftR` 7)
539
540 -- | Same as @pprLEBWord@, but for a signed number
541 pprLEBInt :: Int -> SDoc
542 pprLEBInt x | x >= -64 && x < 64
543 = pprByte (fromIntegral (x .&. 127))
544 | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
545 pprLEBInt (x `shiftR` 7)
546
547 -- | Generates a dynamic null-terminated string. If required the
548 -- caller needs to make sure that the string is escaped properly.
549 pprString' :: SDoc -> SDoc
550 pprString' str = text "\t.asciz \"" <> str <> char '"'
551
552 -- | Generate a string constant. We take care to escape the string.
553 pprString :: String -> SDoc
554 pprString str
555 = pprString' $ hcat $ map escapeChar $
556 if utf8EncodedLength str == length str
557 then str
558 else map (chr . fromIntegral) $ bytesFS $ mkFastString str
559
560 -- | Escape a single non-unicode character
561 escapeChar :: Char -> SDoc
562 escapeChar '\\' = text "\\\\"
563 escapeChar '\"' = text "\\\""
564 escapeChar '\n' = text "\\n"
565 escapeChar c
566 | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
567 = char c
568 | otherwise
569 = char '\\' <> char (intToDigit (ch `div` 64)) <>
570 char (intToDigit ((ch `div` 8) `mod` 8)) <>
571 char (intToDigit (ch `mod` 8))
572 where ch = ord c
573
574 -- | Generate an offset into another section. This is tricky because
575 -- this is handled differently depending on platform: Mac Os expects
576 -- us to calculate the offset using assembler arithmetic. Linux expects
577 -- us to just reference the target directly, and will figure out on
578 -- their own that we actually need an offset. Finally, Windows has
579 -- a special directive to refer to relative offsets. Fun.
580 sectionOffset :: SDoc -> SDoc -> SDoc
581 sectionOffset target section = sdocWithPlatform $ \plat ->
582 case platformOS plat of
583 OSDarwin -> pprDwWord (target <> char '-' <> section)
584 OSMinGW32 -> text "\t.secrel32 " <> target
585 _other -> pprDwWord target