X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfgCmm.hs;h=46f0659e1ae3d865e705aca96ccdbdefb3aaf6ce;hp=4b073e2abffbcf32e8925dfe4c53bb86fd1ff595;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 4b073e2..46f0659 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -8,14 +8,14 @@ module MkZipCfgCmm ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn - , mkReturnSimple, mkComment, copyIn, copyOut + , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo , (<*>), catAGraphs, mkLabel, mkBranch , emptyAGraph, withFreshLabel, withUnique, outOfLine , lgraphOfAGraph, graphOfAGraph, labelAGraph - , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph + , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..) - , emptyStackInfo, stackStubExpr, pprAGraph + , stackStubExpr, pprAGraph ) where @@ -36,14 +36,17 @@ import FastString import ForeignCall import MkZipCfg import Panic +import SMRep (ByteOff) import StaticFlags import ZipCfg type CmmGraph = LGraph Middle Last type CmmAGraph = AGraph Middle Last type CmmBlock = Block Middle Last -type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph -type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph +type CmmStackInfo = (ByteOff, Maybe ByteOff) + -- probably want a record; (SP offset on entry, update frame space) +type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph) +type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph) data Transfer = Call | Jump | Ret deriving Eq @@ -56,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 @@ -95,8 +98,8 @@ mkCmmIfThen e tbranch = withFreshLabel "end of if" $ \endif -> withFreshLabel "start of then" $ \tid -> mkCbranch e tid endif <*> - mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*> - mkLabel endif emptyStackInfo + mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel endif @@ -128,92 +131,139 @@ 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: stackStubExpr :: Width -> CmmExpr stackStubExpr w = CmmLit (CmmInt 0 w) +-- When we copy in parameters, we usually want to put overflow +-- parameters on the stack, but sometimes we want to pass +-- 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 -> Area -> CmmFormals -> (Int, CmmAGraph) +copyInSlot :: Convention -> CmmFormals -> CmmAGraph +copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> + (Int, [Middle]) +copyOutSlot :: Convention -> [LocalReg] -> [Middle] + -- why a list of middles here instead of an AGraph? + +copyInOflow = copyIn oneCopyOflowI +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 -> Area -> CmmFormals -> (ByteOff, CmmAGraph) + -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. -copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last) -copyIn conv isCall area formals = - foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals +copyIn :: CopyIn +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 (reg, StackParam off) (n, ms) = - let ty = localRegType reg - off' = off + init_offset - in (max n off', - mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms) - init_offset = widthInBytes wordWidth + ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) + init_offset = widthInBytes wordWidth -- infotable + 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 + +-- Copy-in one arg, using overflow space if needed. +oneCopyOflowI, oneCopySlotI :: SlotCopier +oneCopyOflowI area (reg, off) (n, ms) = + (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms) + where ty = localRegType reg + +-- Copy-in one arg, using spill slots if needed -- used for calling conventions at +-- a procpoint that is not a return point. The offset is irrelevant here... +oneCopySlotI _ (reg, _) (n, ms) = + (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms) + where ty = localRegType reg + w = widthInBytes (typeWidth ty) + + +-- Factoring out the common parts of the copyout functions yielded something +-- more complicated: -- The argument layout function ignores the pointer to the info table, so we slot that -- in here. When copying-out to a young area, we set the info table for return -- and adjust the offsets of the other parameters. -- If this is a call instruction, we adjust the offsets of the other parameters. -copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle]) -copyOut conv transfer area@(CallArea a) actuals updfr_off = +copyOutOflow conv transfer area@(CallArea a) actuals updfr_off = foldr co (init_offset, []) args' - where args = assignArgumentsPos conv skip_node cmmExprType actuals - skip_node = transfer /= Ret + where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms) + co (v, StackParam off) (n, ms) = + (max n off, MidStore (CmmStackSlot area off) v : ms) (setRA, init_offset) = case a of Young id@(BlockId _) -> -- set RA if making a call if transfer == Call then - ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width) + ([(CmmLit (CmmBlock id), StackParam init_offset)], + widthInBytes wordWidth) else ([], 0) Old -> ([], updfr_off) - ra_width = widthInBytes wordWidth + 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 - co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms) - co (v, StackParam off) (n, ms) = - (max n off, MidStore (CmmStackSlot area off) v : ms) -copyOut _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot" +copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot" + +-- Args passed only in registers and stack slots; no overflow space. +-- No return address may apply! +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 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 = copyIn conv False (CallArea Old) formals +mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset -> - (Int -> Last) -> CmmAGraph + (ByteOff -> Last) -> CmmAGraph lastWithArgs transfer area conv actuals updfr_off last = - let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in + let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in mkMiddles copies <*> mkLast (last outArgs) -- The area created for the jump and return arguments is the same area as the -- procedure entry. old :: Area old = CallArea Old -toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last -toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off) +toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last +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 + 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 + 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 + 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 + 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 + 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 + 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) = copyIn conv False area results - copyout = lastWithArgs Call area conv actuals updfr_off - (toCall f (Just k) updfr_off) - in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off)) - <*> copyin) + (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)