From e239aa2329416a2822fcc03c4ed486c7d28739e1 Mon Sep 17 00:00:00 2001 From: "dias@eecs.tufts.edu" Date: Mon, 23 Mar 2009 17:07:06 +0000 Subject: [PATCH] Small step toward call-conv improvement: separate out calls and returns --- compiler/cmm/CmmCallConv.hs | 14 ++++++++------ compiler/cmm/CmmCvt.hs | 4 ++-- compiler/cmm/MkZipCfgCmm.hs | 10 +++++----- compiler/cmm/ZipCfgCmmRep.hs | 22 ++++++++++++++-------- compiler/codeGen/StgCmmExpr.hs | 2 +- compiler/codeGen/StgCmmLayout.hs | 4 ++-- compiler/codeGen/StgCmmMonad.hs | 2 +- compiler/codeGen/StgCmmPrim.hs | 2 +- compiler/codeGen/StgCmmUtils.hs | 2 +- 9 files changed, 35 insertions(+), 27 deletions(-) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index b7e528b..7c70736 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -56,19 +56,21 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments where -- The calling conventions (CgCallConv.hs) are complicated, to say the least regs = if isCall then case (reps, conv) of - (_, Native) -> getRegsWithoutNode + (_, NativeCall) -> getRegsWithoutNode (_, GC ) -> getRegsWithNode - (_, PrimOp) -> allRegs + (_, PrimOpCall) -> allRegs (_, Slow ) -> noRegs - (_, _ ) -> getRegsWithoutNode + _ -> panic "Unknown calling convention" else case (reps, conv) of ([_], _) -> allRegs - (_, Native) -> getRegsWithNode + (_, NativeCall) -> getRegsWithNode + (_, NativeReturn) -> getRegsWithNode (_, GC ) -> getRegsWithNode - (_, PrimOp) -> getRegsWithNode + (_, PrimOpCall) -> getRegsWithNode + (_, PrimOpReturn) -> getRegsWithNode (_, Slow ) -> noRegs - (_, _ ) -> getRegsWithNode + _ -> pprPanic "Unknown calling convention" (ppr conv) (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs assignArguments' [] _ _ = [] assignArguments' (r:rs) offset avails = diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 09d5cd5..8869027 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -36,7 +36,7 @@ toZgraph _ _ (ListGraph []) = do g <- lgraphOfAGraph emptyAGraph return ((0, Nothing), g) toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = - let (offset, entry) = mkEntry id Native args in + let (offset, entry) = mkEntry id NativeCall args in do g <- labelAGraph id $ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks return ((offset, Nothing), g) @@ -94,7 +94,7 @@ get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints get_hints _other_conv _vd = repeat NoHint get_conv :: MidCallTarget -> Convention -get_conv (PrimTarget _) = Native +get_conv (PrimTarget _) = NativeCall get_conv (ForeignTarget _ fc) = Foreign fc cmm_target :: MidCallTarget -> CmmCallTarget diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index f28e327..29d8daf 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -244,22 +244,22 @@ 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 NativeCall 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 NativeCall actuals updfr_off $ toCall f Nothing updfr_off 0 -mkCmmCall f results actuals = mkCall f Native results actuals +mkCmmCall f results actuals = mkCall f NativeCall 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 = diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index a64a81d..715fd09 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -110,13 +110,17 @@ data MidCallTarget -- The target of a MidUnsafeCall deriving Eq data Convention - = Native -- Native C-- call/return + = NativeCall -- Native C-- call + + | NativeReturn -- Native C-- return | Slow -- Slow entry points: all args pushed on the stack | GC -- Entry to the garbage collector: uses the node reg! - | PrimOp -- Calling prim ops + | PrimOpCall -- Calling prim ops + + | PrimOpReturn -- Returning from prim ops | Foreign -- Foreign call/return ForeignConvention @@ -516,12 +520,14 @@ genFullCondBranch expr t f = ] pprConvention :: Convention -> SDoc -pprConvention (Native {}) = text "" -pprConvention Slow = text "" -pprConvention GC = text "" -pprConvention PrimOp = text "" -pprConvention (Foreign c) = ppr c -pprConvention (Private {}) = text "" +pprConvention (NativeCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" +pprConvention PrimOpCall = text "" +pprConvention PrimOpReturn = text "" +pprConvention (Foreign c) = ppr c +pprConvention (Private {}) = text "" pprForeignConvention :: ForeignConvention -> SDoc pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 32e43a7..462def3 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -465,7 +465,7 @@ cgTailCall fun_id fun_info args = do ; [ret,call] <- forkAlts [ getCode $ emitReturn [fun], -- Is tagged; no need to untag getCode $ do emit (mkAssign nodeReg fun) - emitCall Native (entryCode fun') []] -- Not tagged + emitCall NativeCall (entryCode fun') []] -- Not tagged ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) } SlowCall -> do -- A slow function call via the RTS apply routines diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index dbc97d4..c9f0324 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -161,13 +161,13 @@ direct_call caller lbl arity args reps <+> ppr args <+> ppr reps ) | null rest_reps -- Precisely the right number of arguments - = emitCall Native target args + = emitCall NativeCall target args | otherwise -- Over-saturated call = ASSERT( arity == length initial_reps ) do { pap_id <- newTemp gcWord ; withSequel (AssignTo [pap_id] True) - (emitCall Native target fast_args) + (emitCall NativeCall target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) rest_args rest_reps } where diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 1419773..fdaba95 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -607,7 +607,7 @@ emitProcWithConvention conv info lbl args blocks ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () -emitProc = emitProcWithConvention Native +emitProc = emitProcWithConvention NativeCall emitSimpleProc :: CLabel -> CmmAGraph -> FCode () emitSimpleProc lbl code = diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 8298b68..1d2f0db 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -82,7 +82,7 @@ cgOpApp (StgPrimOp primop) args res_ty | primOpOutOfLine primop = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - ; emitCall PrimOp fun cmm_args } + ; emitCall PrimOpCall fun cmm_args } | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index f49c266..9ef5862 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -314,7 +314,7 @@ emitRtsCall' res fun args _vols safe where call updfr_off = if safe then - mkCall fun_expr Native res' args' updfr_off + mkCall fun_expr NativeCall res' args' updfr_off else mkUnsafeCall (ForeignTarget fun_expr (ForeignConvention CCallConv arg_hints res_hints)) res' args' -- 1.7.10.4