From: dias@eecs.tufts.edu Date: Mon, 23 Mar 2009 17:47:00 +0000 (+0000) Subject: Calls with and without passing node arguments more clearly separated X-Git-Tag: 2009-06-25~401 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=617eb195e67525ffda967099fa8d9899e2b15ce8 Calls with and without passing node arguments more clearly separated --- diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index d40edae..7c67107 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -56,7 +56,8 @@ 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 - (_, NativeCall) -> getRegsWithoutNode + (_, NativeNodeCall) -> getRegsWithNode + (_, NativeDirectCall) -> getRegsWithoutNode (_, GC ) -> getRegsWithNode (_, PrimOpCall) -> allRegs (_, Slow ) -> noRegs @@ -64,12 +65,22 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments else case (reps, conv) of ([_], _) -> allRegs - (_, NativeCall) -> getRegsWithNode + (_, NativeNodeCall) -> getRegsWithNode + (_, NativeDirectCall) -> getRegsWithoutNode (_, NativeReturn) -> getRegsWithNode (_, GC ) -> getRegsWithNode (_, PrimOpReturn) -> getRegsWithNode (_, Slow ) -> noRegs _ -> pprPanic "Unknown calling convention" (ppr conv) + -- (_, NativeCall) -> getRegsWithoutNode + -- (_, GC ) -> getRegsWithNode + -- (_, PrimOpCall) -> allRegs + -- (_, Slow ) -> noRegs + -- _ -> panic "Unknown calling convention" + -- else + -- case (reps, conv) of + -- ([_], _) -> allRegs + -- (_, NativeCall) -> getRegsWithNode (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 4eedd55..9f8279e 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 NativeCall args in + let (offset, entry) = mkEntry id NativeNodeCall 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 _) = NativeCall +get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS get_conv (ForeignTarget _ fc) = Foreign fc cmm_target :: MidCallTarget -> CmmCallTarget diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 9786029..b47185b 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -244,7 +244,7 @@ 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 NativeCall actuals updfr_off $ toCall e Nothing updfr_off 0 + 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 = @@ -257,9 +257,9 @@ mkReturnSimple actuals updfr_off = where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord mkFinalCall f _ actuals updfr_off = - lastWithArgs Call old NativeCall actuals updfr_off $ toCall f Nothing updfr_off 0 + lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0 -mkCmmCall f results actuals = mkCall f (NativeCall, NativeReturn) 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 (callConv, retConv) results actuals updfr_off = diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 43f57a0..b08f2f3 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -110,7 +110,9 @@ data MidCallTarget -- The target of a MidUnsafeCall deriving Eq data Convention - = NativeCall -- Native C-- call + = NativeDirectCall -- Native C-- call skipping the node (closure) argument + + | NativeNodeCall -- Native C-- call including the node argument | NativeReturn -- Native C-- return @@ -520,14 +522,15 @@ genFullCondBranch expr t f = ] pprConvention :: Convention -> SDoc -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 "" +pprConvention (NativeNodeCall {}) = text "" +pprConvention (NativeDirectCall {}) = 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 f3687fc..065005c 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -464,9 +464,9 @@ cgTailCall fun_id fun_info args = do do { let fun' = CmmLoad fun (cmmExprType fun) ; [ret,call] <- forkAlts [ getCode $ emitReturn [fun], -- Is tagged; no need to untag - getCode $ do emit (mkAssign nodeReg fun) - emitCall (NativeCall, NativeReturn) - (entryCode fun') []] -- Not tagged + getCode $ do -- emit (mkAssign nodeReg fun) + emitCall (NativeNodeCall, NativeReturn) + (entryCode fun') [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 47df621..e306dd1 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 (NativeCall, NativeReturn) target args + = emitCall (NativeDirectCall, NativeReturn) target args | otherwise -- Over-saturated call = ASSERT( arity == length initial_reps ) do { pap_id <- newTemp gcWord ; withSequel (AssignTo [pap_id] True) - (emitCall (NativeCall, NativeReturn) target fast_args) + (emitCall (NativeDirectCall, NativeReturn) 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 fdaba95..550c42d 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 NativeCall +emitProc = emitProcWithConvention NativeNodeCall emitSimpleProc :: CLabel -> CmmAGraph -> FCode () emitSimpleProc lbl code =