Types.hs 23.5 KB
Newer Older
Peter Wortmann's avatar
Peter Wortmann committed
1
module Dwarf.Types
2 3
  ( -- * Dwarf information
    DwarfInfo(..)
Peter Wortmann's avatar
Peter Wortmann committed
4 5
  , pprDwarfInfo
  , pprAbbrevDecls
6 7
    -- * Dwarf address range table
  , DwarfARange(..)
8
  , pprDwarfARanges
9 10 11 12
    -- * Dwarf frame
  , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
  , pprDwarfFrame
    -- * Utilities
Peter Wortmann's avatar
Peter Wortmann committed
13
  , pprByte
14
  , pprHalf
15
  , pprData4'
Peter Wortmann's avatar
Peter Wortmann committed
16
  , pprDwWord
17
  , pprWord
Peter Wortmann's avatar
Peter Wortmann committed
18 19
  , pprLEBWord
  , pprLEBInt
20
  , wordAlign
Peter Wortmann's avatar
Peter Wortmann committed
21
  , sectionOffset
Peter Wortmann's avatar
Peter Wortmann committed
22 23 24
  )
  where

25 26
import GhcPrelude

27
import Debug
Peter Wortmann's avatar
Peter Wortmann committed
28
import CLabel
29
import CmmExpr         ( GlobalReg(..) )
Peter Wortmann's avatar
Peter Wortmann committed
30
import Encoding
Peter Wortmann's avatar
Peter Wortmann committed
31 32
import FastString
import Outputable
John Ericson's avatar
John Ericson committed
33
import GHC.Platform
34
import Unique
35
import Reg
36
import SrcLoc
37
import Util
Peter Wortmann's avatar
Peter Wortmann committed
38 39 40

import Dwarf.Constants

41
import qualified Data.ByteString as BS
42
import qualified Control.Monad.Trans.State.Strict as S
43
import Control.Monad (zipWithM, join)
Peter Wortmann's avatar
Peter Wortmann committed
44
import Data.Bits
45
import qualified Data.Map as Map
Peter Wortmann's avatar
Peter Wortmann committed
46 47 48
import Data.Word
import Data.Char

49 50
import CodeGen.Platform

Peter Wortmann's avatar
Peter Wortmann committed
51
-- | Individual dwarf records. Each one will be encoded as an entry in
Ben Gamari's avatar
Ben Gamari committed
52
-- the @.debug_info@ section.
Peter Wortmann's avatar
Peter Wortmann committed
53 54 55 56 57
data DwarfInfo
  = DwarfCompileUnit { dwChildren :: [DwarfInfo]
                     , dwName :: String
                     , dwProducer :: String
                     , dwCompDir :: String
58 59
                     , dwLowLabel :: CLabel
                     , dwHighLabel :: CLabel
Sylvain Henry's avatar
Sylvain Henry committed
60
                     , dwLineLabel :: PtrString }
Peter Wortmann's avatar
Peter Wortmann committed
61 62
  | DwarfSubprogram { dwChildren :: [DwarfInfo]
                    , dwName :: String
63 64 65 66
                    , dwLabel :: CLabel
                    , dwParent :: Maybe CLabel
                      -- ^ label of DIE belonging to the parent tick
                    }
Peter Wortmann's avatar
Peter Wortmann committed
67 68
  | DwarfBlock { dwChildren :: [DwarfInfo]
               , dwLabel :: CLabel
69 70 71 72
               , dwMarker :: Maybe CLabel
               }
  | DwarfSrcNote { dwSrcSpan :: RealSrcSpan
                 }
Peter Wortmann's avatar
Peter Wortmann committed
73 74

-- | Abbreviation codes used for encoding above records in the
Ben Gamari's avatar
Ben Gamari committed
75
-- @.debug_info@ section.
Peter Wortmann's avatar
Peter Wortmann committed
76 77 78 79
data DwarfAbbrev
  = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists
  | DwAbbrCompileUnit
  | DwAbbrSubprogram
