added node to push a closure onto the current call context

compiler/cmm/CmmCvt.hs

@@ -85,8 +85,9 @@ ofZgraph g = ListGraph $ swallow blocks
           mid (MidAssign l r) = CmmAssign l r
           mid (MidStore  l r) = CmmStore  l r
           mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
-          mid m@(CopyOut {})  = pcomment (ppr m)
-          mid m@(CopyIn {})   = pcomment (ppr m <+> text "(proc point)")
+          mid m@(MidAddToContext {}) = pcomment (ppr m)
+          mid m@(CopyOut {})         = pcomment (ppr m)
+          mid m@(CopyIn {})          = pcomment (ppr m <+> text "(proc point)")
           pcomment p = scomment $ showSDoc p
           block' id prev'
               | id == G.lg_entry g = BasicBlock id $ extend_entry    (reverse prev')

compiler/cmm/CmmLiveZ.hs

@@ -60,6 +60,7 @@ middleLiveness m = middle m
         middle (MidAssign lhs expr)          = gen expr . kill lhs
         middle (MidStore addr rval)          = gen addr . gen rval
         middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
+        middle (MidAddToContext ra args)      = gen ra . gen args
         middle (CopyIn _ formals _)          = kill formals
         middle (CopyOut _ actuals)           = gen actuals
 

compiler/cmm/CmmSpillReload.hs

@@ -262,6 +262,7 @@ middleAvail (NotSpillOrReload m) = middle m
         middle (MidAssign lhs _expr)           = akill lhs
         middle (MidStore {})                   = id
         middle (MidUnsafeCall _tgt ress _args) = akill ress
+        middle (MidAddToContext {})             = id
         middle (CopyIn _ formals _)            = akill formals
         middle (CopyOut {})                    = id
 

compiler/cmm/MkZipCfgCmm.hs

@@ -8,7 +8,7 @@
 module MkZipCfgCmm
   ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
          , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
-         , mkCmmWhileDo
+         , mkCmmWhileDo, mkAddToContext
   , (<*>), sequence, mkLabel, mkBranch
   , emptyAGraph, withFreshLabel, withUnique, outOfLine
   , lgraphOfAGraph, graphOfAGraph, labelAGraph
@@ -55,6 +55,9 @@ mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
 mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
 		 -- Never returns; like exit() or barf()
 
+---------- Context manipulation ('return via')
+mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
+
 ---------- Control transfer
 mkJump       	:: CmmExpr -> CmmActuals -> CmmAGraph
 mkCbranch    	:: CmmExpr -> BlockId -> BlockId -> CmmAGraph
@@ -87,6 +90,7 @@ mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 
 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
+mkAddToContext ra actuals         = mkMiddle $ MidAddToContext ra actuals
 
 cmmArgConv, cmmResConv :: Convention
 cmmArgConv = ConventionStandard CmmCallConv Arguments

compiler/cmm/ZipCfgCmmRep.hs

@@ -55,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 
@@ -157,12 +165,13 @@ fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edge
 instance UserOfLocalRegs Middle where
     foldRegsUsed f z m = middle m
       where middle (MidComment {})                = z
-            middle (MidAssign _lhs expr)          = foldRegsUsed f z expr
-            middle (MidStore addr rval)           = foldRegsUsed f (foldRegsUsed f z addr) rval
-            middle (MidUnsafeCall tgt _ress args) = foldRegsUsed f (foldRegsUsed f z tgt) args
+            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)            = foldRegsUsed f z actuals
---            fold = foldRegsUsed
+            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
@@ -230,16 +239,18 @@ 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 " //" <+>
@@ -249,7 +260,13 @@ pprMiddle stmt = (case stmt of
          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