---------------------------------------------------------------------------- -- -- Pretty-printing of old-style Cmm as (a superset of) C-- -- -- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- -- -- This is where we walk over Cmm emitting an external representation, -- suitable for parsing, in a syntax strongly reminiscent of C--. This -- is the "External Core" for the Cmm layer. -- -- As such, this should be a well-defined syntax: we want it to look nice. -- Thus, we try wherever possible to use syntax defined in [1], -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ -- slightly, in some cases. For one, we use I8 .. I64 for types, rather -- than C--'s bits8 .. bits64. -- -- We try to ensure that all information available in the abstract -- syntax is reproduced, or reproducible, in the concrete syntax. -- Data that is not in printed out can be reconstructed according to -- conventions used in the pretty printer. There are at least two such -- cases: -- 1) if a value has wordRep type, the type is not appended in the -- output. -- 2) MachOps that operate over wordRep type are printed in a -- C-style, rather than as their internal MachRep name. -- -- These conventions produce much more readable Cmm output. -- -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- 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 FastString import Data.List ----------------------------------------------------------------------------- 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 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 -- -------------------------------------------------------------------------- -- Info tables. The current pretty printer needs refinement -- but will work for now. -- -- For ideas on how to refine it, they used to be printed in the -- style of C--'s 'stackdata' declaration, just inside the proc body, -- and were labelled with the procedure name ++ "_info". pprInfo :: CmmInfo -> SDoc pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) = vcat [{-ptext (sLit "gc_target: ") <> maybe (ptext (sLit "")) ppr gc_target,-} ptext (sLit "update_frame: ") <> maybe (ptext (sLit "")) pprUpdateFrame update_frame] pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) = vcat [{-ptext (sLit "gc_target: ") <> maybe (ptext (sLit "")) ppr gc_target,-} ptext (sLit "update_frame: ") <> maybe (ptext (sLit "")) pprUpdateFrame update_frame, ppr info_table] -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. -- pprStmt :: CmmStmt -> SDoc pprStmt stmt = case stmt of -- ; CmmNop -> semi -- // text CmmComment s -> text "//" <+> ftext s -- reg = expr; CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi -- rep[lv] = expr; CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where rep = ppr ( cmmExprType expr ) -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile 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 -- Don't print the hints on a native C-- call 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) -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. CmmCall (CmmPrim op) results args safety ret -> pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args safety ret) where -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we -- use one to get the label printed. 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 -- Just look like a tuple, since it was a tuple before -- ... is that a good idea? --Isaac Dupree 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 ) ] -- -------------------------------------------------------------------------- -- goto local label. [1], section 6.6 -- -- goto lbl; -- genBranch :: BlockId -> SDoc genBranch ident = ptext (sLit "goto") <+> ppr ident <> semi -- -------------------------------------------------------------------------- -- Conditional. [1], section 6.4 -- -- if (expr) { goto lbl; } -- genCondBranch :: CmmExpr -> BlockId -> SDoc genCondBranch expr ident = hsep [ ptext (sLit "if") , parens(ppr expr) , ptext (sLit "goto") , ppr ident <> semi ] -- -------------------------------------------------------------------------- -- A tail call. [1], Section 6.9 -- -- jump foo(a, b, c); -- 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 ] -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 -- -- return (a, b, c); -- genReturn :: [CmmHinted CmmExpr] -> SDoc genReturn args = hcat [ ptext (sLit "return") , space , parens ( commafy $ map ppr args ) , semi ] -- -------------------------------------------------------------------------- -- Tabled jump to local label -- -- The syntax is from [1], section 6.5 -- -- switch [0 .. n] (expr) { case ... ; } -- 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