X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=65e2f6feb3ccaeb10a93346f7c2c324365e0c355;hb=16dc208aaad7aadaea970e47b8055d7d7f8781e5;hp=97170a1c33e8b4a276aad248a36477d82afec31b;hpb=1f46671fe24c7155ee64091b71b77dd66909e7a0;p=ghc-hetmet.git diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 97170a1..65e2f6f 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ---------------------------------------------------------------------------- -- -- Pretty-printing of Cmm as (a superset of) C-- @@ -33,7 +40,7 @@ -- module PprCmm ( - writeCmms, pprCmms, pprCmm, pprStmt, pprExpr + writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic ) where #include "HsVersions.h" @@ -52,7 +59,7 @@ import Data.List import System.IO import Data.Maybe -pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc +pprCmms :: (Outputable info) => [GenCmm CmmStatic info (ListGraph CmmStmt)] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ ptext SLIT("-------------------") $$ space @@ -62,15 +69,22 @@ writeCmms handle cmms = printForC handle (pprCmms cmms) ----------------------------------------------------------------------------- -instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where +instance (Outputable info) => Outputable (GenCmm CmmStatic info (ListGraph CmmStmt)) where ppr c = pprCmm c -instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where +instance (Outputable d, Outputable info, Outputable i) + => Outputable (GenCmmTop d info i) where ppr t = pprTop t -instance Outputable CmmBasicBlock where +instance Outputable i => Outputable (ListGraph i) where + ppr (ListGraph blocks) = vcat (map ppr blocks) + +instance (Outputable instr) => Outputable (GenBasicBlock instr) where ppr b = pprBBlock b +instance Outputable BlockId where + ppr id = pprBlockId id + instance Outputable CmmStmt where ppr s = pprStmt s @@ -92,20 +106,24 @@ instance Outputable CmmStatic where instance Outputable CmmInfo where ppr e = pprInfo e + + ----------------------------------------------------------------------------- -pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc +pprCmm :: (Outputable info) => GenCmm CmmStatic info (ListGraph CmmStmt) -> SDoc pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc -pprTop (CmmProc info lbl params blocks ) +pprTop :: (Outputable d, Outputable info, Outputable g) + => GenCmmTop d info g -> SDoc + +pprTop (CmmProc info lbl params graph) = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace , nest 8 $ lbrace <+> ppr info $$ rbrace - , nest 4 $ vcat (map ppr blocks) + , nest 4 $ ppr graph , rbrace ] -- -------------------------------------------------------------------------- @@ -114,10 +132,13 @@ pprTop (CmmProc info lbl params blocks ) -- section "data" { ... } -- pprTop (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic 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 -- -------------------------------------------------------------------------- -- Info tables. The current pretty printer needs refinement @@ -126,15 +147,19 @@ pprTop (CmmData section ds) = -- 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 (CmmNonInfo gc_target) = - ptext SLIT("gc_target: ") <> - maybe (ptext SLIT("")) pprBlockId gc_target -pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc) - gc_target tag info) = - vcat [ptext SLIT("type: ") <> pprLit closure_type, +pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) = + vcat [{-ptext SLIT("gc_target: ") <> + maybe (ptext SLIT("")) pprBlockId gc_target,-} + ptext SLIT("update_frame: ") <> + maybe (ptext SLIT("")) pprUpdateFrame update_frame] +pprInfo (CmmInfo gc_target update_frame + (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) = + vcat [{-ptext SLIT("gc_target: ") <> + maybe (ptext SLIT("")) pprBlockId gc_target,-} + ptext SLIT("update_frame: ") <> + maybe (ptext SLIT("")) pprUpdateFrame update_frame, + ptext SLIT("type: ") <> pprLit closure_type, ptext SLIT("desc: ") <> pprLit closure_desc, - ptext SLIT("gc_target: ") <> - maybe (ptext SLIT("")) pprBlockId gc_target, ptext SLIT("tag: ") <> integer (toInteger tag), pprTypeInfo info] @@ -148,9 +173,9 @@ pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) = ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)), ptext SLIT("srt: ") <> ppr srt, ptext SLIT("fun_type: ") <> integer (toInteger fun_type), - ptext SLIT("arity: ") <> integer (toInteger arity) - --ppr args, -- TODO: needs to be printed - --ppr slow_entry -- TODO: needs to be printed + ptext SLIT("arity: ") <> integer (toInteger arity), + --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed + ptext SLIT("slow: ") <> pprLit slow_entry ] pprTypeInfo (ThunkInfo layout srt) = vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)), @@ -163,10 +188,23 @@ pprTypeInfo (ContInfo stack srt) = vcat [ptext SLIT("stack: ") <> ppr stack, ptext SLIT("srt: ") <> ppr srt] +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 ) ] + + -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. -pprBBlock :: CmmBasicBlock -> SDoc +pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts)) @@ -192,7 +230,7 @@ pprStmt stmt = case stmt of -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile - CmmCall (CmmForeignCall fn cconv) results args srt -> + CmmCall (CmmCallee fn cconv) results args safety ret -> hcat [ if null results then empty else parens (commafy $ map ppr results) <> @@ -200,14 +238,17 @@ pprStmt stmt = case stmt of ptext SLIT("call"), space, doubleQuotes(ppr cconv), space, target fn, parens ( commafy $ map ppr args ), - brackets (ppr srt), semi ] + brackets (ppr safety), + case ret of CmmMayReturn -> empty + CmmNeverReturns -> ptext SLIT(" never returns"), + semi ] where target (CmmLit lit) = pprLit lit target fn' = parens (ppr fn') - CmmCall (CmmPrim op) results args srt -> - pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv) - results args srt) + 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 False)