X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfgCmm.hs;h=46f0659e1ae3d865e705aca96ccdbdefb3aaf6ce;hp=88adaaebf1fa52b877d5dec29819db7fdb8f91f7;hb=f1a90f54590e5a7a32a9c3ef2950740922b1f425;hpb=31a9d04804d9cacda35695c5397590516b964964 diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 88adaae..46f0659 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -59,15 +59,15 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph 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 @@ -131,9 +131,9 @@ mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r 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: @@ -145,31 +145,30 @@ 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) -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 @@ -207,7 +206,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 +214,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 @@ -243,28 +242,28 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> La 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 = +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)