X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=7a1ffbbf299346fa6ec1f9776ffa9d90dca6d360;hp=b718ec9f407d3995cf73caf84f2f38b9eb8d1c20;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=f2cc8b5bc34519a65581dc40b7bfebac97bffd73 diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index b718ec9..7a1ffbb 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/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 :: [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,15 +69,19 @@ 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 d, Outputable info, Outputable i) + => Outputable (GenCmmTop d info i) where ppr t = pprTop t -instance Outputable CmmBasicBlock where +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 @@ -80,48 +91,117 @@ 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 d, Outputable info, Outputable i) + => GenCmmTop d info i -> 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 -- -- 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 +-- 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. -- 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)) @@ -147,20 +227,25 @@ 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 ret -> + 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), + 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 volatile -> - pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv) - results args volatile) + 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) @@ -206,6 +291,7 @@ genJump expr args = else case expr of CmmLoad (CmmReg _) _ -> pprExpr expr _ -> parens (pprExpr expr) + , space , parens ( commafy $ map ppr args ) , semi ] @@ -421,10 +507,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 --