default ppr method for CmmGraph now tells more about the representation

(Previously, ppr had tried to make the zipper representation look as
much like the ListGraph representation as possible.  This decision was
unhelpful for debugging, so although the old code has been retained,
the new default is to tell it like it is.  It may be possible to
retire PprCmmZ one day, although it may be desirable to retain it as
the internal form becomes less readable.

diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs
index d333b05..c6eb4ae 100644 (file)
--- a/compiler/cmm/PprCmmZ.hs
+++ b/compiler/cmm/PprCmmZ.hs
@@ -1,6 +1,6 @@
 
 module PprCmmZ
-    ( pprCmmGraph
+    ( pprCmmGraphLikeCmm
     )
 where
 
@@ -12,21 +12,14 @@ import PprCmm()
 import Outputable
 import qualified ZipCfgCmm as G
 import qualified ZipCfg as Z
-import qualified ZipDataflow as DF
 import CmmZipUtil
 
 import UniqSet
 import FastString
 
 ----------------------------------------------------------------
-instance DF.DebugNodes G.Middle G.Last
-
-
-instance Outputable G.CmmGraph where
-    ppr = pprCmmGraph
-
-pprCmmGraph :: G.CmmGraph -> SDoc
-pprCmmGraph g = vcat (swallow blocks)
+pprCmmGraphLikeCmm :: G.CmmGraph -> SDoc
+pprCmmGraphLikeCmm g = vcat (swallow blocks)
     where blocks = Z.postorder_dfs g
           swallow :: [G.CmmBlock] -> [SDoc]
           swallow [] = []
@@ -109,3 +102,4 @@ pprCmmGraph g = vcat (swallow blocks)
               in  Z.fold_blocks add Z.emptyBlockSet g
           unique_pred id = Z.elemBlockSet id single_preds
 
+

diff --git a/compiler/cmm/ZipCfgCmm.hs b/compiler/cmm/ZipCfgCmm.hs
index 97a675c..2a68502 100644 (file)
--- a/compiler/cmm/ZipCfgCmm.hs
+++ b/compiler/cmm/ZipCfgCmm.hs
@@ -207,8 +207,18 @@ 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
 
@@ -252,6 +262,15 @@ 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
@@ -260,12 +279,25 @@ 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
     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 =