X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=7a1ffbbf299346fa6ec1f9776ffa9d90dca6d360;hp=5ce008dfc1f387d22a827e32f6c609b08a56b4bb;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=b44b0befe2b60cc9c4e4f8313bbb8b6207ad047c

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 5ce008d..7a1ffbb 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -1,3 +1,10 @@
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
 ----------------------------------------------------------------------------
 --
 -- Pretty-printing of Cmm as (a superset of) C--
@@ -33,7 +40,7 @@
 --
 
 module PprCmm ( 	
-	writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
+	writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
   ) where
 
 #include "HsVersions.h"
@@ -65,12 +72,16 @@ writeCmms handle cmms = printForC handle (pprCmms cmms)
 instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
     ppr c = pprCmm c
 
-instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where
+instance (Outputable d, Outputable info, Outputable i)
+	=> Outputable (GenCmmTop d info i) where
     ppr t = pprTop t
 
-instance Outputable CmmBasicBlock where
+instance (Outputable instr) => Outputable (GenBasicBlock instr) where
     ppr b = pprBBlock b
 
+instance Outputable BlockId where
+    ppr id = pprBlockId id
+
 instance Outputable CmmStmt where
     ppr s = pprStmt s
 
@@ -92,6 +103,8 @@ instance Outputable CmmStatic where
 instance Outputable CmmInfo where
     ppr e = pprInfo e
 
+
+
 -----------------------------------------------------------------------------
 
 pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
@@ -100,7 +113,9 @@ pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 -- --------------------------------------------------------------------------
 -- Top level `procedure' blocks.
 --
-pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
+pprTop 	:: (Outputable d, Outputable info, Outputable i)
+	=> GenCmmTop d info i -> SDoc
+
 pprTop (CmmProc info lbl params blocks )
 
   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
@@ -114,7 +129,7 @@ pprTop (CmmProc info lbl params blocks )
 --      section "data" { ... }
 --
 pprTop (CmmData section ds) = 
-    (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
+    (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
     $$ rbrace
 
 -- --------------------------------------------------------------------------
@@ -130,14 +145,14 @@ instance Outputable CmmSafety where
 -- style of C--'s 'stackdata' declaration, just inside the proc body,
 -- and were labelled with the procedure name ++ "_info".
 pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
-    vcat [ptext SLIT("gc_target: ") <>
-                maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+    vcat [{-ptext SLIT("gc_target: ") <>
+                maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
           ptext SLIT("update_frame: ") <>
                 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame]
 pprInfo (CmmInfo gc_target update_frame
          (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
-    vcat [ptext SLIT("gc_target: ") <>
-                maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+    vcat [{-ptext SLIT("gc_target: ") <>
+                maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
           ptext SLIT("update_frame: ") <>
                 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
           ptext SLIT("type: ") <> pprLit closure_type,
@@ -186,7 +201,7 @@ pprUpdateFrame (UpdateFrame expr args) =
 -- --------------------------------------------------------------------------
 -- Basic blocks look like assembly blocks.
 --      lbl: stmt ; stmt ; .. 
-pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
 pprBBlock (BasicBlock ident stmts) =
     hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
 
@@ -212,7 +227,7 @@ pprStmt stmt = case stmt of
 
     -- call "ccall" foo(x, y)[r1, r2];
     -- ToDo ppr volatile
-    CmmCall (CmmForeignCall fn cconv) results args safety ->
+    CmmCall (CmmCallee fn cconv) results args safety ret ->
         hcat [ if null results
                   then empty
                   else parens (commafy $ map ppr results) <>
@@ -220,14 +235,17 @@ pprStmt stmt = case stmt of
                ptext SLIT("call"), space, 
                doubleQuotes(ppr cconv), space,
                target fn, parens  ( commafy $ map ppr args ),
-               brackets (ppr safety), semi ]
+               brackets (ppr safety), 
+               case ret of CmmMayReturn -> empty
+                           CmmNeverReturns -> ptext SLIT(" never returns"),
+               semi ]
         where
             target (CmmLit lit) = pprLit lit
             target fn'          = parens (ppr fn')
 
-    CmmCall (CmmPrim op) results args safety ->
-        pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
-                        results args safety)
+    CmmCall (CmmPrim op) results args safety ret ->
+        pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
+                        results args safety ret)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)