module Dwarf.Types
(
DwarfInfo(..)
, pprDwarfInfo
, pprAbbrevDecls
, DwarfARange(..)
, pprDwarfARanges
, DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
, pprDwarfFrame
, pprByte
, pprHalf
, pprData4'
, pprDwWord
, pprWord
, pprLEBWord
, pprLEBInt
, wordAlign
, sectionOffset
)
where
import GhcPrelude
import Debug
import CLabel
import CmmExpr ( GlobalReg(..) )
import Encoding
import FastString
import Outputable
import Platform
import Unique
import Reg
import SrcLoc
import Util
import Dwarf.Constants
import qualified Control.Monad.Trans.State.Strict as S
import Control.Monad (zipWithM, join)
import Data.Bits
import qualified Data.Map as Map
import Data.Word
import Data.Char
import CodeGen.Platform
data DwarfInfo
= DwarfCompileUnit { dwChildren :: [DwarfInfo]
, dwName :: String
, dwProducer :: String
, dwCompDir :: String
, dwLowLabel :: CLabel
, dwHighLabel :: CLabel
, dwLineLabel :: LitString }
| DwarfSubprogram { dwChildren :: [DwarfInfo]
, dwName :: String
, dwLabel :: CLabel
, dwParent :: Maybe CLabel
}
| DwarfBlock { dwChildren :: [DwarfInfo]
, dwLabel :: CLabel
, dwMarker :: Maybe CLabel
}
| DwarfSrcNote { dwSrcSpan :: RealSrcSpan
}
data DwarfAbbrev
= DwAbbrNull
| DwAbbrCompileUnit
| DwAbbrSubprogram
| DwAbbrSubprogramWithParent
| DwAbbrBlockWithoutCode
| DwAbbrBlock
| DwAbbrGhcSrcNote
deriving (Eq, Enum)
pprAbbrev :: DwarfAbbrev -> SDoc
pprAbbrev = pprLEBWord . fromIntegral . fromEnum
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
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)
]
in dwarfAbbrevSection $$
ptext dwarfAbbrevLabel <> colon $$
mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
([(dW_AT_name, dW_FORM_string)
, (dW_AT_producer, dW_FORM_string)
, (dW_AT_language, dW_FORM_data4)
, (dW_AT_comp_dir, dW_FORM_string)
, (dW_AT_use_UTF8, dW_FORM_flag_present)
, (dW_AT_low_pc, dW_FORM_addr)
, (dW_AT_high_pc, dW_FORM_addr)
] ++
(if haveDebugLine
then [ (dW_AT_stmt_list, dW_FORM_data4) ]
else [])) $$
mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
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
[ (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)
] $$
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)
] $$
pprByte 0
pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
pprDwarfInfo haveSrc d
= 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
pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
highLabel lineLbl) =
pprAbbrev DwAbbrCompileUnit
$$ pprString name
$$ pprString producer
$$ pprData4 dW_LANG_Haskell
$$ pprString compDir
$$ pprWord (ppr lowLabel)
$$ pprWord (ppr highLabel)
$$ if haveSrc
then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
else empty
pprDwarfInfoOpen _ (DwarfSubprogram _ name label
parent) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
$$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
$$ pprFlag (externallyVisibleCLabel label)
$$ pprWord (ppr label)
$$ pprWord (ppr $ mkAsmTempEndLabel label)
$$ pprByte 1
$$ pprByte dW_OP_call_frame_cfa
$$ 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
$$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
$$ pprWord (ppr marker)
$$ pprWord (ppr $ mkAsmTempEndLabel marker)
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)
pprDwarfInfoClose :: SDoc
pprDwarfInfoClose = pprAbbrev DwAbbrNull
data DwarfARange
= DwarfARange
{ dwArngStartLabel :: CLabel
, dwArngEndLabel :: CLabel
}
pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
let wordSize = platformWordSize plat
paddingSize = 4 :: Int
pad n = vcat $ replicate n $ pprByte 0
initialLength = 8 + paddingSize + 2*2*wordSize
in pprDwWord (ppr initialLength)
$$ pprHalf 2
$$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
(ptext dwarfInfoLabel)
$$ pprByte (fromIntegral wordSize)
$$ pprByte 0
$$ pad paddingSize
$$ vcat (map pprDwarfARange arngs)
$$ pprWord (char '0')
$$ pprWord (char '0')
pprDwarfARange :: DwarfARange -> SDoc
pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
where
length = ppr (dwArngEndLabel arng)
<> char '-' <> ppr (dwArngStartLabel arng)
data DwarfFrame
= DwarfFrame
{ dwCieLabel :: CLabel
, dwCieInit :: UnwindTable
, dwCieProcs :: [DwarfFrameProc]
}
data DwarfFrameProc
= DwarfFrameProc
{ dwFdeProc :: CLabel
, dwFdeHasInfo :: Bool
, dwFdeBlocks :: [DwarfFrameBlock]
}
data DwarfFrameBlock
= DwarfFrameBlock
{ dwFdeBlkHasInfo :: Bool
, dwFdeUnwind :: [UnwindPoint]
}
instance Outputable DwarfFrameBlock where
ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds
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
pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
preserveSp = case platformArch plat of
ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4
ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
_ -> empty
in vcat [ ppr cieLabel <> colon
, pprData4' length
, ppr cieStartLabel <> colon
, pprData4' (text "-1")
, pprByte 3
, pprByte 0
, pprByte 1
, pprByte (128fromIntegral wordSize)
, pprByte retReg
] $$
vcat (map pprInit $ Map.toList cieInit) $$
vcat [
pprByte (dW_CFA_offset+retReg)
, pprByte 0
, preserveSp
, pprByte dW_CFA_val_offset
, pprLEBWord (fromIntegral spReg)
, pprLEBWord 0
] $$
wordAlign $$
ppr cieEndLabel <> colon $$
vcat (map (pprFrameProc cieLabel cieInit) procs)
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
in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
, pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
, ppr fdeLabel <> colon
, pprData4' (ppr frameLbl <> char '-' <>
ptext dwarfFrameLabel)
, pprWord (ppr procLbl <> ifInfo "-1")
, pprWord (ppr procEnd <> char '-' <>
ppr procLbl <> ifInfo "+1")
] $$
vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
wordAlign $$
ppr fdeEndLabel <> colon
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 ->
let
isChanged :: GlobalReg -> Maybe UnwindExpr
-> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
isChanged g new
| Just new == old = Nothing
| Nothing <- old
, Nothing <- new = Nothing
| otherwise = Just (join old, new)
where
old = Map.lookup g oldUws
changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
in if oldUws == uws
then (empty, oldUws)
else let
needsOffset = firstDecl && hasInfo
lblDoc = ppr lbl <>
if needsOffset then text "-1" else empty
doc = sdocWithPlatform $ \plat ->
pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
vcat (map (uncurry $ pprSetUnwind plat) changed)
in (doc, uws)
dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
pprSetUnwind :: Platform
-> GlobalReg
-> (Maybe UnwindExpr, Maybe UnwindExpr)
-> SDoc
pprSetUnwind plat g (_, Nothing)
= pprUndefUnwind plat g
pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
= if o' >= 0
then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
pprSetUnwind plat Sp (_, Just (UwReg s' o'))
= if o' >= 0
then pprByte dW_CFA_def_cfa $$
pprLEBRegNo plat s' $$
pprLEBWord (fromIntegral o')
else pprByte dW_CFA_def_cfa_sf $$
pprLEBRegNo plat s' $$
pprLEBInt o'
pprSetUnwind _ Sp (_, Just uw)
= pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o)))
| o < 0 && ((o) `mod` platformWordSize plat) == 0
= pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
pprLEBWord (fromIntegral ((o) `div` platformWordSize plat))
| otherwise
= pprByte dW_CFA_offset_extended_sf $$
pprLEBRegNo plat g $$
pprLEBInt o
pprSetUnwind plat g (_, Just (UwDeref uw))
= pprByte dW_CFA_expression $$
pprLEBRegNo plat g $$
pprUnwindExpr True uw
pprSetUnwind plat g (_, Just (UwReg g' 0))
| g == g'
= pprByte dW_CFA_same_value $$
pprLEBRegNo plat g
pprSetUnwind plat g (_, Just uw)
= pprByte dW_CFA_val_expression $$
pprLEBRegNo plat g $$
pprUnwindExpr True uw
pprLEBRegNo :: Platform -> GlobalReg -> SDoc
pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
pprUnwindExpr spIsCFA expr
= sdocWithPlatform $ \plat ->
let pprE (UwConst i)
| i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
| otherwise = pprByte dW_OP_consts $$ pprLEBInt i
pprE (UwReg Sp i) | spIsCFA
= if i == 0
then pprByte dW_OP_call_frame_cfa
else pprE (UwPlus (UwReg Sp 0) (UwConst i))
pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
pprLEBInt i
pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref
pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord (ppr l)
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
in text "\t.uleb128 2f-1f" $$
text "1:" $$
pprE expr $$
text "2:"
pprUndefUnwind :: Platform -> GlobalReg -> SDoc
pprUndefUnwind plat g = pprByte dW_CFA_undefined $$
pprLEBRegNo plat g
wordAlign :: SDoc
wordAlign = sdocWithPlatform $ \plat ->
text "\t.align " <> case platformOS plat of
OSDarwin -> case platformWordSize plat of
8 -> text "3"
4 -> text "2"
_other -> error "wordAlign: Unsupported word size!"
_other -> ppr (platformWordSize plat)
pprByte :: Word8 -> SDoc
pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)
pprHalf :: Word16 -> SDoc
pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)
pprFlag :: Bool -> SDoc
pprFlag f = pprByte (if f then 0xff else 0x00)
pprData4' :: SDoc -> SDoc
pprData4' x = text "\t.long " <> x
pprData4 :: Word -> SDoc
pprData4 = pprData4' . ppr
pprDwWord :: SDoc -> SDoc
pprDwWord = pprData4'
pprWord :: SDoc -> SDoc
pprWord s = (<> s) . sdocWithPlatform $ \plat ->
case platformWordSize plat of
4 -> text "\t.long "
8 -> text "\t.quad "
n -> panic $ "pprWord: Unsupported target platform word length " ++
show n ++ "!"
pprLEBWord :: Word -> SDoc
pprLEBWord x | x < 128 = pprByte (fromIntegral x)
| otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
pprLEBWord (x `shiftR` 7)
pprLEBInt :: Int -> SDoc
pprLEBInt x | x >= 64 && x < 64
= pprByte (fromIntegral (x .&. 127))
| otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
pprLEBInt (x `shiftR` 7)
pprString' :: SDoc -> SDoc
pprString' str = text "\t.asciz \"" <> str <> char '"'
pprString :: String -> SDoc
pprString str
= pprString' $ hcat $ map escapeChar $
if str `lengthIs` utf8EncodedLength str
then str
else map (chr . fromIntegral) $ bytesFS $ mkFastString str
escapeChar :: Char -> SDoc
escapeChar '\\' = text "\\\\"
escapeChar '\"' = text "\\\""
escapeChar '\n' = text "\\n"
escapeChar c
| isAscii c && isPrint c && c /= '?'
= 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
sectionOffset :: SDoc -> SDoc -> SDoc
sectionOffset target section = sdocWithPlatform $ \plat ->
case platformOS plat of
OSDarwin -> pprDwWord (target <> char '-' <> section)
OSMinGW32 -> text "\t.secrel32 " <> target
_other -> pprDwWord target