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
 
 module PprCmmZ

-    ( pprCmmGraph
+    ( pprCmmGraphLikeCmm

     )
 where
 
     )
 where
 

@@ -12,21 +12,14 @@ import PprCmm()
 import Outputable
 import qualified ZipCfgCmm as G
 import qualified ZipCfg as Z
 import Outputable
 import qualified ZipCfgCmm as G
 import qualified ZipCfg as Z

-import qualified ZipDataflow as DF

 import CmmZipUtil
 
 import UniqSet
 import FastString
 
 ----------------------------------------------------------------
 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 [] = []
     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
 
               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 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 :: Middle -> SDoc    

-pprMiddle stmt = case stmt of
+pprMiddle stmt = (case stmt of

 
     MidNop -> semi
 
 
     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)
         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 :: 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
 
 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
     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
     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 =
 
 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
 genCall (CmmCallee fn cconv) args k =