---------------------------------------------------------------------------- -- -- Pretty-printing of Cmm as (a superset of) C-- -- -- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- -- -- This is where we walk over CmmNode 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 {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-} module PprCmm ( module PprCmmDecl , module PprCmmExpr ) where import BlockId () import CLabel import Cmm import CmmExpr import CmmUtils (isTrivialCmmExpr) import FastString import Outputable import PprCmmDecl import PprCmmExpr import Util import BasicTypes import Compiler.Hoopl import Data.List import Prelude hiding (succ) ------------------------------------------------- -- Outputable instances instance Outputable CmmStackInfo where ppr = pprStackInfo instance Outputable CmmTopInfo where ppr = pprTopInfo instance Outputable (CmmNode e x) where ppr = pprNode instance Outputable Convention where ppr = pprConvention instance Outputable ForeignConvention where ppr = pprForeignConvention instance Outputable ForeignTarget where ppr = pprForeignTarget instance Outputable (Block CmmNode C C) where ppr = pprBlock instance Outputable (Block CmmNode C O) where ppr = pprBlock instance Outputable (Block CmmNode O C) where ppr = pprBlock instance Outputable (Block CmmNode O O) where ppr = pprBlock instance Outputable (Graph CmmNode e x) where ppr = pprGraph instance Outputable CmmGraph where ppr = pprCmmGraph ---------------------------------------------------------- -- Outputting types Cmm contains pprStackInfo :: CmmStackInfo -> SDoc pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = ptext (sLit "arg_space: ") <> ppr arg_space <+> ptext (sLit "updfr_space: ") <> ppr updfr_space pprTopInfo :: CmmTopInfo -> SDoc pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, ptext (sLit "stack_info: ") <> ppr stack_info] ---------------------------------------------------------- -- Outputting blocks and graphs pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc pprBlock block = foldBlockNodesB3 ( ($$) . ppr , ($$) . (nest 4) . ppr , ($$) . (nest 4) . ppr ) block empty pprGraph :: Graph CmmNode e x -> SDoc pprGraph GNil = empty pprGraph (GUnit block) = ppr block pprGraph (GMany entry body exit) = text "{" $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) $$ text "}" where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc pprMaybeO NothingO = empty pprMaybeO (JustO block) = ppr block pprCmmGraph :: CmmGraph -> SDoc pprCmmGraph g = text "{" <> text "offset" $$ nest 2 (vcat $ map ppr blocks) $$ text "}" where blocks = postorderDfs g --------------------------------------------- -- Outputting CmmNode and types which it contains pprConvention :: Convention -> SDoc pprConvention (NativeNodeCall {}) = text "" pprConvention (NativeDirectCall {}) = text "" pprConvention (NativeReturn {}) = text "" pprConvention Slow = text "" pprConvention GC = text "" pprConvention PrimOpCall = text "" pprConvention PrimOpReturn = text "" pprConvention (Foreign c) = ppr c pprConvention (Private {}) = text "" pprForeignConvention :: ForeignConvention -> SDoc pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs pprForeignTarget :: ForeignTarget -> SDoc pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn where ppr_fc :: ForeignConvention -> SDoc ppr_fc (ForeignConvention c args res) = doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res ppr_target :: CmmExpr -> SDoc ppr_target t@(CmmLit _) = ppr t ppr_target fn' = parens (ppr fn') pprForeignTarget (PrimTarget op) -- HACK: We're just using a ForeignLabel to get this printed, the label -- might not really be foreign. = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing ForeignLabelInThisPackage IsFunction)) pprNode :: CmmNode e x -> SDoc pprNode node = pp_node <+> pp_debug where pp_node :: SDoc pp_node = case node of -- label: CmmEntry id -> ppr id <> colon -- // 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 CmmUnsafeForeignCall target results args -> hsep [ ppUnless (null results) $ parens (commafy $ map ppr results) <+> equals, ptext $ sLit "call", ppr target <> parens (commafy $ map ppr args) <> semi] -- goto label; CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi -- if (expr) goto t; else goto f; CmmCondBranch expr t f -> hsep [ ptext (sLit "if") , parens(ppr expr) , ptext (sLit "goto") , ppr t <> semi , ptext (sLit "else goto") , ppr f <> semi ] CmmSwitch expr maybe_ids -> hang (hcat [ ptext (sLit "switch [0 .. ") , int (length maybe_ids - 1) , ptext (sLit "] ") , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr) , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace where pairs = groupBy snds (zip [0 .. ] maybe_ids ) snds a b = (snd a) == (snd b) 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 ] CmmCall tgt k out res updfr_off -> hcat [ ptext (sLit "call"), space , pprFun tgt, ptext (sLit "(...)"), space , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out) <+> parens (ppr res) , ptext (sLit " with update frame") <+> ppr updfr_off , semi ] where pprFun f@(CmmLit _) = ppr f pprFun f = parens (ppr f) CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ [ ptext (sLit "foreign call"), space , ppr t, ptext (sLit "(...)"), space , ptext (sLit "returns to") <+> ppr s <+> ptext (sLit "args:") <+> parens (ppr as) <+> ptext (sLit "ress:") <+> parens (ppr rs) , ptext (sLit " with update frame") <+> ppr u , semi ] pp_debug :: SDoc pp_debug = if not debugIsOn then empty else case node of CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" CmmAssign {} -> text " // CmmAssign" CmmStore {} -> text " // CmmStore" CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" CmmBranch {} -> text " // CmmBranch" CmmCondBranch {} -> text " // CmmCondBranch" CmmSwitch {} -> text " // CmmSwitch" CmmCall {} -> text " // CmmCall" CmmForeignCall {} -> text " // CmmForeignCall" commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs