X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=470b325a6485ac7a0a08e29ef23de2bb510cb30d;hb=b822c1e46cd64d1dba23fbab0f775b731bf0f12b;hp=2d3fd6a7465bd3a9e96f6e8f85330de9d8826f5b;hpb=1c5499d4d5d506ce0cc971e98c09bfbf7bc290a1;p=ghc-hetmet.git diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 2d3fd6a..470b325 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,15 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- -module PprCmm ( - writeCmms, pprCmms, pprCmm, pprStmt, pprExpr - ) where +module PprCmm + ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic, pprLit + ) +where #include "HsVersions.h" import Cmm +import CmmExpr import CmmUtils import MachOp import CLabel @@ -52,7 +61,7 @@ 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 @@ -62,13 +71,18 @@ writeCmms handle cmms = printForC handle (pprCmms cmms) ----------------------------------------------------------------------------- -instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where +instance (Outputable info, Outputable g) + => Outputable (GenCmm CmmStatic 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 +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, Outputable g) => GenCmm CmmStatic 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,7 +132,7 @@ 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 -- -------------------------------------------------------------------------- @@ -186,7 +204,7 @@ pprUpdateFrame (UpdateFrame expr 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)) @@ -212,22 +230,25 @@ pprStmt stmt = case stmt of -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile - CmmCall (CmmCallee fn cconv) results args safety -> + 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("foreign"), space, doubleQuotes(ppr cconv), space, target fn, parens ( commafy $ map ppr args ), - brackets (ppr safety), 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 safety -> + CmmCall (CmmPrim op) results args safety ret -> pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) - results args safety) + results args safety ret) where lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) @@ -274,9 +295,15 @@ 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 => (a, MachHint) -> SDoc +pprHinted (a, NoHint) = ppr a +pprHinted (a, PtrHint) = quotes(text "address") <+> ppr a +pprHinted (a, SignedHint) = quotes(text "signed") <+> ppr a +pprHinted (a, FloatHint) = quotes(text "float") <+> ppr a + -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 -- @@ -491,10 +518,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") @@ -527,6 +554,7 @@ pprSection s = case s of 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")) @@ -544,4 +572,3 @@ pprBlockId b = ppr $ getUnique b commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs -