module PprCmm
( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr,
pprSection, pprStatic, pprLit
)
where
import BlockId
import Cmm
import CmmUtils
import CLabel
import BasicTypes
import ForeignCall
import Outputable
import FastString
import Data.List
import System.IO
import Data.Maybe
import SMRep
import ClosureInfo
#include "../includes/rts/storage/FunTypes.h"
pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ ptext (sLit "-------------------") $$ space
writeCmms :: Handle -> [Cmm] -> IO ()
writeCmms handle cmms = printForC handle (pprCmms cmms)
instance (Outputable d, Outputable info, Outputable g)
=> Outputable (GenCmm d info g) where
ppr c = pprCmm c
instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmTop d info i) where
ppr t = pprTop t
instance (Outputable instr) => Outputable (ListGraph instr) where
ppr (ListGraph blocks) = vcat (map ppr blocks)
instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b
instance Outputable CmmStmt where
ppr s = pprStmt s
instance Outputable CmmExpr where
ppr e = pprExpr e
instance Outputable CmmReg where
ppr e = pprReg e
instance Outputable CmmLit where
ppr l = pprLit l
instance Outputable LocalReg where
ppr e = pprLocalReg e
instance Outputable Area where
ppr e = pprArea e
instance Outputable GlobalReg where
ppr e = pprGlobalReg e
instance Outputable CmmStatic where
ppr e = pprStatic e
instance Outputable CmmInfo where
ppr e = pprInfo e
pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
pprTop :: (Outputable d, Outputable info, Outputable i)
=> GenCmmTop d info i -> SDoc
pprTop (CmmProc info lbl params graph )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
, nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ ppr graph
, rbrace ]
pprTop (CmmData section ds) =
(hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
$$ rbrace
instance Outputable CmmSafety where
ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
ppr (CmmSafe srt) = ppr srt
pprInfo :: CmmInfo -> SDoc
pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
vcat [
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
pprInfo (CmmInfo _gc_target update_frame
(CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
vcat [
ptext (sLit "has static closure: ") <> ppr stat_clos <+>
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
ptext (sLit "type: ") <> pprLit closure_type,
ptext (sLit "desc: ") <> pprLit closure_desc,
ptext (sLit "tag: ") <> integer (toInteger tag),
pprTypeInfo info]
pprTypeInfo :: ClosureTypeInfo -> SDoc
pprTypeInfo (ConstrInfo layout constr descr) =
vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
ptext (sLit "constructor: ") <> integer (toInteger constr),
pprLit descr]
pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
ptext (sLit "srt: ") <> ppr srt,
ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
ptext (sLit "arity: ") <> integer (toInteger arity),
ptext (sLit "slow: ") <> pprLit slow_entry
]
pprTypeInfo (ThunkInfo layout srt) =
vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
ptext (sLit "srt: ") <> ppr srt]
pprTypeInfo (ThunkSelectorInfo offset srt) =
vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
ptext (sLit "srt: ") <> ppr srt]
pprTypeInfo (ContInfo stack srt) =
vcat [ptext (sLit "stack: ") <> ppr stack,
ptext (sLit "srt: ") <> ppr srt]
argDescrType :: ArgDescr -> StgHalfWord
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
| isBigLiveness liveness = ARG_GEN_BIG
| otherwise = ARG_GEN
isBigLiveness :: Liveness -> Bool
isBigLiveness (BigLiveness _) = True
isBigLiveness (SmallLiveness _) = False
pprUpdateFrame :: UpdateFrame -> SDoc
pprUpdateFrame (UpdateFrame expr args) =
hcat [ ptext (sLit "jump")
, space
, if isTrivialCmmExpr expr
then pprExpr expr
else case expr of
CmmLoad (CmmReg _) _ -> pprExpr expr
_ -> parens (pprExpr expr)
, space
, parens ( commafy $ map ppr args ) ]
pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
pprStmt :: CmmStmt -> SDoc
pprStmt stmt = case stmt of
CmmNop -> semi
CmmComment s -> text "//" <+> ftext s
CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
where
rep = ppr ( cmmExprType expr )
CmmCall (CmmCallee fn cconv) results args safety ret ->
sep [ pp_lhs <+> pp_conv
, nest 2 (pprExpr9 fn <>
parens (commafy (map ppr_ar args)))
<> brackets (ppr safety)
, case ret of CmmMayReturn -> empty
CmmNeverReturns -> ptext $ sLit (" never returns")
] <> semi
where
pp_lhs | null results = empty
| otherwise = commafy (map ppr_ar results) <+> equals
ppr_ar :: Outputable a => CmmHinted a -> SDoc
ppr_ar (CmmHinted ar k) = case cconv of
CmmCallConv -> ppr ar
_ -> ppr (ar,k)
pp_conv = case cconv of
CmmCallConv -> empty
_ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
CmmCall (CmmPrim op) results args safety ret ->
pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
results args safety ret)
where
lbl = CmmLabel (mkForeignLabel
(mkFastString (show op))
Nothing ForeignLabelInThisPackage IsFunction)
CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch expr ident
CmmJump expr params -> genJump expr params
CmmReturn params -> genReturn params
CmmSwitch arg ids -> genSwitch arg ids
instance Outputable ForeignHint where
ppr NoHint = empty
ppr SignedHint = quotes(text "signed")
ppr AddrHint = (text "PtrHint")
instance (Outputable a) => Outputable (CmmHinted a) where
ppr (CmmHinted a k) = ppr (a, k)
genBranch :: BlockId -> SDoc
genBranch ident =
ptext (sLit "goto") <+> ppr ident <> semi
genCondBranch :: CmmExpr -> BlockId -> SDoc
genCondBranch expr ident =
hsep [ ptext (sLit "if")
, parens(ppr expr)
, ptext (sLit "goto")
, ppr ident <> semi ]
genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
genJump expr args =
hcat [ ptext (sLit "jump")
, space
, if isTrivialCmmExpr expr
then pprExpr expr
else case expr of
CmmLoad (CmmReg _) _ -> pprExpr expr
_ -> parens (pprExpr expr)
, space
, parens ( commafy $ map ppr args )
, semi ]
genReturn :: [CmmHinted CmmExpr] -> SDoc
genReturn args =
hcat [ ptext (sLit "return")
, space
, parens ( commafy $ map ppr args )
, semi ]
genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
genSwitch expr maybe_ids
= let pairs = groupBy snds (zip [0 .. ] maybe_ids )
in hang (hcat [ ptext (sLit "switch [0 .. ")
, int (length maybe_ids 1)
, ptext (sLit "] ")
, if isTrivialCmmExpr expr
then pprExpr expr
else parens (pprExpr expr)
, ptext (sLit " {")
])
4 (vcat ( map caseify pairs )) $$ rbrace
where
snds a b = (snd a) == (snd b)
caseify :: [(Int,Maybe BlockId)] -> SDoc
caseify ixs@((_,Nothing):_)
= ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
<> ptext (sLit " */")
caseify as
= let (is,ids) = unzip as
in hsep [ ptext (sLit "case")
, hcat (punctuate comma (map int is))
, ptext (sLit ": goto")
, ppr (head [ id | Just id <- ids]) <> semi ]
pprExpr :: CmmExpr -> SDoc
pprExpr e
= case e of
CmmRegOff reg i ->
pprExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
where rep = typeWidth (cmmRegType reg)
CmmLit lit -> pprLit lit
_other -> pprExpr1 e
pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
= pprExpr7 x <+> doc <+> pprExpr7 y
pprExpr1 e = pprExpr7 e
infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
infixMachOp1 (MO_U_Gt _) = Just (char '>')
infixMachOp1 (MO_U_Lt _) = Just (char '<')
infixMachOp1 _ = Nothing
pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
= pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
= pprExpr7 x <+> doc <+> pprExpr8 y
pprExpr7 e = pprExpr8 e
infixMachOp7 (MO_Add _) = Just (char '+')
infixMachOp7 (MO_Sub _) = Just (char '-')
infixMachOp7 _ = Nothing
pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
= pprExpr8 x <+> doc <+> pprExpr9 y
pprExpr8 e = pprExpr9 e
infixMachOp8 (MO_U_Quot _) = Just (char '/')
infixMachOp8 (MO_Mul _) = Just (char '*')
infixMachOp8 (MO_U_Rem _) = Just (char '%')
infixMachOp8 _ = Nothing
pprExpr9 :: CmmExpr -> SDoc
pprExpr9 e =
case e of
CmmLit lit -> pprLit1 lit
CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
CmmReg reg -> ppr reg
CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
CmmMachOp mop args -> genMachOp mop args
genMachOp :: MachOp -> [CmmExpr] -> SDoc
genMachOp mop args
| Just doc <- infixMachOp mop = case args of
[x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
[x] -> doc <> pprExpr9 x
_ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
(pprMachOp mop <+>
parens (hcat $ punctuate comma (map pprExpr args)))
empty
| isJust (infixMachOp1 mop)
|| isJust (infixMachOp7 mop)
|| isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
| otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
(show mop))
infixMachOp :: MachOp -> Maybe SDoc
infixMachOp mop
= case mop of
MO_And _ -> Just $ char '&'
MO_Or _ -> Just $ char '|'
MO_Xor _ -> Just $ char '^'
MO_Not _ -> Just $ char '~'
MO_S_Neg _ -> Just $ char '-'
_ -> Nothing
pprLit :: CmmLit -> SDoc
pprLit lit = case lit of
CmmInt i rep ->
hcat [ (if i < 0 then parens else id)(integer i)
, ppUnless (rep == wordWidth) $
space <> dcolon <+> ppr rep ]
CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
CmmLabel clbl -> pprCLabel clbl
CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
<> pprCLabel clbl2 <> ppr_offset i
CmmBlock id -> ppr id
CmmHighStackMark -> text "<highSp>"
pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
pprLit1 lit = pprLit lit
ppr_offset :: Int -> SDoc
ppr_offset i
| i==0 = empty
| i>=0 = char '+' <> int i
| otherwise = char '-' <> int (i)
pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of
CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
CmmAlign i -> nest 4 $ text "align" <+> int i
CmmDataLabel clbl -> pprCLabel clbl <> colon
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
pprReg :: CmmReg -> SDoc
pprReg r
= case r of
CmmLocal local -> pprLocalReg local
CmmGlobal global -> pprGlobalReg global
pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg uniq rep)
= char '_' <> ppr uniq <>
(if isWord32 rep
then dcolon <> ptr <> ppr rep
else dcolon <> ptr <> ppr rep)
where
ptr = empty
pprArea :: Area -> SDoc
pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
pprArea (CallArea id) = pprAreaId id
pprAreaId :: AreaId -> SDoc
pprAreaId Old = text "old"
pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr
= case gr of
VanillaReg n _ -> char 'R' <> int n
FloatReg n -> char 'F' <> int n
DoubleReg n -> char 'D' <> int n
LongReg n -> char 'L' <> int n
Sp -> ptext (sLit "Sp")
SpLim -> ptext (sLit "SpLim")
Hp -> ptext (sLit "Hp")
HpLim -> ptext (sLit "HpLim")
CurrentTSO -> ptext (sLit "CurrentTSO")
CurrentNursery -> ptext (sLit "CurrentNursery")
HpAlloc -> ptext (sLit "HpAlloc")
EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
GCEnter1 -> ptext (sLit "stg_gc_enter_1")
GCFun -> ptext (sLit "stg_gc_fun")
BaseReg -> ptext (sLit "BaseReg")
PicBaseReg -> ptext (sLit "PicBaseReg")
pprSection :: Section -> SDoc
pprSection s = case s of
Text -> section <+> doubleQuotes (ptext (sLit "text"))
Data -> section <+> doubleQuotes (ptext (sLit "data"))
ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly"))
ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16"))
RelocatableReadOnlyData
-> section <+> doubleQuotes (ptext (sLit "relreadonly"))
UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
OtherSection s' -> section <+> doubleQuotes (text s')
where
section = ptext (sLit "section")
commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs