X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=5f5ae553ebf202364ef769328d7e35c46464a08b;hb=75879a1e1a0a22d3a7218efd71017af724262704;hp=72fde55a493ebaac0e956146181df852bd00efa3;hpb=bb66ce578f2ef5cbeb35de9719f0839a32fbeb35;p=ghc-hetmet.git

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 72fde55..5f5ae55 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/Commentary/CodingStyle#Warnings
+-- for details
+
 ----------------------------------------------------------------------------
 --
 -- Pretty-printing of Cmm as (a superset of) C--
@@ -32,13 +39,15 @@
 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
 --
 
-module PprCmm ( 	
-	writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
-  ) where
+module PprCmm
+    ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
+    )
+where
 
 #include "HsVersions.h"
 
 import Cmm
+import CmmExpr
 import CmmUtils
 import MachOp
 import CLabel
@@ -52,7 +61,7 @@ import Data.List
 import System.IO
 import Data.Maybe
 
-pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
+pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
         where
           separator = space $$ ptext SLIT("-------------------") $$ space
@@ -62,13 +71,18 @@ writeCmms handle cmms = printForC handle (pprCmms cmms)
 
 -----------------------------------------------------------------------------
 
-instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
+instance (Outputable info, Outputable g)
+    => Outputable (GenCmm CmmStatic info g) 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 (ListGraph instr) where
+    ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance (Outputable instr) => Outputable (GenBasicBlock instr) where
     ppr b = pprBBlock b
 
 instance Outputable CmmStmt where
@@ -92,20 +106,24 @@ instance Outputable CmmStatic where
 instance Outputable CmmInfo where
     ppr e = pprInfo e
 
+
+
 -----------------------------------------------------------------------------
 
-pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
+pprCmm :: (Outputable info,  Outputable g) => GenCmm CmmStatic info g -> SDoc
 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 
 -- --------------------------------------------------------------------------
 -- Top level `procedure' blocks.
 --
-pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
-pprTop (CmmProc info lbl params blocks )
+pprTop 	:: (Outputable d, Outputable info, Outputable i)
+	=> GenCmmTop d info i -> SDoc
+
+pprTop (CmmProc info lbl params graph )
 
   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
          , nest 8 $ lbrace <+> ppr info $$ rbrace
-         , nest 4 $ vcat (map ppr blocks)
+         , nest 4 $ ppr graph
          , rbrace ]
 
 -- --------------------------------------------------------------------------
@@ -114,7 +132,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
 
 -- --------------------------------------------------------------------------
@@ -186,7 +204,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))
 
@@ -217,7 +235,7 @@ pprStmt stmt = case stmt of
                   then empty
                   else parens (commafy $ map ppr results) <>
                        ptext SLIT(" = "),
-               ptext SLIT("call"), space, 
+               ptext SLIT("foreign"), space, 
                doubleQuotes(ppr cconv), space,
                target fn, parens  ( commafy $ map ppr args ),
                brackets (ppr safety), 
@@ -277,9 +295,15 @@ genJump expr args =
                     CmmLoad (CmmReg _) _ -> pprExpr expr 
                     _ -> parens (pprExpr expr)
          , space
-         , parens  ( commafy $ map ppr args )
+         , parens  ( commafy $ map pprHinted args )
          , semi ]
 
+pprHinted :: Outputable a => (a, MachHint) -> SDoc
+pprHinted (a, NoHint)     = ppr a
+pprHinted (a, PtrHint)    = quotes(text "address") <+> ppr a
+pprHinted (a, SignedHint) = quotes(text "signed")  <+> ppr a
+pprHinted (a, FloatHint)  = quotes(text "float")   <+> ppr a
+
 -- --------------------------------------------------------------------------
 -- Return from a function. [1], Section 6.8.2 of version 1.128
 --
@@ -494,10 +518,10 @@ pprReg r
 pprLocalReg :: LocalReg -> SDoc
 pprLocalReg (LocalReg uniq rep follow) 
     = hcat [ char '_', ppr uniq, ty ] where
-  ty = if rep == wordRep && follow == KindNonPtr
+  ty = if rep == wordRep && follow == GCKindNonPtr
                 then empty
                 else dcolon <> ptr <> ppr rep
-  ptr = if follow == KindNonPtr
+  ptr = if follow == GCKindNonPtr
                 then empty
                 else doubleQuotes (text "ptr")
 
@@ -530,6 +554,7 @@ pprSection s = case s of
     Text              -> section <+> doubleQuotes (ptext SLIT("text"))
     Data              -> section <+> doubleQuotes (ptext SLIT("data"))
     ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
+    ReadOnlyData16    -> section <+> doubleQuotes (ptext SLIT("readonly16"))
     RelocatableReadOnlyData
                       -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
     UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))