X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgExpr.lhs;h=a7cbef26e9c53c336f5c008881d65ecd0eab5c56;hb=d482ad51c9051d6eb9fbcafd90362949db29f374;hp=f4ad2a1c6863ffcea810f7d2c4cdabbba305883b;hpb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index f4ad2a1..a7cbef2 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.43 2001/05/22 13:43:15 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.51 2002/09/13 15:02:28 simonpj Exp $ % %******************************************************** %* * @@ -18,7 +18,7 @@ import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE ) import StgSyn import CgMonad import AbsCSyn -import AbsCUtils ( mkAbstractCs ) +import AbsCUtils ( mkAbstractCs, getAmodeRep ) import CLabel ( mkClosureTblLabel ) import SMRep ( fixedHdrSize ) @@ -35,19 +35,23 @@ import CgTailCall ( cgTailCall, performReturn, performPrimReturn, tailCallPrimOp, returnUnboxedTuple ) import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, - mkApLFInfo, layOutDynCon ) + mkApLFInfo, layOutDynConstr ) import CostCentre ( sccAbleCostCentre, isSccCountCostCentre ) import Id ( idPrimRep, idType, 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} @@ -150,9 +154,7 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) = 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 @@ -257,7 +259,7 @@ centre. 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 @@ -318,22 +320,27 @@ mkRhsClosure bndr cc bi srt [(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) = layOutDynCon con idPrimRep params + (isUpdatable upd_flag) + (_, params_w_offsets) = layOutDynConstr bogus_name 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 ~~~~~~~~~ @@ -357,7 +364,7 @@ mkRhsClosure bndr cc bi srt [] -- 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 @@ -377,11 +384,9 @@ The default case ~~~~~~~~~~~~~~~~ \begin{code} mkRhsClosure bndr cc bi srt fvs upd_flag args body - = 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 + = cgRhsClosure bndr cc bi srt fvs args body lf_info + where + lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args \end{code} @@ -450,7 +455,17 @@ Little helper for primitives that return unboxed tuples. \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. @@ -458,7 +473,7 @@ primRetUnboxedTuple op args res_ty 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` @@ -472,4 +487,16 @@ primRetUnboxedTuple op args res_ty temp_amodes = zipWith CTemp temp_uniqs prim_reps in returnUnboxedTuple 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}