Code simplifications due to call/return separation; some improvements to how node argument is managed

5 files changed, 35 insertions, 68 deletions

diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 7b3dd0d83f..990e178c30 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -46,13 +46,9 @@ assignArguments f reps = assignments
 -- | JD: For the new stack story, I want arguments passed on the stack to manifest as
 -- positive offsets in a CallArea, not negative offsets from the stack pointer.
 -- Also, I want byte offsets, not word offsets.
--- The first argument tells us whether we are assigning positions for call arguments
--- or return results. The distinction matters because some conventions use different
--- global registers in each case. In particular, the native calling convention
--- uses the `node' register to pass the closure environment.
-assignArgumentsPos :: (Outputable a) => Convention -> Bool -> (a -> CmmType) -> [a] ->
+assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] ->
                       ArgumentFormat a ByteOff
-assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
+assignArgumentsPos conv arg_ty reps = map cvt assignments
     where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
       regs = case (reps, conv) of
                (_,   NativeNodeCall)   -> getRegsWithNode
@@ -65,34 +61,6 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
                (_,   PrimOpReturn)     -> getRegsWithNode
                (_,   Slow)             -> noRegs
                _ -> pprPanic "Unknown calling convention" (ppr conv)
-      -- regs = if isCall then
-      --          case (reps, conv) of
-      --            (_, NativeNodeCall)   -> getRegsWithNode
-      --            (_, NativeDirectCall) -> getRegsWithoutNode
-      --            (_, GC    ) -> getRegsWithNode
-      --            (_, PrimOpCall) -> allRegs
-      --            (_, Slow  ) -> noRegs
-      --            _ -> pprPanic "Unknown calling convention" (ppr conv)
-      --        else
-      --          case (reps, conv) of
-      --            (_,   NativeNodeCall)   -> getRegsWithNode
-      --            (_,   NativeDirectCall) -> getRegsWithoutNode
-      --            ([_], NativeReturn)     -> allRegs
-      --            (_,   NativeReturn)     -> getRegsWithNode
-      --            (_,   GC)               -> getRegsWithNode
-      --            ([_], PrimOpReturn)     -> allRegs
-      --            (_,   PrimOpReturn)     -> getRegsWithNode
-      --            (_,   Slow)             -> noRegs
-      --            _ -> pprPanic "Unknown calling convention" (ppr conv)
-           --       (_, NativeCall) -> getRegsWithoutNode
-           --       (_, GC    ) -> getRegsWithNode
-           --       (_, PrimOpCall) -> allRegs
-           --       (_, Slow  ) -> noRegs
-           --       _ -> panic "Unknown calling convention"
-           --   else
-           --     case (reps, conv) of
-           --       ([_], _)    -> allRegs
-           --       (_, NativeCall)   -> getRegsWithNode
       (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
       assignArguments' [] _ _ = []
       assignArguments' (r:rs) offset avails =
diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 5ec65c5d0b..60d6ce1590 100644
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -329,7 +329,7 @@ add_CopyIns callPPs protos blocks =
            = case lookupBlockEnv protos id of
                Just (Protocol c fs _area) ->
                  do LGraph _ blocks <-
-                      lgraphOfAGraph (mkLabel id <*> copyInSlot c False fs <*> mkZTail t)
+                      lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t)
                     return (map snd $ blockEnvToList blocks)
                Nothing -> return [b]
            | otherwise = return [b]
@@ -356,8 +356,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
                     if elemBlockSet succId procPoints then
                       case lookupBlockEnv protos succId of
                         Nothing -> z
-                        Just (Protocol c fs _area) ->
-                          insert z succId $ copyOutSlot c Jump fs
+                        Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
                     else z
                   insert z succId m =
                     do (b, bmap) <- z
diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 4b2c0225f8..4eabffb208 100644
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -146,15 +146,15 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
 -- the variables in their spill slots.
 -- Therefore, for copying arguments and results, we provide different
 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
-copyInOflow  :: Convention -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph)
-copyInSlot   :: Convention -> Bool -> CmmFormals -> CmmAGraph
+copyInOflow  :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
+copyInSlot   :: Convention -> CmmFormals -> CmmAGraph
 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
                               (Int, [Middle])
-copyOutSlot  :: Convention -> Transfer -> [LocalReg] -> [Middle]
+copyOutSlot  :: Convention -> [LocalReg] -> [Middle]
   -- why a list of middles here instead of an AGraph?
 
 copyInOflow      = copyIn oneCopyOflowI
-copyInSlot c i f = snd $ copyIn oneCopySlotI c i (panic "no area for copying to slots") f
+copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
 
 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
                           (ByteOff, CmmAGraph)
@@ -207,7 +207,7 @@ copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
                          widthInBytes wordWidth)
                       else ([], 0)
                     Old -> ([], updfr_off)
-        args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals
+        args = assignArgumentsPos conv cmmExprType actuals
         args' = foldl adjust setRA args
           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                 adjust rst x@(_, RegisterParam _) = x : rst
@@ -215,19 +215,19 @@ copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register
 
 -- Args passed only in registers and stack slots; no overflow space.
 -- No return address may apply!
-copyOutSlot conv transfer actuals = foldr co [] args
+copyOutSlot conv actuals = foldr co [] args
   where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
         co (v, StackParam off)  ms =
           MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
         toExp r = CmmReg (CmmLocal r)
-        args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals
+        args = assignArgumentsPos conv localRegType actuals
 
 -- oneCopySlotO _ (reg, _) (n, ms) =
 --   (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
 --   where w = widthInBytes (typeWidth (localRegType reg))
 
 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
-mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals
+mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals
 
 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
                 (ByteOff -> Last) -> CmmAGraph
@@ -266,7 +266,7 @@ mkCall f (callConv, retConv) results actuals updfr_off =
                     ppr retConv) $
   withFreshLabel "call successor" $ \k ->
     let area = CallArea $ Young k
-        (off, copyin) = copyInOflow retConv False area results
+        (off, copyin) = copyInOflow retConv area results
         copyout = lastWithArgs Call area callConv actuals updfr_off 
                                (toCall f (Just k) updfr_off off)
     in (copyout <*> mkLabel k <*> copyin)
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index f098f3f733..5decdebd7e 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -393,21 +393,22 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 
 	-- Emit the main entry code
         ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
-    	        -- Emit the slow-entry code (for entering a closure through a PAP)
-	        { mkSlowEntryCode cl_info arg_regs
-
-		; let lf_info = closureLFInfo cl_info
-		      node_points = nodeMustPointToIt lf_info
-		; tickyEnterFun cl_info
-		; whenC node_points (ldvEnterClosure cl_info)
-		; granYield arg_regs node_points
-
-			-- Main payload
-		; entryHeapCheck node arity arg_regs $ do
-		{ enterCostCentre cl_info cc body
+                    -- Emit the slow-entry code (for entering a closure through a PAP)
+                { mkSlowEntryCode cl_info arg_regs
+
+                ; let lf_info = closureLFInfo cl_info
+                      node_points = nodeMustPointToIt lf_info
+                ; tickyEnterFun cl_info
+                ; whenC node_points (ldvEnterClosure cl_info)
+                ; granYield arg_regs node_points
+
+                        -- Main payload
+                ; entryHeapCheck node arity arg_regs $ do
+                { enterCostCentre cl_info cc body
                 ; fv_bindings <- mapM bind_fv fv_details
-		; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
-		; cgExpr body }}	    -- heap check, to reduce live vars over check
+                -- Load free vars out of closure *after*
+                ; if node_points then load_fvs node lf_info fv_bindings else return ()
+                ; cgExpr body }}	    -- heap check, to reduce live vars over check
 
   }
 
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 0e3501a720..ec6095313e 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -344,15 +344,14 @@ entryHeapCheck fun arity args code
   = do updfr_sz <- getUpdFrameOff
        heapCheck True (gc_call updfr_sz) code   -- The 'fun' keeps relevant CAFs alive
   where
-    fun_expr = CmmReg (CmmLocal fun)
-    -- JD: ugh... we should only do the following for dynamic closures
-    args' = fun_expr : map (CmmReg . CmmLocal) args
+    args'     = fun : args
+    arg_exprs = map (CmmReg . CmmLocal) args'
     gc_call updfr_sz
-	| arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) args' updfr_sz
-	| otherwise  = case gc_lbl (fun : args) of
-		 	 Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
-					      args' updfr_sz
-			 Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
+        | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
+        | otherwise  = case gc_lbl args' of
+                         Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+                                              arg_exprs updfr_sz
+                         Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
 
     gc_lbl :: [LocalReg] -> Maybe LitString
 {-