80 81
  | DwAbbrSubprogramWithParent
  | DwAbbrBlockWithoutCode
Peter Wortmann's avatar
Peter Wortmann committed
82
  | DwAbbrBlock
83
  | DwAbbrGhcSrcNote
Peter Wortmann's avatar
Peter Wortmann committed
84 85 86 87 88 89 90
  deriving (Eq, Enum)

-- | Generate assembly for the given abbreviation code
pprAbbrev :: DwarfAbbrev -> SDoc
pprAbbrev = pprLEBWord . fromIntegral . fromEnum

-- | Abbreviation declaration. This explains the binary encoding we
91 92
-- use for representing 'DwarfInfo'. Be aware that this must be updated
-- along with 'pprDwarfInfo'.
Peter Wortmann's avatar
Peter Wortmann committed
93 94 95 96 97 98
pprAbbrevDecls :: Bool -> SDoc
pprAbbrevDecls haveDebugLine =
  let mkAbbrev abbr tag chld flds =
        let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
        in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
           vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
99 100 101 102 103 104 105 106 107 108
      -- These are shared between DwAbbrSubprogram and
      -- DwAbbrSubprogramWithParent
      subprogramAttrs =
           [ (dW_AT_name, dW_FORM_string)
           , (dW_AT_MIPS_linkage_name, dW_FORM_string)
           , (dW_AT_external, dW_FORM_flag)
           , (dW_AT_low_pc, dW_FORM_addr)
           , (dW_AT_high_pc, dW_FORM_addr)
           , (dW_AT_frame_base, dW_FORM_block1)
           ]
Peter Wortmann's avatar
Peter Wortmann committed
109 110 111
  in dwarfAbbrevSection $$
     ptext dwarfAbbrevLabel <> colon $$
     mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
112
       ([(dW_AT_name,     dW_FORM_string)
Peter Wortmann's avatar
Peter Wortmann committed
113 114 115
       , (dW_AT_producer, dW_FORM_string)
       , (dW_AT_language, dW_FORM_data4)
       , (dW_AT_comp_dir, dW_FORM_string)
116
       , (dW_AT_use_UTF8, dW_FORM_flag_present)  -- not represented in body
117 118
       , (dW_AT_low_pc,   dW_FORM_addr)
       , (dW_AT_high_pc,  dW_FORM_addr)
Peter Wortmann's avatar
Peter Wortmann committed
119 120 121 122 123
       ] ++
       (if haveDebugLine
        then [ (dW_AT_stmt_list, dW_FORM_data4) ]
        else [])) $$
     mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
124 125 126 127
       subprogramAttrs $$
     mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes
       (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$
     mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes
Peter Wortmann's avatar
Peter Wortmann committed
128 129 130 131 132 133
       [ (dW_AT_name, dW_FORM_string)
       ] $$
     mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes
       [ (dW_AT_name, dW_FORM_string)
       , (dW_AT_low_pc, dW_FORM_addr)
       , (dW_AT_high_pc, dW_FORM_addr)
Peter Wortmann's avatar
Peter Wortmann committed
134
       ] $$
135 136 137 138 139 140 141
     mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no
       [ (dW_AT_ghc_span_file, dW_FORM_string)
       , (dW_AT_ghc_span_start_line, dW_FORM_data4)
       , (dW_AT_ghc_span_start_col, dW_FORM_data2)
       , (dW_AT_ghc_span_end_line, dW_FORM_data4)
       , (dW_AT_ghc_span_end_col, dW_FORM_data2)
       ] $$
Peter Wortmann's avatar
Peter Wortmann committed
142 143
     pprByte 0

Peter Wortmann's avatar
Peter Wortmann committed
144 145 146
-- | Generate assembly for DWARF data
pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
pprDwarfInfo haveSrc d
147 148 149 150 151 152 153 154 155 156 157
  = case d of
      DwarfCompileUnit {}  -> hasChildren
      DwarfSubprogram {}   -> hasChildren
      DwarfBlock {}        -> hasChildren
      DwarfSrcNote {}      -> noChildren
  where
    hasChildren =
        pprDwarfInfoOpen haveSrc d $$
        vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
        pprDwarfInfoClose
    noChildren = pprDwarfInfoOpen haveSrc d
Peter Wortmann's avatar
Peter Wortmann committed
158 159

-- | Prints assembler data corresponding to DWARF info records. Note
160
-- that the binary format of this is parameterized in @abbrevDecls@ and
Peter Wortmann's avatar
Peter Wortmann committed
161 162
-- has to be kept in synch.
pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
163 164
pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
                                           highLabel lineLbl) =
