From e8b6200f76059a091e6ae7a03821143819561727 Mon Sep 17 00:00:00 2001
From: Norman Ramsey <nr@eecs.harvard.edu>
Date: Tue, 11 Sep 2007 14:27:01 +0000
Subject: [PATCH] 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.

---
 compiler/cmm/PprCmmZ.hs   |   14 ++++----------
 compiler/cmm/ZipCfgCmm.hs |   36 ++++++++++++++++++++++++++++++++++--
 2 files changed, 38 insertions(+), 12 deletions(-)

diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs
index d333b05..c6eb4ae 100644
--- 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
--- 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 =
-- 
1.7.10.4