%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%********************************************************
%* *
%********************************************************
\begin{code}
-#include "HsVersions.h"
-
module CgTailCall (
cgTailCall,
performReturn,
mkPrimReturnCode,
tailCallBusiness
-
- -- and to make the interface self-sufficient...
) where
-IMPORT_Trace
-import Pretty -- Pretty/Outputable: rm (debugging only) ToDo
-import Outputable
+#include "HsVersions.h"
-import StgSyn
import CgMonad
import AbsCSyn
-import Type ( isPrimType, Type )
-import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgCompInfo ( oTHER_TAG, iND_TAG )
-import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
- mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
+import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg,
+ ctrlReturnConvAlg, CtrlReturnConvention(..),
+ DataReturnConvention(..)
)
import CgStackery ( adjustRealSps, mkStkAmodes )
-import CgUsages ( getSpARelOffset, getSpBRelOffset )
-import CLabel ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
-import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getDataConTyCon, getDataConTag,
- idType, getIdPrimRep, fIRST_TAG, Id,
- ConTag(..)
+import CgUsages ( getSpARelOffset )
+import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel, CLabel )
+import ClosureInfo ( nodeMustPointToIt,
+ getEntryConvention, EntryConvention(..),
+ LambdaFormInfo
+ )
+import CmdLineOpts ( opt_DoSemiTagging )
+import HeapOffs ( zeroOff, VirtualSpAOffset )
+import Id ( idType, dataConTyCon, dataConTag,
+ fIRST_TAG, Id
)
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import PrimRep ( retPrimRepSize )
-import Util
+import Literal ( mkMachInt )
+import Maybes ( assocMaybe )
+import PrimRep ( PrimRep(..) )
+import StgSyn ( StgArg, GenStgArg(..), StgLiveVars )
+import Type ( isUnpointedType )
+import TyCon ( TyCon )
+import Util ( zipWithEqual, panic, assertPanic )
\end{code}
%************************************************************************
\item Adjust the stack high water mark appropriately.
\end{itemize}
+\begin{code}
+cgTailCall (StgConArg con) args live_vars
+ = panic "cgTailCall StgConArg" -- Only occur in argument positions
+\end{code}
+
Literals are similar to constructors; they return by putting
themselves in an appropriate register and returning to the address on
top of the B stack.
Case for unboxed @Ids@ first:
\begin{code}
cgTailCall atom@(StgVarArg fun) [] live_vars
- | isPrimType (idType fun)
+ | isUnpointedType (idType fun)
= getCAddrMode fun `thenFC` \ amode ->
performPrimReturn amode live_vars
\end{code}
-- Set the info pointer, and jump
set_info_ptr `thenC`
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- absC (CJump (CLbl (update_label isw_chkr) CodePtrRep))
+ absC (CJump (CLbl update_label CodePtrRep))
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
)
where
- tag = getDataConTag con
- tycon = getDataConTyCon con
+ tag = dataConTag con
+ tycon = dataConTyCon con
return_convention = ctrlReturnConvAlg tycon
zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
-- cf AbsCUtils.mkAlgAltsCSwitch
- update_label isw_chkr
- = case (dataReturnConvAlg isw_chkr con) of
+ update_label
+ = case (dataReturnConvAlg con) of
ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
= -- Get all the info we have about the function and args and go on to
-- the business end
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
tailCallBusiness
fun fun_amode lf_info arg_amodes
-> Code
tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
- = isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
- nodeMustPointToIt lf_info `thenFC` \ node_points ->
+ = nodeMustPointToIt lf_info `thenFC` \ node_points ->
getEntryConvention fun lf_info
(map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
([],
mkAbstractCs [
CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
- CAssign (CReg infoptr)
-
- (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
- CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
+ CJump (CMacroExpr CodePtrRep ENTRY_CODE [(CMacroExpr DataPtrRep INFO_PTR [CReg node])])
])
StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
`mkAbsCStmts`
CJump (CLbl lbl CodePtrRep))
DirectEntry lbl arity regs ->
- (regs, (if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit arity]
- else AbsCNop)
- `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
+ (regs, CJump (CLbl lbl CodePtrRep))
no_of_args = length arg_amodes
- (reg_arg_assts, stk_arg_amodes)
- = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes),
- drop (length arg_regs) arg_amodes) -- No regs, or
- -- args beyond arity
+ (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
+ -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
+
+ reg_arg_assts
+ = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
in
adjustRealSps final_spa final_spb `thenC`
-- Now decide about semi-tagging
- isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on ->
+ let
+ semi_tagging_on = opt_DoSemiTagging
+ in
case (semi_tagging_on, arg_amodes, node_points, sequel) of
--
= load_regs_and_profiling_code `mkAbsCStmts`
CJump (CLbl join_lbl CodePtrRep)
- semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
+ semi_tagged_alts = [ (mkMachInt (fromInt (tag - fIRST_TAG)),
join_details_to_code join_details)
| (tag, join_details) <- st_alts
]
projects / ghc-hetmet.git / blobdiff