%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.16 1998/12/03 17:23:30 simonm Exp $
+% $Id: CgExpr.lhs,v 1.28 1999/06/24 13:04:18 simonmar Exp $
%
%********************************************************
%* *
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
-import CgBindery ( getArgAmodes, CgIdInfo, nukeDeadBindings )
+import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo,
+ nukeDeadBindings, addBindC, addBindsC )
import CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre,
- splitAlgTyConAppThroughNewTypes )
+ restoreCurrentCostCentre )
import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgLetNoEscape ( cgLetNoEscapeClosure )
)
import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
mkApLFInfo, layOutDynCon )
-import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
+import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
import Id ( idPrimRep, idType, Id )
import VarSet
import DataCon ( DataCon, dataConTyCon )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import TyCon ( maybeTyConSingleCon,
isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type ( Type, typePrimRep )
+import Type ( Type, typePrimRep, splitTyConApp_maybe, splitRepTyConApp_maybe )
import Maybes ( assocMaybe, maybeToBool )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
\begin{code}
cgExpr (StgCon (Literal lit) args res_ty)
= ASSERT( null args )
- performPrimReturn (CLit lit)
+ performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
\end{code}
A _ccall_GC_ is treated as an out-of-line primop for the case
expression code, because we want a proper stack frame on the stack
when we perform it. When we get here, however, we need to actually
-perform the call, so we treat it an an inline primop.
+perform the call, so we treat it as an inline primop.
\begin{code}
cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty)
= primRetUnboxedTuple op args res_ty
+-- tagToEnum# is special: we need to pull the constructor out of the table,
+-- and perform an appropriate return.
+
+cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty)
+ = ASSERT(isEnumerationTyCon tycon)
+ getArgAmode arg `thenFC` \amode ->
+ -- save the tag in a temporary in case amode overlaps
+ -- with node.
+ absC (CAssign dyn_tag amode) `thenC`
+ performReturn (
+ CAssign (CReg node)
+ (CVal (CIndex
+ (CLbl (mkClosureTblLabel tycon) PtrRep)
+ dyn_tag PtrRep) PtrRep))
+ (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel)
+ where
+ dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
+ (Just (tycon,_)) = splitTyConApp_maybe res_ty
+
+
cgExpr x@(StgCon (PrimOp op) args res_ty)
| primOpOutOfLine op = tailCallPrimOp op args
| otherwise
let result_amode = CReg (dataReturnConvPrim kind) in
performReturn
(COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
- (\ sequel -> mkPrimReturnCode sequel)
+ (mkPrimReturnCode (text "primapp)" <+> ppr x))
-- otherwise, must be returning an enumerated type (eg. Bool).
-- we've only got the tag in R2, so we have to load the constructor
ReturnsAlg tycon
| isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty
-
| isEnumerationTyCon tycon ->
performReturn
(COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}])
-- about to return anyway.
dyn_tag = CTemp (mkBuiltinUnique 0) IntRep
- closure_lbl = CTableEntry
+ closure_lbl = CVal (CIndex
(CLbl (mkClosureTblLabel tycon) PtrRep)
- dyn_tag PtrRep
+ dyn_tag PtrRep) PtrRep
\end{code}
cgExpr (StgSCC cc expr)
= ASSERT(sccAbleCostCentre cc)
costCentresC
- (if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
+ SLIT("SET_CCC")
[mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
`thenC`
cgExpr expr
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
= ASSERT(is_single_constructor)
- cgStdRhsClosure bndr cc bi srt [the_fv] [] body lf_info [StgVarArg the_fv]
+ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
(isUpdatable upd_flag)
&& arity <= mAX_SPEC_AP_SIZE
-- Ha! an Ap thunk
- = cgStdRhsClosure bndr cc bi srt fvs [] body lf_info payload
+ = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
where
lf_info = mkApLFInfo (idType bndr) upd_flag arity
~~~~~~~~~~~~~~~~
\begin{code}
mkRhsClosure bndr cc bi srt fvs upd_flag args body
- = cgRhsClosure bndr cc bi srt fvs args body lf_info
- where lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+ = getSRTLabel `thenFC` \ srt_label ->
+ let lf_info =
+ mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
+ in
+ cgRhsClosure bndr cc bi fvs args body lf_info
\end{code}
\begin{code}
primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
- = getArgAmodes args `thenFC` \ arg_amodes ->
+ = getArgAmodes args `thenFC` \ arg_amodes ->
{-
- put all the arguments in temporaries so they don't get stomped when
- we push the return address.
+ put all the arguments in temporaries so they don't get stomped when
+ we push the return address.
-}
- let
- n_args = length args
- arg_uniqs = map mkBuiltinUnique [0..n_args-1]
- arg_reps = map getArgPrimRep args
- arg_temps = zipWith CTemp arg_uniqs arg_reps
+ let
+ n_args = length args
+ arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
+ arg_reps = map getArgPrimRep args
+ arg_temps = zipWith CTemp arg_uniqs arg_reps
in
absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
{-
- allocate some temporaries for the return values.
+ allocate some temporaries for the return values.
-}
- let
- Just (tc,ty_args) = splitAlgTyConAppThroughNewTypes res_ty
- prim_reps = map typePrimRep ty_args
- temp_uniqs = map mkBuiltinUnique [n_args..n_args+length ty_args-1]
- temp_amodes = zipWith CTemp temp_uniqs prim_reps
+ let
+ (tc,ty_args) = case splitRepTyConApp_maybe res_ty of
+ Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
+ Just pr -> pr
+ prim_reps = map typePrimRep ty_args
+ temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
+ temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
+
\end{code}