X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=2755312a5a81cc0d6366ab04e4097953dd16d79a;hb=cd11f455bb11647eaf1b533ce775111c74d569b6;hp=55a8014b46331433b51b0ad05f9406d44a2ab6c2;hpb=f96e9aa0444de0e673b3c4055c6e43299639bc5b;p=ghc-hetmet.git diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 55a8014..2755312 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-- @@ -32,13 +39,13 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- -module PprCmm ( - writeCmms, pprCmms, pprCmm, pprStmt, pprExpr - ) where - -#include "HsVersions.h" +module PprCmm + ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic, pprLit + ) +where import Cmm +import CmmExpr import CmmUtils import MachOp import CLabel @@ -52,23 +59,28 @@ import Data.List import System.IO import Data.Maybe -pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc +pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where - separator = space $$ ptext SLIT("-------------------") $$ space + separator = space $$ ptext (sLit "-------------------") $$ space writeCmms :: Handle -> [Cmm] -> IO () writeCmms handle cmms = printForC handle (pprCmms cmms) ----------------------------------------------------------------------------- -instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where +instance (Outputable d, Outputable info, Outputable g) + => Outputable (GenCmm d info g) 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 instr) => Outputable (ListGraph instr) where + ppr (ListGraph blocks) = vcat (map ppr blocks) + +instance (Outputable instr) => Outputable (GenBasicBlock instr) where ppr b = pprBBlock b instance Outputable CmmStmt where @@ -92,20 +104,24 @@ instance Outputable CmmStatic where instance Outputable CmmInfo where ppr e = pprInfo e + + ----------------------------------------------------------------------------- -pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc +pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> 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 i) + => GenCmmTop d info i -> 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 +130,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,42 +145,64 @@ 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 = empty -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: ") <> - maybe (ptext SLIT("")) pprBlockId gc_target, - ptext SLIT("tag: ") <> integer (toInteger tag), +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), - ppr 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 + 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] + 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] + 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)) @@ -187,22 +228,25 @@ 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) <> - ptext SLIT(" = "), - ptext SLIT("call"), space, + ptext (sLit " = "), + ptext (sLit "foreign"), 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) @@ -219,7 +263,7 @@ pprStmt stmt = case stmt of -- genBranch :: BlockId -> SDoc genBranch ident = - ptext SLIT("goto") <+> pprBlockId ident <> semi + ptext (sLit "goto") <+> pprBlockId ident <> semi -- -------------------------------------------------------------------------- -- Conditional. [1], section 6.4 @@ -228,9 +272,9 @@ genBranch ident = -- genCondBranch :: CmmExpr -> BlockId -> SDoc genCondBranch expr ident = - hsep [ ptext SLIT("if") + hsep [ ptext (sLit "if") , parens(ppr expr) - , ptext SLIT("goto") + , ptext (sLit "goto") , pprBlockId ident <> semi ] -- -------------------------------------------------------------------------- @@ -238,10 +282,10 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc +genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc genJump expr args = - hcat [ ptext SLIT("jump") + hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr then pprExpr expr @@ -249,18 +293,24 @@ genJump expr args = CmmLoad (CmmReg _) _ -> pprExpr expr _ -> parens (pprExpr expr) , space - , parens ( commafy $ map ppr args ) + , parens ( commafy $ map pprHinted args ) , semi ] +pprHinted :: Outputable a => (CmmHinted a) -> SDoc +pprHinted (CmmHinted a NoHint) = ppr a +pprHinted (CmmHinted a PtrHint) = quotes(text "address") <+> ppr a +pprHinted (CmmHinted a SignedHint) = quotes(text "signed") <+> ppr a +pprHinted (CmmHinted a FloatHint) = quotes(text "float") <+> ppr a + -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 -- -- return (a, b, c); -- -genReturn :: [(CmmExpr, MachHint)] -> SDoc +genReturn :: [CmmHinted CmmExpr] -> SDoc genReturn args = - hcat [ ptext SLIT("return") + hcat [ ptext (sLit "return") , space , parens ( commafy $ map ppr args ) , semi ] @@ -277,13 +327,13 @@ genSwitch expr maybe_ids = let pairs = groupBy snds (zip [0 .. ] maybe_ids ) - in hang (hcat [ ptext SLIT("switch [0 .. ") + in hang (hcat [ ptext (sLit "switch [0 .. ") , int (length maybe_ids - 1) - , ptext SLIT("] ") + , ptext (sLit "] ") , if isTrivialCmmExpr expr then pprExpr expr else parens (pprExpr expr) - , ptext SLIT(" {") + , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace @@ -292,13 +342,13 @@ genSwitch expr maybe_ids caseify :: [(Int,Maybe BlockId)] -> SDoc caseify ixs@((i,Nothing):_) - = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) - <> ptext SLIT(" */") + = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) + <> ptext (sLit " */") caseify as = let (is,ids) = unzip as - in hsep [ ptext SLIT("case") + in hsep [ ptext (sLit "case") , hcat (punctuate comma (map int is)) - , ptext SLIT(": goto") + , ptext (sLit ": goto") , pprBlockId (head [ id | Just id <- ids]) <> semi ] -- -------------------------------------------------------------------------- @@ -333,12 +383,12 @@ pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op = pprExpr7 x <+> doc <+> pprExpr7 y pprExpr1 e = pprExpr7 e -infixMachOp1 (MO_Eq _) = Just (ptext SLIT("==")) -infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!=")) -infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<")) -infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>")) -infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">=")) -infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<=")) +infixMachOp1 (MO_Eq _) = Just (ptext (sLit "==")) +infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!=")) +infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<")) +infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>")) +infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">=")) +infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<=")) infixMachOp1 (MO_U_Gt _) = Just (char '>') infixMachOp1 (MO_U_Lt _) = Just (char '<') infixMachOp1 _ = Nothing @@ -445,7 +495,7 @@ ppr_offset i -- pprStatic :: CmmStatic -> SDoc pprStatic s = case s of - CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi + CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) CmmAlign i -> nest 4 $ text "align" <+> int i CmmDataLabel clbl -> pprCLabel clbl <> colon @@ -466,10 +516,10 @@ pprReg r pprLocalReg :: LocalReg -> SDoc pprLocalReg (LocalReg uniq rep follow) = hcat [ char '_', ppr uniq, ty ] where - ty = if rep == wordRep && follow == KindNonPtr + ty = if rep == wordRep && follow == GCKindNonPtr then empty else dcolon <> ptr <> ppr rep - ptr = if follow == KindNonPtr + ptr = if follow == GCKindNonPtr then empty else doubleQuotes (text "ptr") @@ -482,33 +532,34 @@ pprGlobalReg gr FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n - Sp -> ptext SLIT("Sp") - SpLim -> ptext SLIT("SpLim") - Hp -> ptext SLIT("Hp") - HpLim -> ptext SLIT("HpLim") - CurrentTSO -> ptext SLIT("CurrentTSO") - CurrentNursery -> ptext SLIT("CurrentNursery") - HpAlloc -> ptext SLIT("HpAlloc") - GCEnter1 -> ptext SLIT("stg_gc_enter_1") - GCFun -> ptext SLIT("stg_gc_fun") - BaseReg -> ptext SLIT("BaseReg") - PicBaseReg -> ptext SLIT("PicBaseReg") + Sp -> ptext (sLit "Sp") + SpLim -> ptext (sLit "SpLim") + Hp -> ptext (sLit "Hp") + HpLim -> ptext (sLit "HpLim") + CurrentTSO -> ptext (sLit "CurrentTSO") + CurrentNursery -> ptext (sLit "CurrentNursery") + HpAlloc -> ptext (sLit "HpAlloc") + GCEnter1 -> ptext (sLit "stg_gc_enter_1") + GCFun -> ptext (sLit "stg_gc_fun") + BaseReg -> ptext (sLit "BaseReg") + PicBaseReg -> ptext (sLit "PicBaseReg") -- -------------------------------------------------------------------------- -- data sections -- pprSection :: Section -> SDoc pprSection s = case s of - Text -> section <+> doubleQuotes (ptext SLIT("text")) - Data -> section <+> doubleQuotes (ptext SLIT("data")) - ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly")) + Text -> section <+> doubleQuotes (ptext (sLit "text")) + Data -> section <+> doubleQuotes (ptext (sLit "data")) + ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly")) + ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16")) RelocatableReadOnlyData - -> section <+> doubleQuotes (ptext SLIT("relreadonly")) - UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised")) + -> section <+> doubleQuotes (ptext (sLit "relreadonly")) + UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised")) OtherSection s' -> section <+> doubleQuotes (text s') where - section = ptext SLIT("section") - + section = ptext (sLit "section") + -- -------------------------------------------------------------------------- -- Basic block ids -- @@ -519,4 +570,3 @@ pprBlockId b = ppr $ getUnique b commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs -