where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs = if isCall then
case (reps, conv) of
- (_, NativeCall) -> getRegsWithoutNode
+ (_, NativeNodeCall) -> getRegsWithNode
+ (_, NativeDirectCall) -> getRegsWithoutNode
(_, GC ) -> getRegsWithNode
(_, PrimOpCall) -> allRegs
(_, Slow ) -> noRegs
else
case (reps, conv) of
([_], _) -> allRegs
- (_, NativeCall) -> getRegsWithNode
+ (_, NativeNodeCall) -> getRegsWithNode
+ (_, NativeDirectCall) -> getRegsWithoutNode
(_, NativeReturn) -> getRegsWithNode
(_, GC ) -> getRegsWithNode
(_, 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 =
do g <- lgraphOfAGraph emptyAGraph
return ((0, Nothing), g)
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 $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
return ((offset, Nothing), g)
get_hints _other_conv _vd = repeat NoHint
get_conv :: MidCallTarget -> Convention
-get_conv (PrimTarget _) = NativeCall
+get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
get_conv (ForeignTarget _ fc) = Foreign fc
cmm_target :: MidCallTarget -> CmmCallTarget
toCall e cont updfr_off res_space arg_space =
LastCall e cont arg_space res_space (Just 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 =
lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
mkForeignJump conv e actuals updfr_off =
where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
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.
mkCall f (callConv, retConv) results actuals updfr_off =
deriving Eq
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
]
pprConvention :: Convention -> SDoc
-pprConvention (NativeCall {}) = text "<native-call-convention>"
-pprConvention (NativeReturn {}) = text "<native-ret-convention>"
-pprConvention Slow = text "<slow-convention>"
-pprConvention GC = text "<gc-convention>"
-pprConvention PrimOpCall = text "<primop-call-convention>"
-pprConvention PrimOpReturn = text "<primop-ret-convention>"
-pprConvention (Foreign c) = ppr c
-pprConvention (Private {}) = text "<private-convention>"
+pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
+pprConvention (NativeReturn {}) = text "<native-ret-convention>"
+pprConvention Slow = text "<slow-convention>"
+pprConvention GC = text "<gc-convention>"
+pprConvention PrimOpCall = text "<primop-call-convention>"
+pprConvention PrimOpReturn = text "<primop-ret-convention>"
+pprConvention (Foreign c) = ppr c
+pprConvention (Private {}) = text "<private-convention>"
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
do { let fun' = CmmLoad fun (cmmExprType fun)
; [ret,call] <- forkAlts [
getCode $ emitReturn [fun], -- Is tagged; no need to untag
- getCode $ do emit (mkAssign nodeReg fun)
- emitCall (NativeCall, NativeReturn)
- (entryCode fun') []] -- Not tagged
+ getCode $ do -- emit (mkAssign nodeReg fun)
+ emitCall (NativeNodeCall, NativeReturn)
+ (entryCode fun') [fun]] -- Not tagged
; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
SlowCall -> do -- A slow function call via the RTS apply routines
<+> ppr args <+> ppr reps )
| null rest_reps -- Precisely the right number of arguments
- = emitCall (NativeCall, NativeReturn) target args
+ = emitCall (NativeDirectCall, NativeReturn) target args
| otherwise -- Over-saturated call
= ASSERT( arity == length initial_reps )
do { pap_id <- newTemp gcWord
; withSequel (AssignTo [pap_id] True)
- (emitCall (NativeCall, NativeReturn) target fast_args)
+ (emitCall (NativeDirectCall, NativeReturn) target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps }
where
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
-emitProc = emitProcWithConvention NativeCall
+emitProc = emitProcWithConvention NativeNodeCall
emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
emitSimpleProc lbl code =