module CgTailCall (
cgTailCall, performTailCall,
performReturn, performPrimReturn,
- emitKnownConReturnCode, emitAlgReturnCode,
returnUnboxedTuple, ccallReturnUnboxedTuple,
pushUnboxedTuple,
tailCallPrimOp,
+ tailCallPrimCall,
pushReturnAddress
) where
import CLabel
import Type
import Id
-import DataCon
import StgSyn
-import TyCon
import PrimOp
import Outputable
+import StaticFlags
import Control.Monad
| 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)
; directCall sp apply_lbl args extra_args
(node_asst `plusStmts` pending_assts)
+
}
-- A direct function call (possibly with some left-over arguments)
}
}
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
-- 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.
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
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
-- 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)
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
-- -----------------------------------------------------------------------------
; setRealHp vHp
}
\end{code}
+
projects / ghc-hetmet.git / blobdiff