X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgExpr.lhs;h=a7cbef26e9c53c336f5c008881d65ecd0eab5c56;hb=d482ad51c9051d6eb9fbcafd90362949db29f374;hp=fc96eb32da14db82a199bebb2f4d2b05324221fe;hpb=3505f69a94879f85376e839cc535705fbc39d09a;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index fc96eb3..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.27 1999/06/09 14:28:38 simonmar 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,23 +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 DataCon ( DataCon, dataConTyCon ) -import Const ( Con(..) ) -import IdInfo ( ArityInfo(..) ) -import PrimOp ( primOpOutOfLine, - getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) - ) -import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep ) -import TyCon ( maybeTyConSingleCon, - isUnboxedTupleTyCon, isEnumerationTyCon ) -import Type ( Type, typePrimRep, splitTyConApp_maybe, splitRepTyConApp_maybe ) -import Maybes ( assocMaybe, maybeToBool ) +import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, + PrimOp(..), PrimOpResultInfo(..) ) +import TysPrim ( foreignObjPrimTyCon, arrayPrimTyCon, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon, + mutableArrayPrimTyCon ) +import PrimRep ( PrimRep(..), isFollowableRep ) +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} @@ -85,11 +85,9 @@ cgExpr (StgApp fun args) = cgTailCall fun args %******************************************************** \begin{code} -cgExpr (StgCon (DataCon con) args res_ty) +cgExpr (StgConApp con args) = getArgAmodes args `thenFC` \ amodes -> - cgReturnDataCon con amodes (all zero_size args) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 + cgReturnDataCon con amodes \end{code} Literals are similar to constructors; they return by putting @@ -97,9 +95,8 @@ themselves in an appropriate register and returning to the address on top of the stack. \begin{code} -cgExpr (StgCon (Literal lit) args res_ty) - = ASSERT( null args ) - performPrimReturn (text "literal" <+> ppr lit) (CLit lit) +cgExpr (StgLit lit) + = performPrimReturn (text "literal" <+> ppr lit) (CLit lit) \end{code} @@ -113,19 +110,21 @@ Here is where we insert real live machine instructions. NOTE about _ccall_GC_: -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 as an inline primop. +A _ccall_GC_ is treated as an out-of-line primop (returns True +for primOpOutOfLine) so that when we see the call in case context + case (ccall ...) of { ... } +we get a proper stack frame on the stack when we perform it. When we +get in a tail-call position, however, we need to actually perform the +call, so we treat it as an inline primop. \begin{code} -cgExpr (StgCon (PrimOp op@(CCallOp _ _ may_gc@True _)) args res_ty) +cgExpr (StgOpApp op@(StgFCallOp _ _) 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) +cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) getArgAmode arg `thenFC` \amode -> -- save the tag in a temporary in case amode overlaps @@ -133,23 +132,31 @@ cgExpr (StgCon (PrimOp TagToEnumOp) [arg] res_ty) absC (CAssign dyn_tag amode) `thenC` performReturn ( CAssign (CReg node) - (CTableEntry + (CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) - dyn_tag PtrRep)) + dyn_tag PtrRep) PtrRep)) (\ sequel -> mkDynamicAlgReturnCode tycon dyn_tag sequel) where dyn_tag = CTemp (mkBuiltinUnique 0) IntRep - (Just (tycon,_)) = splitTyConApp_maybe res_ty + -- + -- if you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- + -- That won't work. + -- + tycon = tyConAppTyCon res_ty -cgExpr x@(StgCon (PrimOp op) args res_ty) - | primOpOutOfLine op = tailCallPrimOp op args - | otherwise - = ASSERT(op /= SeqOp) -- can't handle SeqOp +cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) + | primOpOutOfLine primop + = tailCallPrimOp primop args - getArgAmodes args `thenFC` \ arg_amodes -> + | otherwise + = getArgAmodes args `thenFC` \ arg_amodes -> - case (getPrimOpResultInfo op) of + case (getPrimOpResultInfo primop) of ReturnsPrim kind -> let result_amode = CReg (dataReturnConvPrim kind) in @@ -177,9 +184,9 @@ cgExpr x@(StgCon (PrimOp op) args res_ty) -- 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} @@ -205,14 +212,14 @@ cgExpr (StgCase expr live_vars save_vars bndr srt alts) \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@} \begin{code} -cgExpr (StgLet (StgNonRec name rhs) expr) - = cgRhs name rhs `thenFC` \ (name, info) -> +cgExpr (StgLet (StgNonRec srt name rhs) expr) + = cgRhs srt name rhs `thenFC` \ (name, info) -> addBindC name info `thenC` cgExpr expr -cgExpr (StgLet (StgRec pairs) expr) +cgExpr (StgLet (StgRec srt pairs) expr) = fixC (\ new_bindings -> addBindsC new_bindings `thenC` - listFCs [ cgRhs b e | (b,e) <- pairs ] + listFCs [ cgRhs srt b e | (b,e) <- pairs ] ) `thenFC` \ new_bindings -> addBindsC new_bindings `thenC` @@ -252,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 @@ -271,20 +278,15 @@ We rely on the support code in @CgCon@ (to do constructors) and in @CgClosure@ (to do closures). \begin{code} -cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) +cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along so a binding can be set up -cgRhs name (StgRhsCon maybe_cc con args) - = getArgAmodes args `thenFC` \ amodes -> - buildDynCon name maybe_cc con amodes (all zero_size args) - `thenFC` \ idinfo -> +cgRhs srt name (StgRhsCon maybe_cc con args) + = getArgAmodes args `thenFC` \ amodes -> + buildDynCon name maybe_cc con amodes `thenFC` \ idinfo -> returnFC (name, idinfo) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 -cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body) - = mkRhsClosure name cc bi srt fvs upd_flag args body -cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body) +cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body) = mkRhsClosure name cc bi srt fvs upd_flag args body \end{code} @@ -314,27 +316,31 @@ mkRhsClosure bndr cc bi srt [] -- A thunk body@(StgCase (StgApp scrutinee [{-no args-}]) _ _ _ _ -- ignore uniq, etc. - (StgAlgAlts case_ty + (StgAlgAlts (Just tycon) [(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) - tycon = dataConTyCon con + bogus_name = panic "mkRhsClosure" \end{code} - Ap thunks ~~~~~~~~~ @@ -358,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 @@ -378,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} @@ -392,17 +396,19 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body %* * %******************************************************** \begin{code} -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs) +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot + (StgNonRec srt binder rhs) = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot - NonRecursive binder rhs + NonRecursive srt binder rhs `thenFC` \ (binder, info) -> addBindC binder info -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot + (StgRec srt pairs) = fixC (\ new_bindings -> addBindsC new_bindings `thenC` listFCs [ cgLetNoEscapeRhs full_live_in_rhss - rhs_eob_info maybe_cc_slot Recursive b e + rhs_eob_info maybe_cc_slot Recursive srt b e | (b,e) <- pairs ] ) `thenFC` \ new_bindings -> @@ -417,36 +423,49 @@ cgLetNoEscapeRhs -> EndOfBlockInfo -> Maybe VirtualSpOffset -> RecFlag + -> SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo) -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder - (StgRhsClosure cc bi srt _ upd_flag args body) +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder + (StgRhsClosure cc bi _ upd_flag args body) = -- We could check the update flag, but currently we don't switch it off -- for let-no-escaped things, so we omit the check too! -- case upd_flag of -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update! -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body - cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body + cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info + maybe_cc_slot rec args body -- For a constructor RHS we want to generate a single chunk of code which -- can be jumped to from many places, which will return the constructor. -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside! -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder (StgRhsCon cc con args) - = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT full_live_in_rhss rhs_eob_info maybe_cc_slot rec + = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt + full_live_in_rhss rhs_eob_info maybe_cc_slot rec [] --No args; the binder is data structure, not a function - (StgCon (DataCon con) args (idType binder)) + (StgConApp con args) \end{code} Little helper for primitives that return unboxed tuples. \begin{code} -primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> 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. @@ -454,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` @@ -462,13 +481,22 @@ primRetUnboxedTuple op args res_ty allocate some temporaries for the return values. -} 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 + ty_args = tyConAppArgs (repType 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 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}