%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.44 2001/09/26 15:11:50 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.52 2002/12/11 15:36:26 simonmar Exp $
%
%********************************************************
%* *
import StgSyn
import CgMonad
import AbsCSyn
-import AbsCUtils ( mkAbstractCs )
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
import CgRetConv ( dataReturnConvPrim )
import CgTailCall ( cgTailCall, performReturn, performPrimReturn,
mkDynamicAlgReturnCode, mkPrimReturnCode,
- tailCallPrimOp, returnUnboxedTuple
+ tailCallPrimOp, ccallReturnUnboxedTuple
)
import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
mkApLFInfo, layOutDynConstr )
import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
-import Id ( idPrimRep, idType, Id )
+import Id ( idPrimRep, Id )
import VarSet
-import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
+import PrimOp ( primOpOutOfLine, getPrimOpResultInfo,
+ PrimOp(..), PrimOpResultInfo(..) )
+import TysPrim ( foreignObjPrimTyCon, arrayPrimTyCon,
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+ mutableArrayPrimTyCon )
import PrimRep ( PrimRep(..), isFollowableRep )
-import TyCon ( maybeTyConSingleCon,
- isUnboxedTupleTyCon, isEnumerationTyCon )
+import TyCon ( isUnboxedTupleTyCon, isEnumerationTyCon )
import Type ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
import Maybes ( maybeToBool )
import ListSetOps ( assocMaybe )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
+import Util ( lengthIs )
import Outputable
\end{code}
= tailCallPrimOp primop args
| otherwise
- = ASSERT(primop /= SeqOp) -- can't handle SeqOp
-
- getArgAmodes args `thenFC` \ arg_amodes ->
+ = getArgAmodes args `thenFC` \ arg_amodes ->
case (getPrimOpResultInfo primop) of
cgExpr (StgSCC cc expr)
= ASSERT(sccAbleCostCentre cc)
costCentresC
- SLIT("SET_CCC")
+ FSLIT("SET_CCC")
[mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
`thenC`
cgExpr expr
[(con, params, use_mask,
(StgApp selectee [{-no args-}]))]
StgNoDefault))
- | the_fv == scrutinee -- Scrutinee is the only free variable
- && maybeToBool maybe_offset -- Selectee is a component of the tuple
+ | the_fv == scrutinee -- Scrutinee is the only free variable
+ && 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)
+ = -- NOT TRUE: ASSERT(is_single_constructor)
+ -- The simplifier may have statically determined that the single alternative
+ -- is the only possible case and eliminated the others, even if there are
+ -- other constructors in the datatype. It's still ok to make a selector
+ -- thunk in this case, because we *know* which constructor the scrutinee
+ -- will evaluate to.
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
- lf_info = mkSelectorLFInfo (idType bndr) offset_into_int
- (isUpdatable upd_flag)
- (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params -- Just want the layout
+ lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+ (_, params_w_offsets) = layOutDynConstr con idPrimRep params
+ -- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
- is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- bogus_name = panic "mkRhsClosure"
\end{code}
+
Ap thunks
~~~~~~~~~
[] -- No args; a thunk
body@(StgApp fun_id args)
- | length args + 1 == arity
+ | args `lengthIs` (arity-1)
&& all isFollowableRep (map idPrimRep fvs)
&& isUpdatable upd_flag
&& arity <= mAX_SPEC_AP_SIZE
= cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
where
- lf_info = mkApLFInfo (idType bndr) upd_flag arity
+ lf_info = mkApLFInfo bndr upd_flag arity
-- the payload has to be in the correct order, hence we can't
-- just use the fvs.
payload = StgVarArg fun_id : args
\begin{code}
primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
- = getArgAmodes args `thenFC` \ arg_amodes ->
+ = getArgAmodes args `thenFC` \ arg_amodes1 ->
+ {-
+ For a foreign call, we might need to fiddle with some of the args:
+ for example, when passing a ByteArray#, we pass a ptr to the goods
+ rather than the heap object.
+ -}
+ let
+ arg_amodes
+ | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
+ | otherwise = arg_amodes1
+ in
{-
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_reps = map getAmodeRep arg_amodes
arg_temps = zipWith CTemp arg_uniqs arg_reps
in
absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
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 []))
+ ccallReturnUnboxedTuple temp_amodes
+ (absC (COpStmt temp_amodes op arg_temps []))
+
+
+shimFCallArg arg amode
+ | tycon == foreignObjPrimTyCon
+ = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
+ | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+ = CMacroExpr PtrRep PTRS_ARR_CTS [amode]
+ | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+ = CMacroExpr AddrRep BYTE_ARR_CTS [amode]
+ | otherwise = amode
+ where
+ -- should be a tycon app, since this is a foreign call
+ tycon = tyConAppTyCon (repType (stgArgType arg))
\end{code}