Commit 617eb195 authored by dias@eecs.tufts.edu's avatar dias@eecs.tufts.edu
Browse files

Calls with and without passing node arguments more clearly separated

parent 5d1c70a5
...@@ -56,7 +56,8 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments ...@@ -56,7 +56,8 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
where -- The calling conventions (CgCallConv.hs) are complicated, to say the least where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs = if isCall then regs = if isCall then
case (reps, conv) of case (reps, conv) of
(_, NativeCall) -> getRegsWithoutNode (_, NativeNodeCall) -> getRegsWithNode
(_, NativeDirectCall) -> getRegsWithoutNode
(_, GC ) -> getRegsWithNode (_, GC ) -> getRegsWithNode
(_, PrimOpCall) -> allRegs (_, PrimOpCall) -> allRegs
(_, Slow ) -> noRegs (_, Slow ) -> noRegs
...@@ -64,12 +65,22 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments ...@@ -64,12 +65,22 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
else else
case (reps, conv) of case (reps, conv) of
([_], _) -> allRegs ([_], _) -> allRegs
(_, NativeCall) -> getRegsWithNode (_, NativeNodeCall) -> getRegsWithNode
(_, NativeDirectCall) -> getRegsWithoutNode
(_, NativeReturn) -> getRegsWithNode (_, NativeReturn) -> getRegsWithNode
(_, GC ) -> getRegsWithNode (_, GC ) -> getRegsWithNode
(_, PrimOpReturn) -> getRegsWithNode (_, PrimOpReturn) -> getRegsWithNode
(_, Slow ) -> noRegs (_, Slow ) -> noRegs
_ -> pprPanic "Unknown calling convention" (ppr conv) _ -> 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 (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
assignArguments' [] _ _ = [] assignArguments' [] _ _ = []
assignArguments' (r:rs) offset avails = assignArguments' (r:rs) offset avails =
......
...@@ -36,7 +36,7 @@ toZgraph _ _ (ListGraph []) = ...@@ -36,7 +36,7 @@ toZgraph _ _ (ListGraph []) =
do g <- lgraphOfAGraph emptyAGraph do g <- lgraphOfAGraph emptyAGraph
return ((0, Nothing), g) return ((0, Nothing), g)
toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
let (offset, entry) = mkEntry id NativeCall args in let (offset, entry) = mkEntry id NativeNodeCall args in
do g <- labelAGraph id $ do g <- labelAGraph id $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
return ((offset, Nothing), g) return ((offset, Nothing), g)
...@@ -94,7 +94,7 @@ get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints ...@@ -94,7 +94,7 @@ get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
get_hints _other_conv _vd = repeat NoHint get_hints _other_conv _vd = repeat NoHint
get_conv :: MidCallTarget -> Convention get_conv :: MidCallTarget -> Convention
get_conv (PrimTarget _) = NativeCall get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
get_conv (ForeignTarget _ fc) = Foreign fc get_conv (ForeignTarget _ fc) = Foreign fc
cmm_target :: MidCallTarget -> CmmCallTarget cmm_target :: MidCallTarget -> CmmCallTarget
......
...@@ -244,7 +244,7 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> La ...@@ -244,7 +244,7 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> La
toCall e cont updfr_off res_space arg_space = toCall e cont updfr_off res_space arg_space =
LastCall e cont arg_space res_space (Just updfr_off) LastCall e cont arg_space res_space (Just updfr_off)
mkJump e actuals updfr_off = mkJump e actuals updfr_off =
lastWithArgs Jump old NativeCall actuals updfr_off $ toCall e Nothing updfr_off 0 lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
mkJumpGC e actuals updfr_off = mkJumpGC e actuals updfr_off =
lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0 lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
mkForeignJump conv e actuals updfr_off = mkForeignJump conv e actuals updfr_off =
...@@ -257,9 +257,9 @@ mkReturnSimple actuals updfr_off = ...@@ -257,9 +257,9 @@ mkReturnSimple actuals updfr_off =
where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
mkFinalCall f _ actuals updfr_off = mkFinalCall f _ actuals updfr_off =
lastWithArgs Call old NativeCall actuals updfr_off $ toCall f Nothing updfr_off 0 lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
mkCmmCall f results actuals = mkCall f (NativeCall, NativeReturn) results actuals mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later. -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
mkCall f (callConv, retConv) results actuals updfr_off = mkCall f (callConv, retConv) results actuals updfr_off =
......
...@@ -110,7 +110,9 @@ data MidCallTarget -- The target of a MidUnsafeCall ...@@ -110,7 +110,9 @@ data MidCallTarget -- The target of a MidUnsafeCall
deriving Eq deriving Eq
data Convention data Convention
= NativeCall -- Native C-- call = NativeDirectCall -- Native C-- call skipping the node (closure) argument
| NativeNodeCall -- Native C-- call including the node argument
| NativeReturn -- Native C-- return | NativeReturn -- Native C-- return
...@@ -520,14 +522,15 @@ genFullCondBranch expr t f = ...@@ -520,14 +522,15 @@ genFullCondBranch expr t f =
] ]
pprConvention :: Convention -> SDoc pprConvention :: Convention -> SDoc
pprConvention (NativeCall {}) = text "<native-call-convention>" pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
pprConvention (NativeReturn {}) = text "<native-ret-convention>" pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
pprConvention Slow = text "<slow-convention>" pprConvention (NativeReturn {}) = text "<native-ret-convention>"
pprConvention GC = text "<gc-convention>" pprConvention Slow = text "<slow-convention>"
pprConvention PrimOpCall = text "<primop-call-convention>" pprConvention GC = text "<gc-convention>"
pprConvention PrimOpReturn = text "<primop-ret-convention>" pprConvention PrimOpCall = text "<primop-call-convention>"
pprConvention (Foreign c) = ppr c pprConvention PrimOpReturn = text "<primop-ret-convention>"
pprConvention (Private {}) = text "<private-convention>" pprConvention (Foreign c) = ppr c
pprConvention (Private {}) = text "<private-convention>"
pprForeignConvention :: ForeignConvention -> SDoc pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
......
...@@ -464,9 +464,9 @@ cgTailCall fun_id fun_info args = do ...@@ -464,9 +464,9 @@ cgTailCall fun_id fun_info args = do
do { let fun' = CmmLoad fun (cmmExprType fun) do { let fun' = CmmLoad fun (cmmExprType fun)
; [ret,call] <- forkAlts [ ; [ret,call] <- forkAlts [
getCode $ emitReturn [fun], -- Is tagged; no need to untag getCode $ emitReturn [fun], -- Is tagged; no need to untag
getCode $ do emit (mkAssign nodeReg fun) getCode $ do -- emit (mkAssign nodeReg fun)
emitCall (NativeCall, NativeReturn) emitCall (NativeNodeCall, NativeReturn)
(entryCode fun') []] -- Not tagged (entryCode fun') [fun]] -- Not tagged
; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) } ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
SlowCall -> do -- A slow function call via the RTS apply routines SlowCall -> do -- A slow function call via the RTS apply routines
......
...@@ -161,13 +161,13 @@ direct_call caller lbl arity args reps ...@@ -161,13 +161,13 @@ direct_call caller lbl arity args reps
<+> ppr args <+> ppr reps ) <+> ppr args <+> ppr reps )
| null rest_reps -- Precisely the right number of arguments | null rest_reps -- Precisely the right number of arguments
= emitCall (NativeCall, NativeReturn) target args = emitCall (NativeDirectCall, NativeReturn) target args
| otherwise -- Over-saturated call | otherwise -- Over-saturated call
= ASSERT( arity == length initial_reps ) = ASSERT( arity == length initial_reps )
do { pap_id <- newTemp gcWord do { pap_id <- newTemp gcWord
; withSequel (AssignTo [pap_id] True) ; withSequel (AssignTo [pap_id] True)
(emitCall (NativeCall, NativeReturn) target fast_args) (emitCall (NativeDirectCall, NativeReturn) target fast_args)
; slow_call (CmmReg (CmmLocal pap_id)) ; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps } rest_args rest_reps }
where where
......
...@@ -607,7 +607,7 @@ emitProcWithConvention conv info lbl args blocks ...@@ -607,7 +607,7 @@ emitProcWithConvention conv info lbl args blocks
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
emitProc = emitProcWithConvention NativeCall emitProc = emitProcWithConvention NativeNodeCall
emitSimpleProc :: CLabel -> CmmAGraph -> FCode () emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
emitSimpleProc lbl code = emitSimpleProc lbl code =
......
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