-- | 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
(_, 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 =
= 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]
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
-- 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)
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
-- 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
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)
-- 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
}
= 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
{-
projects / ghc-hetmet.git / commitdiff