Fix the Slow calling convention (#7192)

The Slow calling convention passes the closure in R1, but we were
ignoring this and hoping it would work, which it often did.  However,
this bug seems to have been the cause of #7192, because the
graph-colouring allocator is more sensitive to having correct liveness
information on jumps.

7 files changed, 30 insertions, 49 deletions

diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 7fc89e2f54..7007872c0e 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -56,7 +56,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
                (_,   NativeReturn)     -> getRegsWithNode dflags
                -- GC calling convention *must* put values in registers
                (_,   GC)               -> allRegs dflags
-               (_,   Slow)             -> noRegs
+               (_,   Slow)             -> nodeOnly
       -- The calling conventions first assign arguments to registers,
       -- then switch to the stack when we first run out of registers
       -- (even if there are still available registers for args of a
@@ -172,8 +172,8 @@ allRegs dflags = (allVanillaRegs dflags,
                   allLongRegs dflags,
                   allSseRegs dflags)
 
-noRegs :: AvailRegs
-noRegs  = ([], [], [], [], [])
+nodeOnly :: AvailRegs
+nodeOnly = ([VanillaReg 1], [], [], [], [])
 
 globalArgRegs :: DynFlags -> [GlobalReg]
 globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index dfa44ca274..dff62e2fa7 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1086,7 +1086,7 @@ doJumpWithStack expr_code stk_code args_code = do
   stk_args <- sequence stk_code
   args <- sequence args_code
   updfr_off <- getUpdFrameOff
-  emit (mkJumpExtra dflags expr args updfr_off stk_args)
+  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
 
 doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
        -> CmmParse ()
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 7971b1de0f..bba3d4a88a 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -9,7 +9,7 @@ module MkGraph
   , stackStubExpr
   , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
   , mkJumpReturnsTo
-  , mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra
+  , mkJump, mkJumpExtra
   , mkRawJump
   , mkCbranch, mkSwitch
   , mkReturn, mkComment, mkCallEntry, mkBranch
@@ -188,10 +188,12 @@ mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 mkStore  l r  = mkMiddle $ CmmStore  l r
 
 ---------- Control transfer
-mkJump          :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+mkJump          :: DynFlags -> Convention -> CmmExpr
+                -> [CmmActual]
+                -> UpdFrameOffset
                 -> CmmAGraph
-mkJump dflags e actuals updfr_off =
-  lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
+mkJump dflags conv e actuals updfr_off =
+  lastWithArgs dflags Jump Old conv actuals updfr_off $
     toCall e Nothing updfr_off 0
 
 -- | A jump where the caller says what the live GlobalRegs are.  Used
@@ -203,28 +205,10 @@ mkRawJump dflags e updfr_off vols =
     \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols
 
 
-mkJumpExtra     :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-                -> [CmmActual] -> CmmAGraph
-mkJumpExtra dflags e actuals updfr_off extra_stack =
-  lastWithArgsAndExtraStack dflags Jump Old NativeNodeCall actuals updfr_off extra_stack $
-    toCall e Nothing updfr_off 0
-
-mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-                -> CmmAGraph
-mkDirectJump dflags e actuals updfr_off =
-  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
-    toCall e Nothing updfr_off 0
-
-mkForeignJump   :: DynFlags
-                -> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-                -> CmmAGraph
-mkForeignJump dflags conv e actuals updfr_off =
-  mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
-
-mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
+mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
                 -> UpdFrameOffset -> [CmmActual]
                 -> CmmAGraph
-mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
+mkJumpExtra dflags conv e actuals updfr_off extra_stack =
   lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
     toCall e Nothing updfr_off 0
 
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 439a2aa67e..60eeaa12db 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -450,7 +450,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
         ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
             \(_offset, node, arg_regs) -> do
                 -- Emit slow-entry code (for entering a closure through a PAP)
-                { mkSlowEntryCode cl_info arg_regs
+                { mkSlowEntryCode bndr cl_info arg_regs
 
                 ; dflags <- getDynFlags
                 ; let lf_info = closureLFInfo cl_info
@@ -494,21 +494,22 @@ load_fvs node lf_info = mapM_ (\ (reg, off) ->
 --
 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
 
-mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
+mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
 -- If this function doesn't have a specialised ArgDescr, we need
 -- to generate the function's arg bitmap and slow-entry code.
 -- Here, we emit the slow-entry code.
-mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
+mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
   | Just (_, ArgGen _) <- closureFunInfo cl_info
   = do dflags <- getDynFlags
-       let slow_lbl = closureSlowEntryLabel  cl_info
+       let node = idToReg dflags (NonVoid bndr)
+           slow_lbl = closureSlowEntryLabel  cl_info
            fast_lbl = closureLocalEntryLabel dflags cl_info
            -- mkDirectJump does not clobber `Node' containing function closure
-           jump = mkDirectJump dflags
-                               (mkLblExpr fast_lbl)
-                               (map (CmmReg . CmmLocal) arg_regs)
-                               (initUpdFrameOff dflags)
-       emitProcWithConvention Slow Nothing slow_lbl arg_regs jump
+           jump = mkJump dflags NativeNodeCall
+                                (mkLblExpr fast_lbl)
+                                (map (CmmReg . CmmLocal) (node : arg_regs))
+                                (initUpdFrameOff dflags)
+       emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) jump
   | otherwise = return ()
 
 -----------------------------------------
@@ -728,7 +729,7 @@ link_caf node _is_upd = do
         -- assuming lots of things, like the stack pointer hasn't
         -- moved since we entered the CAF.
        (let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) in
-        mkJump dflags target [] updfr)
+        mkJump dflags NativeNodeCall target [] updfr)
 
   ; return hp_rel }
 
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 9176cb330c..d7c015e689 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -685,8 +685,8 @@ emitEnter fun = do
       -- test, just generating an enter.
       Return _ -> do
         { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg
-        ; emit $ mkForeignJump dflags NativeNodeCall entry
-                    [cmmUntag dflags fun] updfr_off
+        ; emit $ mkJump dflags NativeNodeCall entry
+                        [cmmUntag dflags fun] updfr_off
         ; return AssignedDirectly
         }
 
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 7805473915..22007bf9fe 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -366,21 +366,17 @@ entryHeapCheck' is_fastf node arity args code
 
               Function (fast): call (NativeNode) stg_gc_fun(fun, args)
 
-              Function (slow): R1 = fun
-                               call (slow) stg_gc_fun(args)
-               XXX: this is a bit naughty, we should really pass R1 as an
-               argument and use a special calling convention.
+              Function (slow): call (slow) stg_gc_fun(fun, args)
            -}
            gc_call upd
                | is_thunk
-                 = mkJump dflags stg_gc_enter1 [node] upd
+                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd
 
                | is_fastf
-                 = mkJump dflags stg_gc_fun (node : args') upd
+                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd
 
                | otherwise
-                 = mkAssign nodeReg node <*>
-                   mkForeignJump dflags Slow stg_gc_fun args' upd
+                 = mkJump dflags Slow stg_gc_fun (node : args') upd
 
        updfr_sz <- getUpdFrameOff
 
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index bb0b8a78d0..3b4d954d8e 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -121,7 +121,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
 	; updfr_off <- getUpdFrameOff
         ; case sequel of
             Return _ -> do
-              emit $ mkForeignJumpExtra dflags callConv fun args updfr_off extra_stack
+              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack
               return AssignedDirectly
             AssignTo res_regs _ -> do
               k <- newLabelC