X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=163c86bcc7ba2aa03bf2c3ec2e16be8d76b54195;hb=d31dfb32ea936c22628b508c28a36c12e631430a;hp=e8176bae6031b205a2303fce99d24d9db35b0958;hpb=0a38c61e534a952ec7a083c822efeac71b9015f4;p=ghc-hetmet.git diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index e8176ba..163c86b 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,56 @@ 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 (CmmNonInfo gc_target) = + ptext SLIT("gc_target: ") <> + ptext SLIT("TODO") --maybe (ptext SLIT("")) pprBlockId gc_target + -- ^ gc_target is currently unused and wired to a panic +pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc) + gc_target tag info) = + vcat [ptext SLIT("type: ") <> pprLit closure_type, + ptext SLIT("desc: ") <> pprLit closure_desc, + ptext SLIT("gc_target: ") <> + ptext SLIT("TODO"), --maybe (ptext SLIT("")) pprBlockId gc_target, + -- ^ gc_target is currently unused and wired to a panic + 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) + --ppr args, -- TODO: needs to be printed + --ppr slow_entry -- TODO: needs to be printed + ] +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] -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. @@ -147,26 +197,29 @@ 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 (CmmForeignCall 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 -> + CmmCall (CmmPrim op) results args safety -> pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv) - results args volatile) + results args safety) where lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) 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 -- -------------------------------------------------------------------------- @@ -195,8 +248,8 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> [LocalReg] -> SDoc -genJump expr actuals = +genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc +genJump expr args = hcat [ ptext SLIT("jump") , space @@ -205,12 +258,22 @@ genJump expr actuals = else case expr of CmmLoad (CmmReg _) _ -> pprExpr expr _ -> parens (pprExpr expr) - , pprActuals actuals + , space + , parens ( commafy $ map ppr args ) , semi ] - where - pprActuals [] = empty - pprActuals as = parens ( commafy $ map pprLocalReg as ) +-- -------------------------------------------------------------------------- +-- Return from a function. [1], Section 6.8.2 of version 1.128 +-- +-- return (a, b, c); +-- +genReturn :: [(CmmExpr, MachHint)] -> SDoc +genReturn args = + + hcat [ ptext SLIT("return") + , space + , parens ( commafy $ map ppr args ) + , semi ] -- -------------------------------------------------------------------------- -- Tabled jump to local label @@ -411,10 +474,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 --