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

@@ -37,8 +40,8 @@ type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
 mkNop        :: CmmAGraph
 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 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
 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)
 
 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
 
   -- ^ 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)
   -- 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
 
   | 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 
      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
         C_SRT           -- Static things kept alive by this block

-  | CopyOut Convention CmmHintFormals 
+  | CopyOut Convention CmmFormals 

 
 data Last
   = LastReturn CmmActuals          -- Return from a function,
 
 data Last
   = LastReturn CmmActuals          -- Return from a function,

@@ -94,7 +97,7 @@ data Last
   | LastJump   CmmExpr CmmActuals
         -- Tail call to another procedure
 
   | 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.
 
         -- 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")
 
     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

@@ -251,8 +254,11 @@ pprMiddle stmt = case stmt of
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 
 
           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
 
     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 =
 
 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 ]