X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgExpr.lhs;h=8e8b5e276b7108e94554d69873248d7f6bce518a;hb=67b9ddc822964b29ea177bde3c735702afcda667;hp=01a700317347528e3884fa3f25964b5ae605ddb0;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 01a7003..8e8b5e2 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.17 1998/12/18 17:40:50 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.40 2000/11/24 09:51:38 simonpj Exp $ % %******************************************************** %* * @@ -18,13 +18,14 @@ import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE ) import StgSyn import CgMonad import AbsCSyn +import AbsCUtils ( mkAbstractCs ) 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 ) @@ -35,20 +36,16 @@ import CgTailCall ( cgTailCall, performReturn, performPrimReturn, ) 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 Const ( Con(..) ) -import IdInfo ( ArityInfo(..) ) -import PrimOp ( primOpOutOfLine, - getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) - ) -import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep ) +import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) ) +import PrimRep ( PrimRep(..), isFollowableRep ) import TyCon ( maybeTyConSingleCon, isUnboxedTupleTyCon, isEnumerationTyCon ) -import Type ( Type, typePrimRep ) -import Maybes ( assocMaybe, maybeToBool ) +import Type ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType ) +import Maybes ( maybeToBool ) +import ListSetOps ( assocMaybe ) import Unique ( mkBuiltinUnique ) import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) import Outputable @@ -84,11 +81,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 @@ -96,9 +91,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} @@ -112,16 +106,46 @@ 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 an 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 (StgPrimApp op@(CCallOp ccall) args res_ty) = primRetUnboxedTuple op args res_ty -cgExpr x@(StgCon (PrimOp op) args res_ty) +-- tagToEnum# is special: we need to pull the constructor out of the table, +-- and perform an appropriate return. + +cgExpr (StgPrimApp 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 + -- + -- 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@(StgPrimApp op args res_ty) | primOpOutOfLine op = tailCallPrimOp op args | otherwise = ASSERT(op /= SeqOp) -- can't handle SeqOp @@ -143,7 +167,6 @@ cgExpr x@(StgCon (PrimOp op) args res_ty) ReturnsAlg tycon | isUnboxedTupleTyCon tycon -> primRetUnboxedTuple op args res_ty - | isEnumerationTyCon tycon -> performReturn (COpStmt [dyn_tag] op arg_amodes [{-no vol_regs-}]) @@ -157,9 +180,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} @@ -232,7 +255,7 @@ centre. 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 @@ -255,12 +278,9 @@ cgRhs :: 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 -> + = 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 @@ -294,7 +314,7 @@ 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)) @@ -302,7 +322,7 @@ mkRhsClosure bndr cc bi srt && 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) @@ -311,7 +331,6 @@ mkRhsClosure bndr cc bi srt Just the_offset = maybe_offset offset_into_int = the_offset - fixedHdrSize is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) - tycon = dataConTyCon con \end{code} @@ -344,7 +363,7 @@ mkRhsClosure bndr cc bi srt && 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 @@ -358,8 +377,11 @@ The default case ~~~~~~~~~~~~~~~~ \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} @@ -414,7 +436,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder (StgRhsCon cc con args) = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} NoSRT 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. @@ -423,15 +445,26 @@ Little helper for primitives that return unboxed tuples. \begin{code} primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code primRetUnboxedTuple op args res_ty - = let (tc,ty_args) = case splitAlgTyConAppThroughNewTypes res_ty of - Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty) - Just pr -> pr - - prim_reps = map typePrimRep ty_args - temp_uniqs = map mkBuiltinUnique [0..length ty_args] - temp_amodes = zipWith CTemp temp_uniqs prim_reps + = getArgAmodes args `thenFC` \ arg_amodes -> + {- + 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 + in + absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC` + {- + allocate some temporaries for the return values. + -} + let + 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 - (getArgAmodes args `thenFC` \ arg_amodes -> - absC (COpStmt temp_amodes op arg_amodes [])) + returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps [])) \end{code}