X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=2d3fd6a7465bd3a9e96f6e8f85330de9d8826f5b;hb=1c5499d4d5d506ce0cc971e98c09bfbf7bc290a1;hp=06d68c0eb538d79868c862aeeb21677ee34f3071;hpb=a20e8369c11f0f71444f2b849e47eaab6fff1315;p=ghc-hetmet.git diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 06d68c0..2d3fd6a 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -52,7 +52,7 @@ import Data.List import System.IO import Data.Maybe -pprCmms :: [Cmm] -> SDoc +pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ ptext SLIT("-------------------") $$ space @@ -62,10 +62,10 @@ writeCmms handle cmms = printForC handle (pprCmms cmms) ----------------------------------------------------------------------------- -instance Outputable Cmm where +instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where ppr c = pprCmm c -instance Outputable CmmTop where +instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where ppr t = pprTop t instance Outputable CmmBasicBlock where @@ -80,34 +80,34 @@ instance Outputable CmmExpr where instance Outputable CmmReg where ppr e = pprReg e +instance Outputable LocalReg where + ppr e = pprLocalReg 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 :: Cmm -> SDoc +pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops -- -------------------------------------------------------------------------- --- Top level `procedure' blocks. The info tables, if not null, are --- printed in the style of C--'s 'stackdata' declaration, just inside --- the proc body, and are labelled with the procedure name ++ "_info". +-- Top level `procedure' blocks. -- -pprTop :: CmmTop -> SDoc +pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc pprTop (CmmProc info lbl params blocks ) - = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace - , nest 8 $ pprInfo info lbl + = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace + , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ vcat (map ppr blocks) , rbrace ] - where - pprInfo [] _ = empty - pprInfo i label = - (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace ) - 4 $ vcat (map pprStatic i)) - $$ rbrace - -- -------------------------------------------------------------------------- -- We follow [1], 4.5 -- @@ -117,6 +117,71 @@ pprTop (CmmData section ds) = (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic 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 +-- 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 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("tag: ") <> integer (toInteger tag), + pprTypeInfo info] + +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 fun_type 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 fun_type), + 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)), + 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] + +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. @@ -147,20 +212,22 @@ pprStmt stmt = case stmt of -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile - CmmCall (CmmForeignCall fn cconv) results args _volatile -> - hcat [ ptext SLIT("call"), space, + CmmCall (CmmCallee fn cconv) results args safety -> + hcat [ if null results + then empty + else parens (commafy $ map ppr results) <> + ptext SLIT(" = "), + ptext SLIT("call"), space, doubleQuotes(ppr cconv), space, target fn, parens ( commafy $ map ppr args ), - (if null results - then empty - else brackets( commafy $ map ppr results)), semi ] + brackets (ppr safety), semi ] where target (CmmLit lit) = pprLit lit target fn' = parens (ppr fn') - CmmCall (CmmPrim op) results args volatile -> - pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv) - results args volatile) + CmmCall (CmmPrim op) results args safety -> + pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) + results args safety) where lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) @@ -422,10 +489,14 @@ pprReg r -- We only print the type of the local reg if it isn't wordRep -- pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep) - = hcat [ char '_', ppr uniq, - (if rep == wordRep - then empty else dcolon <> ppr rep) ] +pprLocalReg (LocalReg uniq rep follow) + = hcat [ char '_', ppr uniq, ty ] where + ty = if rep == wordRep && follow == KindNonPtr + then empty + else dcolon <> ptr <> ppr rep + ptr = if follow == KindNonPtr + then empty + else doubleQuotes (text "ptr") -- needs to be kept in syn with Cmm.hs.GlobalReg --