module OldPprCmm
( pprStmt
, module PprCmmDecl
, module PprCmmExpr
)
where
import BlockId
import CLabel
import CmmUtils
import OldCmm
import PprCmmDecl
import PprCmmExpr
import BasicTypes
import ForeignCall
import Outputable
import Platform
import FastString
import Data.List
instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where
pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks)
instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where
pprPlatform platform b = pprBBlock platform b
instance Outputable CmmStmt where
ppr s = pprStmt s
instance PlatformOutputable CmmStmt where
pprPlatform _ = ppr
instance Outputable CmmInfo where
ppr e = pprInfo e
instance Outputable CmmSafety where
ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
ppr CmmInterruptible = ptext (sLit "_interruptible_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 info_table@(CmmInfoTable _ _ _ _ _)) =
vcat [
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
ppr info_table]
pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc
pprBBlock platform (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) 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 (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 a) => Outputable (CmmHinted a) where
ppr (CmmHinted a k) = ppr (a, k)
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 ) ]
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 ]
commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs