import FastString
import ForeignCall
import MkZipCfg
-import Outputable
import Panic
import SMRep (ByteOff)
import StaticFlags
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
---------- Calls
-mkCall :: CmmExpr -> Convention -> CmmFormals -> CmmActuals ->
+mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
UpdFrameOffset -> CmmAGraph
mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
UpdFrameOffset -> CmmAGraph
- -- Native C-- calling convention
-mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+ -- Native C-- calling convention
+mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
- -- Never returns; like exit() or barf()
+ -- Never returns; like exit() or barf()
---------- Control transfer
mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
mkSwitch e tbl = mkLast $ LastSwitch e tbl
-mkSafeCall t fs as upd =
+mkSafeCall t fs as upd interruptible =
withFreshLabel "safe call" $ \k ->
- mkMiddle $ MidForeignCall (Safe k upd) t fs as
+ mkMiddle $ MidForeignCall (Safe k upd interruptible) t fs as
mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
-- For debugging purposes, we can stub out dead stack slots:
-- 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)
-type CopyIn = SlotCopier -> Convention -> Bool -> Area -> CmmFormals ->
- (ByteOff, CmmAGraph)
+type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph)
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
copyIn :: CopyIn
-copyIn oflow conv isCall area formals =
+copyIn oflow conv area formals =
foldr ci (init_offset, mkNop) args'
where ci (reg, RegisterParam r) (n, ms) =
(n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
init_offset = widthInBytes wordWidth -- infotable
- args = assignArgumentsPos conv isCall localRegType formals
+ args = assignArgumentsPos conv localRegType formals
args' = foldl adjust [] args
where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
adjust rst x@(_, RegisterParam _) = x : rst
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
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 Native 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 =
lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
mkReturn e actuals updfr_off =
- lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off 0
+ lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
-- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
mkReturnSimple actuals updfr_off =
- lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off 0
+ lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
mkFinalCall f _ actuals updfr_off =
- lastWithArgs Call old Native 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 Native 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 conv results actuals updfr_off =
- pprTrace "mkCall" (ppr f <+> ppr actuals <+> ppr results <+> ppr conv) $
+mkCall f (callConv, retConv) results actuals updfr_off =
withFreshLabel "call successor" $ \k ->
let area = CallArea $ Young k
- (off, copyin) = copyInOflow conv False area results
- copyout = lastWithArgs Call area conv actuals updfr_off
+ (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)