Peter Wortmann's avatar
Peter Wortmann committed
165 166 167 168 169
  pprAbbrev DwAbbrCompileUnit
  $$ pprString name
  $$ pprString producer
  $$ pprData4 dW_LANG_Haskell
  $$ pprString compDir
170 171
  $$ pprWord (ppr lowLabel)
  $$ pprWord (ppr highLabel)
Peter Wortmann's avatar
Peter Wortmann committed
172
  $$ if haveSrc
173
     then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
Peter Wortmann's avatar
Peter Wortmann committed
174
     else empty
175 176 177 178
pprDwarfInfoOpen _ (DwarfSubprogram _ name label
                                    parent) = sdocWithDynFlags $ \df ->
  ppr (mkAsmTempDieLabel label) <> colon
  $$ pprAbbrev abbrev
Peter Wortmann's avatar
Peter Wortmann committed
179 180 181 182 183
  $$ pprString name
  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
  $$ pprFlag (externallyVisibleCLabel label)
  $$ pprWord (ppr label)
  $$ pprWord (ppr $ mkAsmTempEndLabel label)
184 185
  $$ pprByte 1
  $$ pprByte dW_OP_call_frame_cfa
186 187 188 189 190 191 192 193 194 195 196 197 198
  $$ parentValue
  where
    abbrev = case parent of Nothing -> DwAbbrSubprogram
                            Just _  -> DwAbbrSubprogramWithParent
    parentValue = maybe empty pprParentDie parent
    pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
  ppr (mkAsmTempDieLabel label) <> colon
  $$ pprAbbrev DwAbbrBlockWithoutCode
  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
  ppr (mkAsmTempDieLabel label) <> colon
  $$ pprAbbrev DwAbbrBlock
Peter Wortmann's avatar
Peter Wortmann committed
199 200 201
  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
  $$ pprWord (ppr marker)
  $$ pprWord (ppr $ mkAsmTempEndLabel marker)
202 203 204 205 206 207 208
pprDwarfInfoOpen _ (DwarfSrcNote ss) =
  pprAbbrev DwAbbrGhcSrcNote
  $$ pprString' (ftext $ srcSpanFile ss)
  $$ pprData4 (fromIntegral $ srcSpanStartLine ss)
  $$ pprHalf (fromIntegral $ srcSpanStartCol ss)
  $$ pprData4 (fromIntegral $ srcSpanEndLine ss)
  $$ pprHalf (fromIntegral $ srcSpanEndCol ss)
Peter Wortmann's avatar
Peter Wortmann committed
209 210 211 212 213

-- | Close a DWARF info record with children
pprDwarfInfoClose :: SDoc
pprDwarfInfoClose = pprAbbrev DwAbbrNull

214 215 216 217 218 219 220 221 222 223 224
-- | A DWARF address range. This is used by the debugger to quickly locate
-- which compilation unit a given address belongs to. This type assumes
-- a non-segmented address-space.
data DwarfARange
  = DwarfARange
    { dwArngStartLabel :: CLabel
    , dwArngEndLabel   :: CLabel
    }

