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
 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()
 
            )
 import PprCmm()
 

@@ -21,12 +21,15 @@ import CLabel
 import ClosureInfo
 import FastString
 import ForeignCall
 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 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
 
 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 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
 
     CopyIn conv args _ ->
         if null args then ptext SLIT("empty CopyIn")
 
     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) <+>
              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
 
     --  // 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)
         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 :: 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
     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 =

-        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 =
         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 ]
 
            ptext SLIT("returns to"), space, ppr k,
            semi ]