%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.22 1999/03/25 13:13:51 simonm Exp $
+% $Id: CgExpr.lhs,v 1.31 2000/03/23 17:45:19 simonpj 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, freeCostCentreSlot,
- splitTyConAppThroughNewTypes )
+ restoreCurrentCostCentre )
import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgLetNoEscape ( cgLetNoEscapeClosure )
import Id ( idPrimRep, idType, Id )
import VarSet
import DataCon ( DataCon, dataConTyCon )
-import Const ( Con(..) )
import IdInfo ( ArityInfo(..) )
-import PrimOp ( primOpOutOfLine,
+import PrimOp ( primOpOutOfLine, ccallMayGC,
getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
)
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import TyCon ( maybeTyConSingleCon,
isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type ( Type, typePrimRep )
+import Type ( Type, typePrimRep, splitTyConApp_maybe, repType )
import Maybes ( assocMaybe, maybeToBool )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
%********************************************************
\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
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}
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.
+ --
+ (Just (tycon,_)) = splitTyConApp_maybe res_ty
+
+
+cgExpr x@(StgPrimApp op args res_ty)
| primOpOutOfLine op = tailCallPrimOp op args
| otherwise
= ASSERT(op /= SeqOp) -- can't handle SeqOp
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}
saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
-- ToDo: cost centre???
- freeCostCentreSlot maybe_cc_slot `thenC`
restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
-- Save those variables right now!
-- 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
(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.
allocate some temporaries for the return values.
-}
let
- (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of
+ (tc,ty_args) = case splitTyConApp_maybe (repType res_ty) of
Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
Just pr -> pr
prim_reps = map typePrimRep ty_args
temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
-
\end{code}
projects / ghc-hetmet.git / blobdiff