-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
-- address table entry.
225 226
pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
227 228 229 230 231 232 233 234 235
  let wordSize = platformWordSize plat
      paddingSize = 4 :: Int
      -- header is 12 bytes long.
      -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
      -- pad such that first entry begins at multiple of entry size.
      pad n = vcat $ replicate n $ pprByte 0
      initialLength = 8 + paddingSize + 2*2*wordSize
  in pprDwWord (ppr initialLength)
     $$ pprHalf 2
236
     $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
237 238 239 240
                      (ptext dwarfInfoLabel)
     $$ pprByte (fromIntegral wordSize)
     $$ pprByte 0
     $$ pad paddingSize
241 242
     -- body
     $$ vcat (map pprDwarfARange arngs)
243 244 245 246
     -- terminus
     $$ pprWord (char '0')
     $$ pprWord (char '0')

247 248 249 250 251 252
pprDwarfARange :: DwarfARange -> SDoc
pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
  where
    length = ppr (dwArngEndLabel arng)
             <> char '-' <> ppr (dwArngStartLabel arng)

253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
-- | Information about unwind instructions for a procedure. This
-- corresponds to a "Common Information Entry" (CIE) in DWARF.
data DwarfFrame
  = DwarfFrame
    { dwCieLabel :: CLabel
    , dwCieInit  :: UnwindTable
    , dwCieProcs :: [DwarfFrameProc]
    }

-- | Unwind instructions for an individual procedure. Corresponds to a
-- "Frame Description Entry" (FDE) in DWARF.
data DwarfFrameProc
  = DwarfFrameProc
    { dwFdeProc    :: CLabel
    , dwFdeHasInfo :: Bool
    , dwFdeBlocks  :: [DwarfFrameBlock]
      -- ^ List of blocks. Order must match asm!
    }

-- | Unwind instructions for a block. Will become part of the
-- containing FDE.
data DwarfFrameBlock
  = DwarfFrameBlock
276 277 278 279
    { dwFdeBlkHasInfo :: Bool
    , dwFdeUnwind     :: [UnwindPoint]
      -- ^ these unwind points must occur in the same order as they occur
      -- in the block
280 281
    }

282 283 284
instance Outputable DwarfFrameBlock where
  ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds

Ben Gamari's avatar
Ben Gamari committed
285
-- | Header for the @.debug_frame@ section. Here we emit the "Common
286 287 288 289 290 291 292 293 294 295 296
-- Information Entry" record that etablishes general call frame
-- parameters and the default stack layout.
pprDwarfFrame :: DwarfFrame -> SDoc
pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
  = sdocWithPlatform $ \plat ->
    let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
        cieEndLabel = mkAsmTempEndLabel cieLabel
        length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
        spReg       = dwarfGlobalRegNo plat Sp
        retReg      = dwarfReturnRegNo plat
        wordSize    = platformWordSize plat
297
        pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
298
        pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
299 300 301 302 303 304 305

        -- Preserve C stack pointer: This necessary to override that default
        -- unwinding behavior of setting $sp = CFA.
        preserveSp = case platformArch plat of
          ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4
          ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
          _          -> empty
