X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgTailCall.lhs;h=89c050406f746f34fc105aca66d894fc3ac3fc67;hp=c65ec1c4b5d65a7f404369df262dd21552d79927;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=a2d78ebe0451484e20ad3dc4d7f662e8c1e9650e diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index c65ec1c..89c0504 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -8,10 +8,10 @@ module CgTailCall ( cgTailCall, performTailCall, performReturn, performPrimReturn, - emitKnownConReturnCode, emitAlgReturnCode, returnUnboxedTuple, ccallReturnUnboxedTuple, pushUnboxedTuple, tailCallPrimOp, + tailCallPrimCall, pushReturnAddress ) where @@ -33,11 +33,10 @@ import CmmUtils import CLabel import Type import Id -import DataCon import StgSyn -import TyCon import PrimOp import Outputable +import StaticFlags import Control.Monad @@ -105,33 +104,41 @@ performTailCall fun_info arg_amodes pending_assts | otherwise = do { fun_amode <- idInfoToAmode fun_info - ; let node_asst = oneStmt (CmmAssign nodeReg fun_amode) + ; let assignSt = CmmAssign nodeReg fun_amode + node_asst = oneStmt assignSt opt_node_asst | nodeMustPointToIt lf_info = node_asst | otherwise = noStmts ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - ; this_pkg <- getThisPackage - ; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of + ; dflags <- getDynFlags + ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of -- Node must always point to things we enter EnterIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) - ; doFinalJump sp False (stmtC (CmmJump target [])) } + ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) + enterClosure = stmtC (CmmJump target []) + -- If this is a scrutinee + -- let's check if the closure is a constructor + -- so we can directly jump to the alternatives switch + -- statement. + jumpInstr = getEndOfBlockInfo >>= + maybeSwitchOnCons enterClosure + ; doFinalJump sp False jumpInstr } -- A function, but we have zero arguments. It is already in WHNF, -- so we can just return it. -- As with any return, Node must point to it. ReturnIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False emitDirectReturnInstr } + ; doFinalJump sp False emitReturnInstr } -- A real constructor. Don't bother entering it, -- just do the right sort of return instead. -- As with any return, Node must point to it. - ReturnCon con -> do + ReturnCon _ -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False (emitKnownConReturnCode con) } + ; doFinalJump sp False emitReturnInstr } JumpToIt lbl -> do { emitSimultaneously (opt_node_asst `plusStmts` pending_assts) @@ -152,6 +159,7 @@ performTailCall fun_info arg_amodes pending_assts ; directCall sp apply_lbl args extra_args (node_asst `plusStmts` pending_assts) + } -- A direct function call (possibly with some left-over arguments) @@ -170,11 +178,67 @@ performTailCall fun_info arg_amodes pending_assts } } where - fun_name = idName (cgIdInfoId fun_info) + fun_id = cgIdInfoId fun_info + fun_name = idName fun_id lf_info = cgIdInfoLF fun_info - - - + fun_has_cafs = idCafInfo fun_id + untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)) + -- Test if closure is a constructor + maybeSwitchOnCons enterClosure eob + | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, + not opt_SccProfilingOn + -- we can't shortcut when profiling is on, because we have + -- to enter a closure to mark it as "used" for LDV profiling + = do { is_constr <- newLabelC + -- Is the pointer tagged? + -- Yes, jump to switch statement + ; stmtC (CmmCondBranch (cmmIsTagged (CmmReg nodeReg)) + is_constr) + -- No, enter the closure. + ; enterClosure + ; labelC is_constr + ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl)) []) + } +{- + -- This is a scrutinee for a case expression + -- so let's see if we can directly inspect the closure + | EndOfBlockInfo _ (CaseAlts lbl _ _ _) <- eob + = do { no_cons <- newLabelC + -- Both the NCG and gcc optimize away the temp + ; z <- newTemp wordRep + ; stmtC (CmmAssign z tag_expr) + ; let tag = CmmReg z + -- Is the closure a cons? + ; stmtC (CmmCondBranch (cond1 tag) no_cons) + ; stmtC (CmmCondBranch (cond2 tag) no_cons) + -- Yes, jump to switch statement + ; stmtC (CmmJump (CmmLit (CmmLabel lbl)) []) + ; labelC no_cons + -- No, enter the closure. + ; enterClosure + } +-} + -- No case expression involved, enter the closure. + | otherwise + = do { stmtC untag_node + ; enterClosure + } + where + --cond1 tag = cmmULtWord tag lowCons + -- More efficient than the above? +{- + tag_expr = cmmGetClosureType (CmmReg nodeReg) + cond1 tag = cmmEqWord tag (CmmLit (mkIntCLit 0)) + cond2 tag = cmmUGtWord tag highCons + lowCons = CmmLit (mkIntCLit 1) + -- CONSTR + highCons = CmmLit (mkIntCLit 8) + -- CONSTR_NOCAF_STATIC (from ClosureType.h) +-} + +directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)] + -> [(CgRep, CmmExpr)] -> CmmStmts + -> Code directCall sp lbl args extra_args assts = do let -- First chunk of args go in registers @@ -218,17 +282,17 @@ doFinalJump final_sp is_let_no_escape jump_code -- and do the jump ; jump_code } --- ----------------------------------------------------------------------------- +-- ---------------------------------------------------------------------------- -- A general return (just a special case of doFinalJump, above) -performReturn :: Code -- The code to execute to actually do the return +performReturn :: Code -- The code to execute to actually do the return -> Code performReturn finish_code - = do { EndOfBlockInfo args_sp sequel <- getEndOfBlockInfo + = do { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo ; doFinalJump args_sp False{-not a LNE-} finish_code } --- ----------------------------------------------------------------------------- +-- ---------------------------------------------------------------------------- -- Primitive Returns -- Just load the return value into the right register, and return. @@ -237,34 +301,10 @@ performPrimReturn :: CgRep -> CmmExpr -- The thing to return performPrimReturn rep amode = do { whenC (not (isVoidArg rep)) (stmtC (CmmAssign ret_reg amode)) - ; performReturn emitDirectReturnInstr } + ; performReturn emitReturnInstr } where ret_reg = dataReturnConvPrim rep --- ----------------------------------------------------------------------------- --- Algebraic constructor returns - --- Constructor is built on the heap; Node is set. --- All that remains is to do the right sort of jump. - -emitKnownConReturnCode :: DataCon -> Code -emitKnownConReturnCode con - = emitAlgReturnCode (dataConTyCon con) - (CmmLit (mkIntCLit (dataConTagZ con))) - -- emitAlgReturnCode requires zero-indexed tag - -emitAlgReturnCode :: TyCon -> CmmExpr -> Code --- emitAlgReturnCode is used both by emitKnownConReturnCode, --- and by by PrimOps that return enumerated types (i.e. --- all the comparison operators). -emitAlgReturnCode tycon tag - = do { case ctrlReturnConvAlg tycon of - VectoredReturn fam_sz -> do { tickyVectoredReturn fam_sz - ; emitVectoredReturnInstr tag } - UnvectoredReturn _ -> emitDirectReturnInstr - } - - -- --------------------------------------------------------------------------- -- Unboxed tuple returns @@ -281,11 +321,11 @@ emitAlgReturnCode tycon tag returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code returnUnboxedTuple amodes - = do { eob@(EndOfBlockInfo args_sp sequel) <- getEndOfBlockInfo + = do { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo ; tickyUnboxedTupleReturn (length amodes) ; (final_sp, assts) <- pushUnboxedTuple args_sp amodes ; emitSimultaneously assts - ; doFinalJump final_sp False{-not a LNE-} emitDirectReturnInstr } + ; doFinalJump final_sp False{-not a LNE-} emitReturnInstr } pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing -> [(CgRep, CmmExpr)] -- amodes of the components @@ -343,13 +383,21 @@ ccallReturnUnboxedTuple amodes before_jump -- Calling an out-of-line primop tailCallPrimOp :: PrimOp -> [StgArg] -> Code -tailCallPrimOp op args +tailCallPrimOp op + = tailCallPrim (mkRtsPrimOpLabel op) + +tailCallPrimCall :: PrimCall -> [StgArg] -> Code +tailCallPrimCall primcall + = tailCallPrim (mkPrimCallLabel primcall) + +tailCallPrim :: CLabel -> [StgArg] -> Code +tailCallPrim lbl args = do { -- We're going to perform a normal-looking tail call, -- except that *all* the arguments will be in registers. -- Hence the ASSERT( null leftovers ) arg_amodes <- getArgAmodes args ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes - jump_to_primop = jumpToLbl (mkRtsPrimOpLabel op) + jump_to_primop = jumpToLbl lbl ; ASSERT(null leftovers) -- no stack-resident args emitSimultaneously (assignToRegs arg_regs) @@ -375,19 +423,10 @@ tailCallPrimOp op args pushReturnAddress :: EndOfBlockInfo -> Code -pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ False)) +pushReturnAddress (EndOfBlockInfo args_sp (CaseAlts lbl _ _)) = do { sp_rel <- getSpRelOffset args_sp ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) } --- For a polymorphic case, we have two return addresses to push: the case --- return, and stg_seq_frame_info which turns a possible vectored return --- into a direct one. -pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ True)) - = do { sp_rel <- getSpRelOffset (args_sp-1) - ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) - ; sp_rel <- getSpRelOffset args_sp - ; stmtC (CmmStore sp_rel (CmmLit (CmmLabel mkSeqInfoLabel))) } - pushReturnAddress _ = nopC -- ----------------------------------------------------------------------------- @@ -444,3 +483,4 @@ adjustSpAndHp newRealSp ; setRealHp vHp } \end{code} +