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