306 307 308
    in vcat [ ppr cieLabel <> colon
            , pprData4' length -- Length of CIE
            , ppr cieStartLabel <> colon
309
            , pprData4' (text "-1")
310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
                               -- Common Information Entry marker (-1 = 0xf..f)
            , pprByte 3        -- CIE version (we require DWARF 3)
            , pprByte 0        -- Augmentation (none)
            , pprByte 1        -- Code offset multiplicator
            , pprByte (128-fromIntegral wordSize)
                               -- Data offset multiplicator
                               -- (stacks grow down => "-w" in signed LEB128)
            , pprByte retReg   -- virtual register holding return address
            ] $$
       -- Initial unwind table
       vcat (map pprInit $ Map.toList cieInit) $$
       vcat [ -- RET = *CFA
              pprByte (dW_CFA_offset+retReg)
            , pprByte 0

325 326 327
              -- Preserve C stack pointer
            , preserveSp

328
              -- Sp' = CFA
329
              -- (we need to set this manually as our (STG) Sp register is
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
              -- often not the architecture's default stack register)
            , pprByte dW_CFA_val_offset
            , pprLEBWord (fromIntegral spReg)
            , pprLEBWord 0
            ] $$
       wordAlign $$
       ppr cieEndLabel <> colon $$
       -- Procedure unwind tables
       vcat (map (pprFrameProc cieLabel cieInit) procs)

-- | Writes a "Frame Description Entry" for a procedure. This consists
-- mainly of referencing the CIE and writing state machine
-- instructions to describe how the frame base (CFA) changes.
pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
  = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
        fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
        procEnd     = mkAsmTempEndLabel procLbl
        ifInfo str  = if hasInfo then text str else empty
                      -- see [Note: Info Offset]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
350
    in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
351
            , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
352 353 354 355 356 357 358
            , ppr fdeLabel <> colon
            , pprData4' (ppr frameLbl <> char '-' <>
                         ptext dwarfFrameLabel)    -- Reference to CIE
            , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer
            , pprWord (ppr procEnd <> char '-' <>
                       ppr procLbl <> ifInfo "+1") -- Block byte length
            ] $$
359
       vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
360 361 362 363 364 365 366
       wordAlign $$
       ppr fdeEndLabel <> colon

-- | Generates unwind information for a block. We only generate
-- instructions where unwind information actually changes. This small
-- optimisations saves a lot of space, as subsequent blocks often have
-- the same unwind information.
367 368 369 370 371 372
pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
  where
    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
    pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
373 374 375 376 377 378 379 380 381 382 383 384 385 386
        let -- Did a register's unwind expression change?
            isChanged :: GlobalReg -> Maybe UnwindExpr
                      -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
            isChanged g new
                -- the value didn't change
              | Just new == old = Nothing
                -- the value was and still is undefined
              | Nothing <- old
              , Nothing <- new  = Nothing
                -- the value changed
              | otherwise       = Just (join old, new)
              where
                old = Map.lookup g oldUws

387 388 389 390 391 392 393 394 395 396
            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws

        in if oldUws == uws
             then (empty, oldUws)
             else let -- see [Note: Info Offset]
                      needsOffset = firstDecl && hasInfo
                      lblDoc = ppr lbl <>
                               if needsOffset then text "-1" else empty
                      doc = sdocWithPlatform $ \plat ->
                           pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
397
                           vcat (map (uncurry $ pprSetUnwind plat) changed)
398
                  in (doc, uws)
399

Ben Gamari's avatar
Ben Gamari committed
400
-- Note [Info Offset]
401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
--
-- GDB was pretty much written with C-like programs in mind, and as a
-- result they assume that once you have a return address, it is a
-- good idea to look at (PC-1) to unwind further - as that's where the
-- "call" instruction is supposed to be.
--
-- Now on one hand, code generated by GHC looks nothing like what GDB
-- expects, and in fact going up from a return pointer is guaranteed
-- to land us inside an info table! On the other hand, that actually
-- gives us some wiggle room, as we expect IP to never *actually* end
-- up inside the info table, so we can "cheat" by putting whatever GDB
-- expects to see there. This is probably pretty safe, as GDB cannot
-- assume (PC-1) to be a valid code pointer in the first place - and I
-- have seen no code trying to correct this.
--
-- Note that this will not prevent GDB from failing to look-up the
-- correct function name for the frame, as that uses the symbol table,
-- which we can not manipulate as easily.
419 420 421 422 423 424
--
-- There's a GDB patch to address this at [1]. At the moment of writing
-- it's not merged, so I recommend building GDB with the patch if you
-- care about unwinding. The hack above doesn't cover every case.
--
-- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html
425 426 427

-- | Get DWARF register ID for a given GlobalReg
dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
428 429
dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
430 431 432 433

-- | Generate code for setting the unwind information for a register,
-- optimized using its known old value in the table. Note that "Sp" is
-- special: We see it as synonym for the CFA.
434 435 436 437 438 439 440 441 442
pprSetUnwind :: Platform
             -> GlobalReg
                -- ^ the register to produce an unwinding table entry for
             -> (Maybe UnwindExpr, Maybe UnwindExpr)
                -- ^ the old and new values of the register
             -> SDoc
