%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.15 1998/12/02 13:17:49 simonm Exp $
+% $Id: CgExpr.lhs,v 1.56 2003/07/02 13:19:28 simonpj Exp $
%
%********************************************************
%* *
import StgSyn
import CgMonad
import AbsCSyn
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
-import CgBindery ( getArgAmodes, CgIdInfo, nukeDeadBindings )
-import CgCase ( cgCase, saveVolatileVarsAndRegs,
- restoreCurrentCostCentre,
- splitAlgTyConAppThroughNewTypes )
+import CoreSyn ( AltCon(..) )
+import CgBindery ( getArgAmodes, getArgAmode, CgIdInfo,
+ nukeDeadBindings, addBindC, addBindsC )
+import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure, cgStdRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgLetNoEscape ( cgLetNoEscapeClosure )
import CgRetConv ( dataReturnConvPrim )
import CgTailCall ( cgTailCall, performReturn, performPrimReturn,
mkDynamicAlgReturnCode, mkPrimReturnCode,
- tailCallPrimOp, returnUnboxedTuple
+ tailCallPrimOp, ccallReturnUnboxedTuple
)
import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo,
- mkApLFInfo, layOutDynCon )
-import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
-import Id ( idPrimRep, idType, Id )
+ mkApLFInfo, layOutDynConstr )
+import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
+import Id ( idPrimRep, 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 )
-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}
%********************************************************
\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 (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 (StgOpApp op@(StgFCallOp _ _) args res_ty)
= primRetUnboxedTuple op args res_ty
-cgExpr x@(StgCon (PrimOp op) args res_ty)
- | primOpOutOfLine op = tailCallPrimOp op args
- | otherwise
- = ASSERT(op /= SeqOp) -- can't handle SeqOp
+-- tagToEnum# is special: we need to pull the constructor out of the table,
+-- and perform an appropriate return.
+
+cgExpr (StgOpApp (StgPrimOp 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
+ -- The '0' is just to get a random spare temp
+ --
+ -- 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@(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
performReturn
(COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
- (\ sequel -> mkPrimReturnCode sequel)
+ (mkPrimReturnCode (text "primapp)" <+> ppr x))
-- otherwise, must be returning an enumerated type (eg. Bool).
-- we've only got the tag in R2, so we have to load the constructor
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}
module, @CgCase@.
\begin{code}
-cgExpr (StgCase expr live_vars save_vars bndr srt alts)
- = cgCase expr live_vars save_vars bndr srt alts
+cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
+ = cgCase expr live_vars save_vars bndr srt alt_type alts
\end{code}
nukeDeadBindings live_in_whole_let `thenC`
saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
- -- ToDo: cost centre???
- restoreCurrentCostCentre maybe_cc_slot `thenFC` \ restore_cc ->
-- Save those variables right now!
absC save_assts `thenC`
cgExpr (StgSCC cc expr)
= ASSERT(sccAbleCostCentre cc)
costCentresC
- (if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
+ FSLIT("SET_CCC")
[mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
`thenC`
cgExpr expr
-- 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
-cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
+cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
= mkRhsClosure name cc bi srt fvs upd_flag args body
\end{code}
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
- (StgAlgAlts case_ty
- [(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
+ (AlgAlt tycon)
+ [(DataAlt con, params, use_mask,
+ (StgApp selectee [{-no args-}]))])
+ | 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)
- cgStdRhsClosure bndr cc bi srt [the_fv] [] body lf_info [StgVarArg the_fv]
+ = -- 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
+ 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)
- tycon = dataConTyCon con
\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
-- 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
+ 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}
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
+ where
+ lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
\end{code}
%* *
%********************************************************
\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 binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
- NonRecursive binder rhs
+ NonRecursive binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
-> FCode (Id, CgIdInfo)
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
- (StgRhsClosure cc bi srt _ upd_flag args body)
+ (StgRhsClosure cc bi _ upd_flag srt 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
(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-} 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.
\begin{code}
-primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
+primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
- = let Just (tc,ty_args) = splitAlgTyConAppThroughNewTypes res_ty
- 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_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 getAmodeRep arg_amodes
+ 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 []))
+ 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}
projects / ghc-hetmet.git / blobdiff