X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfgCmm.hs;h=2600da2942597159a2befceaad0b961b14eae528;hb=25628e2771424cae1b3366322e8ce6f8a85440f9;hp=6792559aeea80be52a6a8937dd06eb92924caa5b;hpb=c0a5a5d2e41341046aaf37c1d2155372e7ed3ee8;p=ghc-hetmet.git diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 6792559..2600da2 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -6,10 +6,11 @@ -- complain to Norman Ramsey. module MkZipCfgCmm - ( mkNop, mkAssign, mkStore, mkCall, mkUnsafeCall, mkFinalCall - , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse - , mkCmmWhileDo - , (<*>), mkLabel, mkBranch + ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall + , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry + , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo + , mkAddToContext + , (<*>), catAGraphs, mkLabel, mkBranch , emptyAGraph, withFreshLabel, withUnique, outOfLine , lgraphOfAGraph, graphOfAGraph, labelAGraph , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle, Last, Convention(..) @@ -20,11 +21,14 @@ where import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormals + , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds + , CmmKinded (..) ) +import MachOp (MachHint(..)) import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ) -- ^ to make this module more self-contained, these definitions are duplicated below import PprCmm() +import StackSlot import ClosureInfo import FastString @@ -38,47 +42,128 @@ type CmmBlock = Block Middle Last type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph +---------- No-ops mkNop :: CmmAGraph +mkComment :: FastString -> CmmAGraph + +---------- Assignment and store mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkStore :: CmmExpr -> CmmExpr -> CmmAGraph -mkCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> C_SRT -> 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 :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns -mkJump :: CmmExpr -> CmmActuals -> CmmAGraph -mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph -mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph -mkReturn :: CmmActuals -> CmmAGraph -mkComment :: FastString -> CmmAGraph +mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph + -- Never returns; like exit() or barf() + +---------- Context manipulation ('return via') +mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph + +---------- Control transfer +mkJump :: CmmExpr -> CmmActuals -> CmmAGraph +mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph +mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph +mkReturn :: CmmActuals -> CmmAGraph --- Not to be forgotten, but exported by MkZipCfg: ---mkBranch :: BlockId -> CmmAGraph ---mkLabel :: BlockId -> CmmAGraph mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph -mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph +mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph +mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph + +-- Not to be forgotten, but exported by MkZipCfg: +-- mkBranch :: BlockId -> CmmAGraph +-- mkLabel :: BlockId -> CmmAGraph +-- outOfLine :: CmmAGraph -> CmmAGraph +-- withUnique :: (Unique -> CmmAGraph) -> CmmAGraph +-- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph -------------------------------------------------------------------------- +mkCmmWhileDo e = mkWhileDo (mkCbranch e) mkCmmIfThenElse e = mkIfThenElse (mkCbranch e) -mkCmmWhileDo e = mkWhileDo (mkCbranch e) + +mkCmmIfThen e tbranch + = withFreshLabel "end of if" $ \endif -> + withFreshLabel "start of then" $ \tid -> + mkCbranch e tid endif <*> + mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel endif + -- ================ IMPLEMENTATION ================-- -mkNop = mkMiddle $ MidNop +mkNop = emptyAGraph mkComment fs = mkMiddle $ MidComment fs mkAssign l r = mkMiddle $ MidAssign l r mkStore l r = mkMiddle $ MidStore l r -mkJump e args = mkLast $ LastJump e args mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot -mkReturn actuals = mkLast $ LastReturn actuals mkSwitch e tbl = mkLast $ LastSwitch e tbl mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals -mkFinalCall tgt actuals = mkLast $ LastCall tgt actuals Nothing - -mkCall tgt results actuals srt = +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 + +-- 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 -> - mkLast (LastCall tgt actuals (Just k)) <*> - mkLabel k <*> - mkMiddle (CopyIn (Result CmmCallConv) results srt) + 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) +-- + +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)