X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgTailCall.lhs;h=89c050406f746f34fc105aca66d894fc3ac3fc67;hp=22cecb72492bfd93a51a0ff71aef4847f70dc1e2;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=9ff76535edb25ab7434284adddb5c64708ecb547 diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 22cecb7..89c0504 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -11,6 +11,7 @@ module CgTailCall ( returnUnboxedTuple, ccallReturnUnboxedTuple, pushUnboxedTuple, tailCallPrimOp, + tailCallPrimCall, pushReturnAddress ) where @@ -35,6 +36,7 @@ import Id import StgSyn import PrimOp import Outputable +import StaticFlags import Control.Monad @@ -102,19 +104,27 @@ 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. @@ -126,7 +136,7 @@ performTailCall fun_info arg_amodes pending_assts -- 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 emitReturnInstr } @@ -149,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) @@ -167,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 @@ -222,7 +289,7 @@ 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 } -- ---------------------------------------------------------------------------- @@ -254,7 +321,7 @@ performPrimReturn rep amode 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 @@ -316,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) @@ -348,7 +423,7 @@ tailCallPrimOp op args pushReturnAddress :: EndOfBlockInfo -> Code -pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _)) +pushReturnAddress (EndOfBlockInfo args_sp (CaseAlts lbl _ _)) = do { sp_rel <- getSpRelOffset args_sp ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) } @@ -408,3 +483,4 @@ adjustSpAndHp newRealSp ; setRealHp vHp } \end{code} +