pprSetUnwind plat g  (_, Nothing)
  = pprUndefUnwind plat g
pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
443 444 445
  = if o' >= 0
    then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
    else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
446
pprSetUnwind plat Sp (_, Just (UwReg s' o'))
447 448
  = if o' >= 0
    then pprByte dW_CFA_def_cfa $$
449
         pprLEBRegNo plat s' $$
450 451
         pprLEBWord (fromIntegral o')
    else pprByte dW_CFA_def_cfa_sf $$
452
         pprLEBRegNo plat s' $$
453
         pprLEBInt o'
454
pprSetUnwind _    Sp (_, Just uw)
455
  = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
456
pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))
457 458 459 460 461
  | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case
  = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
    pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))
  | otherwise
  = pprByte dW_CFA_offset_extended_sf $$
462
    pprLEBRegNo plat g $$
463
    pprLEBInt o
464
pprSetUnwind plat g  (_, Just (UwDeref uw))
465
  = pprByte dW_CFA_expression $$
466
    pprLEBRegNo plat g $$
467
    pprUnwindExpr True uw
468 469 470 471
pprSetUnwind plat g  (_, Just (UwReg g' 0))
  | g == g'
  = pprByte dW_CFA_same_value $$
    pprLEBRegNo plat g
472
pprSetUnwind plat g  (_, Just uw)
473
  = pprByte dW_CFA_val_expression $$
474
    pprLEBRegNo plat g $$
475 476
    pprUnwindExpr True uw

477 478 479 480 481
-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
-- encoded number.
pprLEBRegNo :: Platform -> GlobalReg -> SDoc
pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat

482 483 484 485 486 487
-- | Generates a DWARF expression for the given unwind expression. If
-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
-- mentioned.
pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
pprUnwindExpr spIsCFA expr
  = sdocWithPlatform $ \plat ->
488
    let pprE (UwConst i)
489 490
          | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
          | otherwise        = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
491
        pprE (UwReg Sp i) | spIsCFA
492 493
                             = if i == 0
                               then pprByte dW_OP_call_frame_cfa
494
                               else pprE (UwPlus (UwReg Sp 0) (UwConst i))
495
        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
496
                               pprLEBInt i
497
        pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref
498
        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord (ppr l)
499 500 501
        pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
        pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
        pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
502 503 504
    in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length
       -- computed as the difference of the following local labels 2: and 1:
       text "1:" $$
505
       pprE expr $$
506
       text "2:"
507 508

-- | Generate code for re-setting the unwind information for a
Ben Gamari's avatar
Ben Gamari committed
509
-- register to @undefined@
510 511
pprUndefUnwind :: Platform -> GlobalReg -> SDoc
pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$
512
                         pprLEBRegNo plat g
513 514 515 516 517


-- | Align assembly at (machine) word boundary
wordAlign :: SDoc
wordAlign = sdocWithPlatform $ \plat ->
518
  text "\t.align " <> case platformOS plat of
519 520 521 522 523 524
    OSDarwin -> case platformWordSize plat of
      8      -> text "3"
      4      -> text "2"
      _other -> error "wordAlign: Unsupported word size!"
    _other   -> ppr (platformWordSize plat)

Peter Wortmann's avatar
Peter Wortmann committed
525 526
-- | Assembly for a single byte of constant DWARF data
pprByte :: Word8 -> SDoc
527
pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)
Peter Wortmann's avatar
Peter Wortmann committed
528

529 530
-- | Assembly for a two-byte constant integer
pprHalf :: Word16 -> SDoc
531
pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)
532

Peter Wortmann's avatar
Peter Wortmann committed
533 534 535 536 537 538
-- | Assembly for a constant DWARF flag
pprFlag :: Bool -> SDoc
pprFlag f = pprByte (if f then 0xff else 0x00)

