X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipCfgCmmRep.hs;h=8c1b46156ef10c7400e3e38a78c6e57fb65e1656;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=03fc759b3e9e9189df774614332b336d9036f42b;hpb=569348e87434f2a8d9e18dccac8b4a563b4eb363;p=ghc-hetmet.git

diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 03fc759..8c1b461 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -15,7 +15,7 @@ where
 
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
-           , CmmCallTarget(..), CmmActuals, CmmFormals
+           , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHinted(..)
            , CmmStmt(CmmSwitch) -- imported in order to call ppr
            )
 import PprCmm()
@@ -25,7 +25,7 @@ import ClosureInfo
 import FastString
 import ForeignCall
 import MachOp
-import qualified ZipDataflow as DF
+import qualified ZipDataflow0 as DF
 import ZipCfg 
 import MkZipCfg
 
@@ -43,8 +43,7 @@ type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
 
 data Middle
-  = MidNop
-  | MidComment FastString
+  = MidComment FastString
 
   | MidAssign CmmReg CmmExpr     -- Assign to register
 
@@ -56,6 +55,14 @@ data Middle
      CmmFormals                  -- zero or more results
      CmmActuals                  -- zero or more arguments
 
+  | MidAddToContext              -- push a frame on the stack;
+                                 -- I will return to this frame
+     CmmExpr                     -- The frame's return address; it must be
+                                 -- preceded by an info table that describes the
+                                 -- live variables.
+     [CmmExpr]                   -- The frame's live variables, to go on the 
+                                 -- stack with the first one at the young end
+
   | CopyIn    -- Move incoming parameters or results from conventional
               -- locations to registers.  Note [CopyIn invariant]
         Convention 
@@ -84,7 +91,7 @@ data Last
 
   | LastJump CmmExpr    -- Tail call to another procedure; args in a CopyOut node
 
-  | LastCall {                   -- A call (native or safe foreign)
+  | LastCall {                   -- A call (native or safe foreign); args in CopyOut node
         cml_target :: CmmExpr,   -- never a CmmPrim to a CallishMachOp!
         cml_cont   :: Maybe BlockId }  -- BlockId of continuation, if call returns
 
@@ -152,6 +159,29 @@ fold_cmm_succs _f (LastCall _ Nothing)     z = z
 fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
 fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
 
+----------------------------------------------------------------------
+----- Instance declarations for register use
+
+instance UserOfLocalRegs Middle where
+    foldRegsUsed f z m = middle m
+      where middle (MidComment {})                = z
+            middle (MidAssign _lhs expr)          = fold f z expr
+            middle (MidStore addr rval)           = fold f (fold f z addr) rval
+            middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
+            middle (MidAddToContext ra args)      = fold f (fold f z ra) args
+            middle (CopyIn _ _formals _)          = z
+            middle (CopyOut _ actuals)            = fold f z actuals
+            fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
+
+instance UserOfLocalRegs Last where
+    foldRegsUsed f z m = last m
+      where last (LastReturn)           = z
+            last (LastJump e)           = foldRegsUsed f z e
+            last (LastBranch _id)       = z
+            last (LastCall tgt _)       = foldRegsUsed f z tgt
+            last (LastCondBranch e _ _) = foldRegsUsed f z e
+            last (LastSwitch e _tbl)    = foldRegsUsed f z e
+
 
 ----------------------------------------------------------------------
 ----- Instance declarations for prettyprinting (avoids recursive imports)
@@ -167,17 +197,12 @@ instance Outputable Convention where
 
 instance DF.DebugNodes Middle Last
 
-instance Outputable CmmGraph where
-    ppr = pprLgraph
-
 debugPpr :: Bool
 debugPpr = debugIsOn
 
 pprMiddle :: Middle -> SDoc    
 pprMiddle stmt = (case stmt of
 
-    MidNop -> semi
-
     CopyIn conv args _ ->
         if null args then ptext SLIT("empty CopyIn")
         else commafy (map pprHinted args) <+> equals <+>
@@ -207,34 +232,41 @@ pprMiddle stmt = (case stmt of
                        ptext SLIT(" = "),
                ptext SLIT("call"), space, 
                doubleQuotes(ppr cconv), space,
-               target fn, parens  ( commafy $ map ppr args ),
+               ppr_target fn, parens  ( commafy $ map ppr args ),
                semi ]
-        where
-            target t@(CmmLit _) = ppr t
-            target fn'          = parens (ppr fn')
 
     MidUnsafeCall (CmmPrim op) results args ->
         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
+
+    MidAddToContext ra args ->
+        hcat [ ptext SLIT("return via ")
+             , ppr_target ra, parens (commafy $ map ppr args), semi ]
+
   ) <>
   if debugPpr then empty
   else 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"
+         MidUnsafeCall  {} -> text "MidUnsafeCall"
+         MidAddToContext {} -> text "MidAddToContext"
+
+
+ppr_target :: CmmExpr -> SDoc
+ppr_target t@(CmmLit _) = ppr t
+ppr_target fn'          = parens (ppr fn')
 
 
-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
+pprHinted :: Outputable a => CmmHinted a -> SDoc
+pprHinted (CmmHinted a NoHint)     = ppr a
+pprHinted (CmmHinted a PtrHint)    = doubleQuotes (text "address") <+> ppr a
+pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed")  <+> ppr a
+pprHinted (CmmHinted a FloatHint)  = doubleQuotes (text "float")   <+> ppr a
 
 pprLast :: Last -> SDoc    
 pprLast stmt = (case stmt of