projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Code simplifications due to call/return separation; some improvements to how node...
[ghc-hetmet.git]
/
compiler
/
codeGen
/
CgTailCall.lhs
diff --git
a/compiler/codeGen/CgTailCall.lhs
b/compiler/codeGen/CgTailCall.lhs
index
e25e794
..
60a8561
100644
(file)
--- a/
compiler/codeGen/CgTailCall.lhs
+++ b/
compiler/codeGen/CgTailCall.lhs
@@
-27,7
+27,6
@@
import CgUtils
import CgTicky
import ClosureInfo
import SMRep
import CgTicky
import ClosureInfo
import SMRep
-import MachOp
import Cmm
import CmmUtils
import CLabel
import Cmm
import CmmUtils
import CLabel
@@
-36,6
+35,7
@@
import Id
import StgSyn
import PrimOp
import Outputable
import StgSyn
import PrimOp
import Outputable
+import StaticFlags
import Control.Monad
import Control.Monad
@@
-108,9
+108,9
@@
performTailCall fun_info arg_amodes pending_assts
opt_node_asst | nodeMustPointToIt lf_info = node_asst
| otherwise = noStmts
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
opt_node_asst | nodeMustPointToIt lf_info = node_asst
| otherwise = noStmts
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
- ; this_pkg <- getThisPackage
- ; case (getCallMethod 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
-- Node must always point to things we enter
EnterIt -> do
@@
-135,7
+135,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.
-- 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 }
{ emitSimultaneously (node_asst `plusStmts` pending_assts)
; doFinalJump sp False emitReturnInstr }
@@
-177,12
+177,17
@@
performTailCall fun_info arg_amodes pending_assts
}
}
where
}
}
where
- fun_name = idName (cgIdInfoId fun_info)
+ fun_id = cgIdInfoId fun_info
+ fun_name = idName fun_id
lf_info = cgIdInfoLF fun_info
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
untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg))
-- Test if closure is a constructor
maybeSwitchOnCons enterClosure eob
- | EndOfBlockInfo _ (CaseAlts lbl _ _) <- 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
= do { is_constr <- newLabelC
-- Is the pointer tagged?
-- Yes, jump to switch statement
@@
-191,7
+196,7
@@
performTailCall fun_info arg_amodes pending_assts
-- No, enter the closure.
; enterClosure
; labelC is_constr
-- No, enter the closure.
; enterClosure
; labelC is_constr
- ; stmtC (CmmJump (CmmLit (CmmLabel lbl)) [])
+ ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl)) [])
}
{-
-- This is a scrutinee for a case expression
}
{-
-- This is a scrutinee for a case expression
@@
-220,6
+225,7
@@
performTailCall fun_info arg_amodes pending_assts
where
--cond1 tag = cmmULtWord tag lowCons
-- More efficient than the above?
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
tag_expr = cmmGetClosureType (CmmReg nodeReg)
cond1 tag = cmmEqWord tag (CmmLit (mkIntCLit 0))
cond2 tag = cmmUGtWord tag highCons
@@
-227,11
+233,11
@@
performTailCall fun_info arg_amodes pending_assts
-- CONSTR
highCons = CmmLit (mkIntCLit 8)
-- CONSTR_NOCAF_STATIC (from ClosureType.h)
-- CONSTR
highCons = CmmLit (mkIntCLit 8)
-- CONSTR_NOCAF_STATIC (from ClosureType.h)
+-}
-
-untagCmmAssign (CmmAssign r cmmExpr) = CmmAssign r (cmmUntag cmmExpr)
-untagCmmAssign stmt = stmt
-
+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
directCall sp lbl args extra_args assts = do
let
-- First chunk of args go in registers
@@
-282,7
+288,7
@@
performReturn :: Code -- The code to execute to actually do the return
-> Code
performReturn finish_code
-> 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 }
-- ----------------------------------------------------------------------------
; doFinalJump args_sp False{-not a LNE-} finish_code }
-- ----------------------------------------------------------------------------
@@
-314,7
+320,7
@@
performPrimReturn rep amode
returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code
returnUnboxedTuple amodes
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
; tickyUnboxedTupleReturn (length amodes)
; (final_sp, assts) <- pushUnboxedTuple args_sp amodes
; emitSimultaneously assts
@@
-408,7
+414,7
@@
tailCallPrimOp op args
pushReturnAddress :: EndOfBlockInfo -> Code
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)) }
= do { sp_rel <- getSpRelOffset args_sp
; stmtC (CmmStore sp_rel (mkLblExpr lbl)) }
@@
-468,3
+474,4
@@
adjustSpAndHp newRealSp
; setRealHp vHp
}
\end{code}
; setRealHp vHp
}
\end{code}
+