entryHeapCheck: fix calls to stg_gc_fun and stg_gc_enter_1

We weren't passing the arguments correctly to the GC functions, which
usually happened to work because the arguments were in the right
registers already.

After this fix the profiling tests go through with the new code
generator.

1 files changed, 26 insertions, 21 deletions

diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index b33ecdff12..12f3b1347e 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -328,14 +328,13 @@ These are used in the following circumstances
 -- A heap/stack check at a function or thunk entry point.
 
 entryHeapCheck :: ClosureInfo
-               -> Int            -- Arg Offset
                -> Maybe LocalReg -- Function (closure environment)
                -> Int            -- Arity -- not same as len args b/c of voids
                -> [LocalReg]     -- Non-void args (empty for thunk)
                -> FCode ()
                -> FCode ()
 
-entryHeapCheck cl_info offset nodeSet arity args code
+entryHeapCheck cl_info nodeSet arity args code
   = do dflags <- getDynFlags
        let is_thunk = arity == 0
            is_fastf = case closureFunInfo cl_info of
@@ -343,25 +342,31 @@ entryHeapCheck cl_info offset nodeSet arity args code
                            _otherwise         -> True
 
            args' = map (CmmReg . CmmLocal) args
-           setN = case nodeSet of
-                          Just _  -> mkNop -- No need to assign R1, it already
-                                           -- points to the closure
-                          Nothing -> mkAssign nodeReg $
-                              CmmLit (CmmLabel $ staticClosureLabel cl_info)
-
-           {- Thunks:          jump GCEnter1
-              Function (fast): Set R1 = node, jump GCFun
-              Function (slow): Set R1 = node, call generic_gc -}
-           gc_call upd = setN <*> gc_lbl upd
-           gc_lbl upd
-               | is_thunk  = mkDirectJump dflags (CmmReg $ CmmGlobal GCEnter1) [] sp
-               | is_fastf  = mkDirectJump dflags (CmmReg $ CmmGlobal GCFun) [] sp
-               | otherwise = mkForeignJump dflags Slow (CmmReg $ CmmGlobal GCFun) args' upd
-               where sp = max offset upd
-           {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
-            - This is since the ncg inserts spills before the stack/heap check.
-            - This should be fixed up and then we won't need to fix up the Sp on
-            - GC calls, but until then this fishy code works -}
+           node = case nodeSet of
+                      Just r  -> CmmReg (CmmLocal r)
+                      Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)
+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
+
+           {- Thunks:          jump stg_gc_enter_1
+
+              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.
+           -}
+           gc_call upd
+               | is_thunk
+                 = mkJump dflags stg_gc_enter1 [node] upd
+
+               | is_fastf
+                 = mkJump dflags stg_gc_fun (node : args') upd
+
+               | otherwise
+                 = mkAssign nodeReg node <*>
+                   mkForeignJump dflags Slow stg_gc_fun args' upd
 
        updfr_sz <- getUpdFrameOff