-- | Assembly for 4 bytes of dynamic DWARF data
pprData4' :: SDoc -> SDoc
539
pprData4' x = text "\t.long " <> x
Peter Wortmann's avatar
Peter Wortmann committed
540 541 542 543 544 545 546 547 548 549 550 551 552 553 554

-- | Assembly for 4 bytes of constant DWARF data
pprData4 :: Word -> SDoc
pprData4 = pprData4' . ppr

-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
-- we are generating 32 bit DWARF.
pprDwWord :: SDoc -> SDoc
pprDwWord = pprData4'

-- | Assembly for a machine word of dynamic data. Depends on the
-- architecture we are currently generating code for.
pprWord :: SDoc -> SDoc
pprWord s = (<> s) . sdocWithPlatform $ \plat ->
  case platformWordSize plat of
555 556
    4 -> text "\t.long "
    8 -> text "\t.quad "
Peter Wortmann's avatar
Peter Wortmann committed
557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578
    n -> panic $ "pprWord: Unsupported target platform word length " ++
                 show n ++ "!"

-- | Prints a number in "little endian base 128" format. The idea is
-- to optimize for small numbers by stopping once all further bytes
-- would be 0. The highest bit in every byte signals whether there
-- are further bytes to read.
pprLEBWord :: Word -> SDoc
pprLEBWord x | x < 128   = pprByte (fromIntegral x)
             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
                           pprLEBWord (x `shiftR` 7)

-- | Same as @pprLEBWord@, but for a signed number
pprLEBInt :: Int -> SDoc
pprLEBInt x | x >= -64 && x < 64
                        = pprByte (fromIntegral (x .&. 127))
            | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
                          pprLEBInt (x `shiftR` 7)

-- | Generates a dynamic null-terminated string. If required the
-- caller needs to make sure that the string is escaped properly.
pprString' :: SDoc -> SDoc
579
pprString' str = text "\t.asciz \"" <> str <> char '"'
Peter Wortmann's avatar
Peter Wortmann committed
580 581 582

-- | Generate a string constant. We take care to escape the string.
pprString :: String -> SDoc
Peter Wortmann's avatar
Peter Wortmann committed
583 584
pprString str
  = pprString' $ hcat $ map escapeChar $
585
    if str `lengthIs` utf8EncodedLength str
Peter Wortmann's avatar
Peter Wortmann committed
586
    then str
587
    else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str
Peter Wortmann's avatar
Peter Wortmann committed
588 589 590

-- | Escape a single non-unicode character
escapeChar :: Char -> SDoc
591 592 593
escapeChar '\\' = text "\\\\"
escapeChar '\"' = text "\\\""
escapeChar '\n' = text "\\n"
Peter Wortmann's avatar
Peter Wortmann committed
594 595 596 597 598 599 600 601
escapeChar c
  | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
  = char c
  | otherwise
  = char '\\' <> char (intToDigit (ch `div` 64)) <>
                 char (intToDigit ((ch `div` 8) `mod` 8)) <>
                 char (intToDigit (ch `mod` 8))
  where ch = ord c
Peter Wortmann's avatar
Peter Wortmann committed
602 603 604

-- | Generate an offset into another section. This is tricky because
-- this is handled differently depending on platform: Mac Os expects
605 606 607 608
-- us to calculate the offset using assembler arithmetic. Linux expects
-- us to just reference the target directly, and will figure out on
-- their own that we actually need an offset. Finally, Windows has
-- a special directive to refer to relative offsets. Fun.
609
sectionOffset :: SDoc -> SDoc -> SDoc
Peter Wortmann's avatar
Peter Wortmann committed
610 611
sectionOffset target section = sdocWithPlatform $ \plat ->
  case platformOS plat of
612 613 614
    OSDarwin  -> pprDwWord (target <> char '-' <> section)
    OSMinGW32 -> text "\t.secrel32 " <> target
    _other    -> pprDwWord target