prettyprint 'hinted' things in a more readable way

[ghc-hetmet.git] / compiler / cmm / ZipCfgCmm.hs

diff --git a/compiler/cmm/ZipCfgCmm.hs b/compiler/cmm/ZipCfgCmm.hs
index 367d952..97a675c 100644 (file)
--- a/compiler/cmm/ZipCfgCmm.hs
+++ b/compiler/cmm/ZipCfgCmm.hs
@@ -12,8 +12,8 @@ where
 
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
-           , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHintFormals
-           , CmmStmt(CmmJump, CmmSwitch, CmmReturn) -- imported in order to call ppr
+           , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
+           , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
            )
 import PprCmm()
 
@@ -21,12 +21,15 @@ import CLabel
 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 ZipCfg 
-import MkZipCfg
 
 type CmmGraph  = LGraph Middle Last
 type CmmAGraph = AGraph Middle Last
@@ -37,8 +40,8 @@ type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
 mkNop        :: CmmAGraph
 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
-mkCall       :: CmmCallTarget -> CmmHintFormals -> CmmActuals -> C_SRT -> CmmAGraph
-mkUnsafeCall :: CmmCallTarget -> CmmHintFormals -> CmmActuals -> CmmAGraph
+mkCall       :: CmmCallTarget -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
 mkFinalCall  :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns
 mkJump       :: CmmExpr -> CmmActuals -> CmmAGraph
 mkCbranch    :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
@@ -57,11 +60,11 @@ mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
 mkCmmWhileDo    e = mkWhileDo    (mkCbranch e)
 
-mkCopyIn     :: Convention -> CmmHintFormals -> C_SRT -> CmmAGraph
-mkCopyOut    :: Convention -> CmmHintFormals -> CmmAGraph
+mkCopyIn     :: Convention -> CmmFormals -> C_SRT -> CmmAGraph
+mkCopyOut    :: Convention -> CmmFormals -> CmmAGraph
 
   -- ^ XXX: Simon or Simon thinks maybe the hints are being abused and
-  -- we should have CmmFormals here, but for now it is CmmHintFormals
+  -- we should have CmmFormalsWithoutKinds here, but for now it is CmmFormals
   -- for consistency with the rest of the back end ---NR
 
 mkComment fs = mkMiddle (MidComment fs)
@@ -77,15 +80,15 @@ data Middle
 
   | MidUnsafeCall                -- An "unsafe" foreign call;
      CmmCallTarget               -- just a fat machine instructoin
-     CmmHintFormals              -- zero or more results
+     CmmFormals              -- zero or more results
      CmmActuals                  -- zero or more arguments
 
   | CopyIn    -- Move parameters or results from conventional locations to registers
               -- Note [CopyIn invariant]
         Convention 
-        CmmHintFormals      
+        CmmFormals      
         C_SRT           -- Static things kept alive by this block
-  | CopyOut Convention CmmHintFormals 
+  | CopyOut Convention CmmFormals 
 
 data Last
   = LastReturn CmmActuals          -- Return from a function,
@@ -94,7 +97,7 @@ data Last
   | LastJump   CmmExpr CmmActuals
         -- Tail call to another procedure
 
-  | LastBranch BlockId CmmFormals
+  | LastBranch BlockId CmmFormalsWithoutKinds
         -- To another block in the same procedure
         -- The parameters are unused at present.
 
@@ -211,13 +214,13 @@ pprMiddle stmt = case stmt of
 
     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) <+>
-             parens (commafy (map ppr args))
+             parens (commafy (map pprHinted args))
 
     --  // text
     MidComment s -> text "//" <+> ftext s
@@ -251,8 +254,11 @@ pprMiddle stmt = case stmt of
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 
 
-pprLast :: Last -> SDoc    
-pprLast stmt = case stmt of
+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
 
     LastBranch ident args     -> genBranchWithArgs ident args
     LastCondBranch expr t f   -> genFullCondBranch expr t f
@@ -263,18 +269,18 @@ pprLast stmt = case stmt of
 
 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 =
-    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 ]