default ppr method for CmmGraph now tells more about the representation

[ghc-hetmet.git] / compiler / cmm / ZipCfgCmm.hs

diff --git a/compiler/cmm/ZipCfgCmm.hs b/compiler/cmm/ZipCfgCmm.hs
index d496626..2a68502 100644 (file)
--- a/compiler/cmm/ZipCfgCmm.hs
+++ b/compiler/cmm/ZipCfgCmm.hs
@@ -13,7 +13,7 @@ where
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
            , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
-           , CmmStmt(CmmJump, CmmSwitch, CmmReturn) -- imported in order to call ppr
+           , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
            )
 import PprCmm()
 
@@ -21,12 +21,15 @@ import CLabel
 import ClosureInfo
 import FastString
 import ForeignCall
+import MachOp
+import qualified ZipDataflow as DF
+import ZipCfg 
+import MkZipCfg
+
 import Maybes
 import Outputable hiding (empty)
 import qualified Outputable as PP
 import Prelude hiding (zip, unzip, last)
-import ZipCfg 
-import MkZipCfg
 
 type CmmGraph  = LGraph Middle Last
 type CmmAGraph = AGraph Middle Last
@@ -204,20 +207,30 @@ instance Outputable Last where
 instance Outputable Convention where
     ppr = pprConvention
 
+instance DF.DebugNodes Middle Last
+
+instance Outputable CmmGraph where
+    ppr = pprCmmGraphAsRep
+
+pprCmmGraphAsRep :: CmmGraph -> SDoc
+pprCmmGraphAsRep g = vcat (map ppr_block blocks)
+    where blocks = postorder_dfs g
+          ppr_block (Block id tail) = hang (ppr id <> colon) 4 (ppr tail)
+
 pprMiddle :: Middle -> SDoc    
-pprMiddle stmt = case stmt of
+pprMiddle stmt = (case stmt of
 
     MidNop -> semi
 
     CopyIn conv args _ ->
         if null args then ptext SLIT("empty CopyIn")
-        else commafy (map ppr args) <+> equals <+>
+        else commafy (map pprHinted args) <+> equals <+>
              ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
 
     CopyOut conv args ->
         if null args then PP.empty
         else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
-             parens (commafy (map ppr args))
+             parens (commafy (map pprHinted args))
 
     --  // text
     MidComment s -> text "//" <+> ftext s
@@ -249,32 +262,57 @@ pprMiddle stmt = case stmt of
         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
-
+  ) <+> text "//" <+>
+  case stmt of
+    MidNop {} -> text "MidNop"
+    CopyIn {} -> text "CopyIn"
+    CopyOut {} -> text "CopyOut"
+    MidComment {} -> text "MidComment"
+    MidAssign {} -> text "MidAssign"
+    MidStore {} -> text "MidStore"
+    MidUnsafeCall {} -> text "MidUnsafeCall"
+
+
+pprHinted :: Outputable a => (a, MachHint) -> SDoc
+pprHinted (a, NoHint)     = ppr a
+pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
+pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
+pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 
 pprLast :: Last -> SDoc    
-pprLast stmt = case stmt of
-
+pprLast stmt = (case stmt of
     LastBranch ident args     -> genBranchWithArgs ident args
     LastCondBranch expr t f   -> genFullCondBranch expr t f
     LastJump expr params      -> ppr $ CmmJump expr params
-    LastReturn params         -> ppr $ CmmReturn params
+    LastReturn results        -> hcat [ ptext SLIT("return"), space
+                                      , parens ( commafy $ map pprHinted results )
+                                      , semi ]
     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
     LastCall tgt params k     -> genCall tgt params k
+  ) <+> text "//" <+>
+  case stmt of
+    LastBranch {} -> text "LastBranch"
+    LastCondBranch {} -> text "LastCondBranch"
+    LastJump {} -> text "LastJump"
+    LastReturn {} -> text "LastReturn"
+    LastSwitch {} -> text "LastSwitch"
+    LastCall {} -> text "LastCall"
+
 
 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
 genCall (CmmCallee fn cconv) args k =
-        hcat [ ptext SLIT("foreign"), space, 
-               doubleQuotes(ppr cconv), space,
-               target fn, parens  ( commafy $ map ppr args ),
-               case k of Nothing -> ptext SLIT("never returns")
-                         Just k -> ptext SLIT("returns to") <+> ppr k,
-               semi ]
+        hcat [ ptext SLIT("foreign"), space
+             , doubleQuotes(ppr cconv), space
+             , target fn, parens  ( commafy $ map pprHinted args ), space
+             , case k of Nothing -> ptext SLIT("never returns")
+                         Just k -> ptext SLIT("returns to") <+> ppr k
+             , semi ]
         where
             target t@(CmmLit _) = ppr t
             target fn'          = parens (ppr fn')
 
 genCall (CmmPrim op) args k =
-    hcat [ text "%", text (show op), parens  ( commafy $ map ppr args ),
+    hcat [ text "%", text (show op), parens  ( commafy $ map pprHinted args ),
            ptext SLIT("returns to"), space, ppr k,
            semi ]