X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfgCmm.hs;h=1d806508586dfc2caf194ef1741041bdd50afb57;hp=2600da2942597159a2befceaad0b961b14eae528;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=25628e2771424cae1b3366322e8ce6f8a85440f9 diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 2600da2..1d80650 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -13,28 +13,30 @@ module MkZipCfgCmm , (<*>), catAGraphs, mkLabel, mkBranch , emptyAGraph, withFreshLabel, withUnique, outOfLine , lgraphOfAGraph, graphOfAGraph, labelAGraph - , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle, Last, Convention(..) + , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph + , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..) ) where #include "HsVersions.h" +import BlockId import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds - , CmmKinded (..) + , CmmActuals, CmmFormals ) -import MachOp (MachHint(..)) +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 StackSlot import ClosureInfo import FastString import ForeignCall -import ZipCfg import MkZipCfg +import Panic +import ZipCfg type CmmGraph = LGraph Middle Last type CmmAGraph = AGraph Middle Last @@ -42,6 +44,8 @@ type CmmBlock = Block Middle Last type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph +data Transfer = Call | Jump | Ret deriving Eq + ---------- No-ops mkNop :: CmmAGraph mkComment :: FastString -> CmmAGraph @@ -54,17 +58,17 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph mkCall :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph -- Native C-- calling convention -mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph +mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph -- Never returns; like exit() or barf() ----------- Context manipulation ('return via') +---------- Context manipulation ("return via") mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph ---------- Control transfer mkJump :: CmmExpr -> CmmActuals -> CmmAGraph -mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph -mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph +mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph +mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph mkReturn :: CmmActuals -> CmmAGraph mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph @@ -73,7 +77,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,8 +91,8 @@ mkCmmIfThen e tbranch = withFreshLabel "end of if" $ \endif -> withFreshLabel "start of then" $ \tid -> mkCbranch e tid endif <*> - mkLabel tid <*> tbranch <*> mkBranch endif <*> - mkLabel endif + mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*> + mkLabel endif Nothing @@ -99,71 +103,89 @@ 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 + +-- 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 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals ---cmmArgConv :: Convention cmmResConv :: Convention ---cmmArgConv = ConventionStandard CmmCallConv Arguments -cmmResConv = ConventionStandard CmmCallConv Arguments - -copyIn :: Convention -> StackArea -> CmmFormals -> [Middle] -copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals - where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v) - (CmmReg $ CmmStack $ StackSlot area n) : ms) - -copyOut :: Convention -> StackArea -> CmmActuals -> [Middle] -copyOut _ area actuals = moveSP : reverse (snd $ foldl co (1, []) actuals) - where moveSP = MidAssign spReg $ CmmReg $ CmmStack $ outgoingSlot area - co (n, ms) v = (n+1, MidAssign (CmmStack $ StackSlot area n) - (kindlessCmm v) : ms) -mkEntry :: BlockId -> Convention -> CmmFormalsWithoutKinds -> [Middle] -mkEntry entryId conv formals = copyIn conv (mkStackArea entryId [] $ Just fs) fs - where fs = map (\f -> CmmKinded f NoHint) formals +cmmResConv = Native + +-- Return the number of bytes used for copying arguments, as well as the +-- instructions to copy the arguments. +copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, [Middle]) +copyIn _ isCall area formals = + foldr ci (init_offset, []) $ assignArgumentsPos isCall localRegType formals + where ci (reg, RegisterParam r) (n, ms) = + (n, MidAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms) + ci (reg, StackParam off) (n, ms) = + let ty = localRegType reg + off' = off + init_offset + in (max n off', + MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) : ms) + init_offset = widthInBytes wordWidth + +-- 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 -> (Int, [Middle]) +copyOut _ transfer area@(CallArea a) actuals = + foldr co (init_offset, []) args' + where args = assignArgumentsPos skip_node cmmExprType actuals + skip_node = transfer /= Ret + (setRA, init_offset) = + case a of Young id -> -- set RA if making a call + if transfer == Call then + ([(CmmLit (CmmLabel (infoTblLbl id)), + StackParam init_offset)], ra_width) + else ([], 0) + Old -> ([], ra_width) + ra_width = widthInBytes wordWidth + 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" + +mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph) +mkEntry _ conv formals = + let (off, copies) = copyIn conv False (CallArea Old) formals in + (off, mkMiddles copies) -- 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 :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> - CmmAGraph -lastWithArgs conv actuals formals toLast = - withFreshLabel "call successor" $ \k -> - let area = mkStackArea k actuals formals - in (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 -always :: a -> b -> a -always x _ = x - -mkJump e actuals = lastWithArgs cmmResConv actuals Nothing $ always $ LastJump e -mkReturn actuals = lastWithArgs cmmResConv actuals Nothing $ always LastReturn ---mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e) ---mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn - -mkFinalCall f conv actuals = - lastWithArgs (ConventionStandard conv Arguments) actuals Nothing - $ always $ LastCall f Nothing --mkFinalCall f conv actuals = --- mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*> --- mkLast (LastCall f Nothing) --- + +lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> (Int -> Last) -> CmmAGraph +lastWithArgs transfer area conv actuals last = + let (outArgs, copies) = copyOut conv transfer area actuals in + mkMiddles copies <*> mkLast (last outArgs) + +-- The area created for the jump and return arguments is the same area as the +-- procedure entry. +mkJump e actuals = lastWithArgs Jump (CallArea Old) cmmResConv actuals $ LastJump e +mkReturn actuals = lastWithArgs Ret (CallArea Old) cmmResConv actuals $ LastJump e + where e = CmmStackSlot (CallArea Old) (widthInBytes wordWidth) + +mkFinalCall f _ actuals = + lastWithArgs Call (CallArea Old) Native actuals $ LastCall f Nothing mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt -- 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 conv results actuals srt = --- withFreshLabel "call successor" $ \k -> --- mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*> --- mkLast (LastCall f (Just k)) <*> --- mkLabel k <*> --- mkMiddle (CopyIn (ConventionStandard conv Results) results srt) +mkCall f _ results actuals _ = + withFreshLabel "call successor" $ \k -> + let area = CallArea $ Young k + (off, copyin) = copyIn Native False area results + copyout = lastWithArgs Call area Native actuals $ LastCall f (Just k) + in copyout <*> mkLabel k (Just off) <*> (mkMiddles copyin)