module Dwarf.Types
(
DwarfInfo(..)
, pprDwarfInfo
, pprAbbrevDecls
, DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
, pprDwarfFrame
, pprByte
, pprData4'
, pprDwWord
, pprWord
, pprLEBWord
, pprLEBInt
, wordAlign
, sectionOffset
)
where
import Debug
import CLabel
import CmmExpr ( GlobalReg(..) )
import Encoding
import FastString
import Outputable
import Platform
import Reg
import Dwarf.Constants
import Data.Bits
import Data.List ( mapAccumL )
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
, dwLineLabel :: LitString }
| DwarfSubprogram { dwChildren :: [DwarfInfo]
, dwName :: String
, dwLabel :: CLabel }
| DwarfBlock { dwChildren :: [DwarfInfo]
, dwLabel :: CLabel
, dwMarker :: CLabel }
data DwarfAbbrev
= DwAbbrNull
| DwAbbrCompileUnit
| DwAbbrSubprogram
| DwAbbrBlock
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
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)
] ++
(if haveDebugLine
then [ (dW_AT_stmt_list, dW_FORM_data4) ]
else [])) $$
mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
[ (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)
] $$
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)
] $$
pprByte 0
pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
pprDwarfInfo haveSrc d
= pprDwarfInfoOpen haveSrc d $$
vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
pprDwarfInfoClose
pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lineLbl) =
pprAbbrev DwAbbrCompileUnit
$$ pprString name
$$ pprString producer
$$ pprData4 dW_LANG_Haskell
$$ pprString compDir
$$ pprFlag True
$$ if haveSrc
then sectionOffset lineLbl dwarfLineLabel
else empty
pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df ->
pprAbbrev DwAbbrSubprogram
$$ 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
pprDwarfInfoOpen _ (DwarfBlock _ label marker) = sdocWithDynFlags $ \df ->
pprAbbrev DwAbbrBlock
$$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
$$ pprWord (ppr marker)
$$ pprWord (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoClose :: SDoc
pprDwarfInfoClose = pprAbbrev DwAbbrNull
data DwarfFrame
= DwarfFrame
{ dwCieLabel :: CLabel
, dwCieInit :: UnwindTable
, dwCieProcs :: [DwarfFrameProc]
}
data DwarfFrameProc
= DwarfFrameProc
{ dwFdeProc :: CLabel
, dwFdeHasInfo :: Bool
, dwFdeBlocks :: [DwarfFrameBlock]
}
data DwarfFrameBlock
= DwarfFrameBlock
{ dwFdeBlock :: CLabel
, dwFdeBlkHasInfo :: Bool
, dwFdeUnwind :: UnwindTable
}
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 (g, uw) = pprSetUnwind plat g (Nothing, uw)
in vcat [ ppr cieLabel <> colon
, pprData4' length
, ppr cieStartLabel <> colon
, pprData4' (ptext (sLit "-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
, 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 [ 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 (snd $ mapAccumL pprFrameBlock initUw blocks) $$
wordAlign $$
ppr fdeEndLabel <> colon
pprFrameBlock :: UnwindTable -> DwarfFrameBlock -> (UnwindTable, SDoc)
pprFrameBlock oldUws (DwarfFrameBlock blockLbl hasInfo uws)
| uws == oldUws
= (oldUws, empty)
| otherwise
= (,) uws $ sdocWithPlatform $ \plat ->
let lbl = ppr blockLbl <> if hasInfo then text "-1" else empty
isChanged g v | old == Just v = Nothing
| otherwise = Just (old, v)
where old = Map.lookup g oldUws
changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
died = Map.toList $ Map.difference oldUws uws
in pprByte dW_CFA_set_loc $$ pprWord lbl $$
vcat (map (uncurry $ pprSetUnwind plat) changed) $$
vcat (map (pprUndefUnwind plat . fst) died)
dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
dwarfGlobalRegNo p = maybe 0 (dwarfRegNo p . RegReal) . globalRegMaybe p
pprSetUnwind :: Platform -> GlobalReg -> (Maybe UnwindExpr, UnwindExpr) -> SDoc
pprSetUnwind _ Sp (Just (UwReg s _), 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 (_, UwReg s' o')
= if o' >= 0
then pprByte dW_CFA_def_cfa $$
pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$
pprLEBWord (fromIntegral o')
else pprByte dW_CFA_def_cfa_sf $$
pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$
pprLEBInt o'
pprSetUnwind _ Sp (_, uw)
= pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
pprSetUnwind plat g (_, 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 $$
pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
pprLEBInt o
pprSetUnwind plat g (_, UwDeref uw)
= pprByte dW_CFA_expression $$
pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
pprUnwindExpr True uw
pprSetUnwind plat g (_, uw)
= pprByte dW_CFA_val_expression $$
pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
pprUnwindExpr True uw
pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
pprUnwindExpr spIsCFA expr
= sdocWithPlatform $ \plat ->
let ppr (UwConst i)
| i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
| otherwise = pprByte dW_OP_consts $$ pprLEBInt i
ppr (UwReg Sp i) | spIsCFA
= if i == 0
then pprByte dW_OP_call_frame_cfa
else ppr (UwPlus (UwReg Sp 0) (UwConst i))
ppr (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
pprLEBInt i
ppr (UwDeref u) = ppr u $$ pprByte dW_OP_deref
ppr (UwPlus u1 u2) = ppr u1 $$ ppr u2 $$ pprByte dW_OP_plus
ppr (UwMinus u1 u2) = ppr u1 $$ ppr u2 $$ pprByte dW_OP_minus
ppr (UwTimes u1 u2) = ppr u1 $$ ppr u2 $$ pprByte dW_OP_mul
in ptext (sLit "\t.byte 1f-.-1") $$
ppr expr $$
ptext (sLit "1:")
pprUndefUnwind :: Platform -> GlobalReg -> SDoc
pprUndefUnwind _ Sp = panic "pprUndefUnwind Sp"
pprUndefUnwind plat g = pprByte dW_CFA_undefined $$
pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat g)
wordAlign :: SDoc
wordAlign = sdocWithPlatform $ \plat ->
ptext (sLit "\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 = ptext (sLit "\t.byte ") <> ppr (fromIntegral x :: Word)
pprFlag :: Bool -> SDoc
pprFlag f = pprByte (if f then 0xff else 0x00)
pprData4' :: SDoc -> SDoc
pprData4' x = ptext (sLit "\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 -> ptext (sLit "\t.long ")
8 -> ptext (sLit "\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 = ptext (sLit "\t.asciz \"") <> str <> char '"'
pprString :: String -> SDoc
pprString str
= pprString' $ hcat $ map escapeChar $
if utf8EncodedLength str == length str
then str
else map (chr . fromIntegral) $ bytesFS $ mkFastString str
escapeChar :: Char -> SDoc
escapeChar '\\' = ptext (sLit "\\\\")
escapeChar '\"' = ptext (sLit "\\\"")
escapeChar '\n' = ptext (sLit "\\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 :: LitString -> LitString -> SDoc
sectionOffset target section = sdocWithPlatform $ \plat ->
case platformOS plat of
OSDarwin -> pprDwWord (ptext target <> char '-' <> ptext section)
OSMinGW32 -> text "\t.secrel32 " <> ptext target
_other -> pprDwWord (ptext target)