Commit babe3c60 authored by Simon Marlow's avatar Simon Marlow

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.
parent ef58afea
......@@ -435,7 +435,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
; granYield arg_regs node_points
-- Main payload
; entryHeapCheck cl_info offset node' arity arg_regs $ do
; entryHeapCheck cl_info node' arity arg_regs $ do
{ fv_bindings <- mapM bind_fv fv_details
-- Load free vars out of closure *after*
-- heap check, to reduce live vars over check
......@@ -493,7 +493,7 @@ thunkCode cl_info fv_details _cc node arity body
; granThunk node_points
-- Heap overflow check
; entryHeapCheck cl_info 0 node' arity [] $ do
; entryHeapCheck cl_info node' arity [] $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
; whenC (blackHoleOnEntry cl_info && node_points)
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment