Commit 5dd61c66 authored by dias@eecs.tufts.edu's avatar dias@eecs.tufts.edu
Browse files

Code simplifications due to call/return separation; some improvements to how...

Code simplifications due to call/return separation; some improvements to how node argument is managed
parent 8e9c95ac
......@@ -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 =
......
......@@ -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
......
......@@ -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)
......@@ -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
}
......
......@@ -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
{-
......
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