X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfgCmm.hs;h=46f0659e1ae3d865e705aca96ccdbdefb3aaf6ce;hp=e623c302be6e2f3700b122e64d5ee45742d49fab;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=0d80489c9b9f2421f65d8dd86c1e50c6bb429715 diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index e623c30..46f0659 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -6,14 +6,16 @@ -- complain to Norman Ramsey. module MkZipCfgCmm - ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall - , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry - , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo - , mkAddToContext + ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall + , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn + , 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, Middle, Last, Convention(..) + , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo + , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..) + , stackStubExpr, pprAGraph ) where @@ -22,25 +24,31 @@ where import BlockId import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds - , CmmKinded (..) + , CmmActuals, CmmFormals ) -import MachOp (MachHint(..), wordRep) +import CmmCallConv (assignArgumentsPos, ParamLocation(..)) import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ) - -- ^ to make this module more self-contained, these definitions are duplicated below + -- to make this module more self-contained, the above definitions are + -- duplicated below import PprCmm() -import ClosureInfo import FastString import ForeignCall -import ZipCfg 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 ---------- No-ops mkNop :: CmmAGraph @@ -51,21 +59,24 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkStore :: CmmExpr -> CmmExpr -> CmmAGraph ---------- Calls -mkCall :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph -mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph - -- Native C-- calling convention -mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph -mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph - -- Never returns; like exit() or barf() - ----------- Context manipulation ('return via') -mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph +mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals -> + UpdFrameOffset -> CmmAGraph +mkCmmCall :: CmmExpr -> 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() ---------- Control transfer -mkJump :: Area -> CmmExpr -> CmmActuals -> CmmAGraph -mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph -mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph -mkReturn :: Area -> CmmActuals -> CmmAGraph +mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph +mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph +mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph @@ -73,7 +84,7 @@ mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph -- Not to be forgotten, but exported by MkZipCfg: -- mkBranch :: BlockId -> CmmAGraph --- mkLabel :: BlockId -> CmmAGraph +-- mkLabel :: BlockId -> Maybe Int -> CmmAGraph -- outOfLine :: CmmAGraph -> CmmAGraph -- withUnique :: (Unique -> CmmAGraph) -> CmmAGraph -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph @@ -87,7 +98,7 @@ mkCmmIfThen e tbranch = withFreshLabel "end of if" $ \endif -> withFreshLabel "start of then" $ \tid -> mkCbranch e tid endif <*> - mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel tid <*> tbranch <*> mkBranch endif <*> mkLabel endif @@ -96,68 +107,163 @@ mkCmmIfThen e tbranch mkNop = emptyAGraph mkComment fs = mkMiddle $ MidComment fs -mkAssign l r = mkMiddle $ MidAssign l r mkStore l r = mkMiddle $ MidStore l r -mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot -mkSwitch e tbl = mkLast $ LastSwitch e tbl - -mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals -mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals - -cmmResConv :: Convention -cmmResConv = ConventionStandard CmmCallConv Results - -copyIn :: Convention -> Area -> CmmFormals -> [Middle] -copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals - where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v) - (CmmLoad (CmmStackSlot area n) wordRep) : ms) - -copyOut :: Convention -> Area -> CmmActuals -> [Middle] -copyOut conv area actuals = moveSP conv $ snd $ foldl co (1, []) actuals - where moveSP (ConventionStandard _ Arguments) args = - MidAssign spReg (outgoingSlot area) : reverse args - moveSP _ args = reverse $ MidAssign spReg (outgoingSlot area) : args - co (n, ms) v = (n+1, MidStore (CmmStackSlot area n) (kindlessCmm v) : ms) -mkEntry :: Area -> Convention -> CmmFormalsWithoutKinds -> [Middle] -mkEntry area conv formals = copyIn conv area fs - where fs = map (\f -> CmmKinded f NoHint) formals - --- I'm not sure how to get the calling conventions right yet, --- and I suspect this should not be resolved until sometime after --- Simon's patch is applied. --- For now, I apply a bogus calling convention: all arguments go on the --- stack, using the same amount of stack space. -lastWithArgs' :: BlockId -> Area -> Convention -> CmmActuals -> Maybe CmmFormals -> - (BlockId -> Last) -> CmmAGraph -lastWithArgs' k area conv actuals formals toLast = - (mkMiddles $ copyOut conv area actuals) <*> - -- adjust the sp - mkLast (toLast k) <*> - case formals of - Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals) - Nothing -> emptyAGraph -lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> CmmAGraph -lastWithArgs c a f l = - withFreshLabel "call successor" $ \k -> lastWithArgs' k (mkCallArea k a f) c a f l - -always :: a -> b -> a -always x _ = x +-- NEED A COMPILER-DEBUGGING FLAG HERE +-- Sanity check: any value assigned to a pointer must be non-zero. +-- If it's 0, cause a crash immediately. +mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r + where assign l r = mkMiddle (MidAssign l r) + check (CmmGlobal _) = mkNop + check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash! + if isGcPtrType ty then + mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w]) + (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty)) + else mkNop + where ty = localRegType reg + w = typeWidth ty + r = CmmReg l + + +-- Why are we inserting extra blocks that simply branch to the successors? +-- Because in addition to the branch instruction, @mkBranch@ will insert +-- a necessary adjustment to the stack pointer. +mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot) +mkSwitch e tbl = mkLast $ LastSwitch e tbl + +mkSafeCall t fs as upd interruptible = + withFreshLabel "safe call" $ \k -> + 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 :: 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 (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. +copyOutOflow conv transfer area@(CallArea a) actuals updfr_off = + foldr co (init_offset, []) args' + 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)], + widthInBytes wordWidth) + else ([], 0) + Old -> ([], updfr_off) + 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 +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 = copyInOflow conv (CallArea Old) formals + +lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset -> + (ByteOff -> Last) -> CmmAGraph +lastWithArgs transfer area conv actuals updfr_off last = + 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. -mkJump area e actuals = - lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always $ LastJump e -mkReturn area actuals = - lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always LastReturn +old :: Area +old = CallArea Old +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 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 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 NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 + where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord -mkFinalCall f conv actuals = - lastWithArgs (ConventionStandard conv Arguments) actuals Nothing - $ always $ LastCall f Nothing --mkFinalCall f conv actuals = +mkFinalCall f _ actuals updfr_off = + lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0 -mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt +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 _ = - lastWithArgs (ConventionStandard conv Arguments) actuals (Just results) - $ \k -> LastCall f (Just k) +mkCall f (callConv, retConv) results actuals updfr_off = + withFreshLabel "call successor" $ \k -> + let area = CallArea $ Young k + (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)