module GHC.CmmToAsm.Dwarf.Types
(
DwarfInfo(..)
, pprDwarfInfo
, pprAbbrevDecls
, DwarfARange(..)
, pprDwarfARanges
, DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
, pprDwarfFrame
, pprByte
, pprHalf
, pprData4'
, pprDwWord
, pprWord
, pprLEBWord
, pprLEBInt
, wordAlign
, sectionOffset
)
where
import GHC.Prelude
import GHC.Cmm.DebugBlock
import GHC.Cmm.CLabel
import GHC.Cmm.Expr ( GlobalReg(..) )
import GHC.Utils.Encoding
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Platform
import GHC.Types.Unique
import GHC.Platform.Reg
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.CmmToAsm.Dwarf.Constants
import qualified Data.ByteString as BS
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 GHC.Platform.Regs
data DwarfInfo
= DwarfCompileUnit { dwChildren :: [DwarfInfo]
, dwName :: String
, dwProducer :: String
, dwCompDir :: String
, dwLowLabel :: CLabel
, dwHighLabel :: CLabel
, dwLineLabel :: PtrString }
| 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 :: Platform -> Bool -> SDoc
pprAbbrevDecls platform 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 platform $$
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 :: Platform -> Bool -> DwarfInfo -> SDoc
pprDwarfInfo platform haveSrc d
= case d of
DwarfCompileUnit {} -> hasChildren
DwarfSubprogram {} -> hasChildren
DwarfBlock {} -> hasChildren
DwarfSrcNote {} -> noChildren
where
hasChildren =
pprDwarfInfoOpen platform haveSrc d $$
vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
pprDwarfInfoClose
noChildren = pprDwarfInfoOpen platform haveSrc d
pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
highLabel lineLbl) =
pprAbbrev DwAbbrCompileUnit
$$ pprString name
$$ pprString producer
$$ pprData4 dW_LANG_Haskell
$$ pprString compDir
$$ pprWord platform (ppr lowLabel)
$$ pprWord platform (ppr highLabel)
$$ if haveSrc
then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)
else empty
pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label
parent) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprFlag (externallyVisibleCLabel label)
$$ pprWord platform (ppr label)
$$ pprWord platform (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 platform (ppr sym) (ptext dwarfInfoLabel)
pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlockWithoutCode
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlock
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprWord platform (ppr marker)
$$ pprWord platform (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 :: Platform -> [DwarfARange] -> Unique -> SDoc
pprDwarfARanges platform arngs unitU =
let wordSize = platformWordSizeInBytes platform
paddingSize = 4 :: Int
pad n = vcat $ replicate n $ pprByte 0
initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
in pprDwWord (ppr initialLength)
$$ pprHalf 2
$$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU)
(ptext dwarfInfoLabel)
$$ pprByte (fromIntegral wordSize)
$$ pprByte 0
$$ pad paddingSize
$$ vcat (map (pprDwarfARange platform) arngs)
$$ pprWord platform (char '0')
$$ pprWord platform (char '0')
pprDwarfARange :: Platform -> DwarfARange -> SDoc
pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform 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 :: Platform -> DwarfFrame -> SDoc
pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
= let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
cieEndLabel = mkAsmTempEndLabel cieLabel
length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
spReg = dwarfGlobalRegNo platform Sp
retReg = dwarfReturnRegNo platform
wordSize = platformWordSizeInBytes platform
pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)
preserveSp = case platformArch platform 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 platform $$
ppr cieEndLabel <> colon $$
vcat (map (pprFrameProc platform cieLabel cieInit) procs)
pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
pprFrameProc platform 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 platform (ppr procLbl <> ifInfo "-1")
, pprWord platform (ppr procEnd <> char '-' <>
ppr procLbl <> ifInfo "+1")
] $$
vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$
wordAlign platform $$
ppr fdeEndLabel <> colon
pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc
pprFrameBlock platform (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 = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$
vcat (map (uncurry $ pprSetUnwind platform) 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 plat Sp (_, Just uw)
= pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw
pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o)))
| o < 0 && ((o) `mod` platformWordSizeInBytes plat) == 0
= pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
pprLEBWord (fromIntegral ((o) `div` platformWordSizeInBytes 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 plat 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 plat True uw
pprLEBRegNo :: Platform -> GlobalReg -> SDoc
pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc
pprUnwindExpr platform spIsCFA expr
= 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 platform g) $$
pprLEBInt i
pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref
pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (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 :: Platform -> SDoc
wordAlign plat =
text "\t.align " <> case platformOS plat of
OSDarwin -> case platformWordSize plat of
PW8 -> char '3'
PW4 -> char '2'
_other -> ppr (platformWordSizeInBytes 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 :: Platform -> SDoc -> SDoc
pprWord plat s =
case platformWordSize plat of
PW4 -> text "\t.long " <> s
PW8 -> text "\t.quad " <> s
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) $ BS.unpack $ 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 :: Platform -> SDoc -> SDoc -> SDoc
sectionOffset plat target section =
case platformOS plat of
OSDarwin -> pprDwWord (target <> char '-' <> section)
OSMinGW32 -> text "\t.secrel32 " <> target
_other -> pprDwWord target