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