import CoreUtils ( coreExprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
+import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, mkVanillaId,
externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
)
import Var ( Var, varType, modifyIdInfo )
import UsageSPUtils ( primOpUsgTys )
import DataCon ( DataCon, dataConName, dataConId )
import Demand ( Demand, isStrict, wwStrict, wwLazy )
-import Name ( Name, nameModule, isLocallyDefinedName )
+import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique )
import Module ( isDynamicModule )
import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon )
import VarEnv
import PrimOp ( PrimOp(..), primOpUsg, primOpSig )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType )
+ UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType )
import TysPrim ( intPrimTy )
import UniqSupply -- all of it, really
import Util ( lengthExceeds )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( opt_D_verbose_stg2stg )
+import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn )
import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
isOnceTy :: Type -> Bool
-isOnceTy ty = case tyUsg ty of
- UsOnce -> True
- UsMany -> False
+isOnceTy ty
+ =
+#ifdef USMANY
+ opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
+#endif
+ case tyUsg ty of
+ UsOnce -> True
+ UsMany -> False
+ UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv)
bdrDem :: Id -> RhsDemand
bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id))
We reject the following candidates for 'static constructor'dom:
- any dcon that takes a lit-lit as an arg.
- - [Win32 DLLs only]: any dcon that is (or takes as arg)
- that's living in a DLL.
+ - [Win32 DLLs only]: any dcon that resides in a DLL
+ (or takes as arg something that is.)
These constraints are necessary to ensure that the code
generated in the end for the static constructors, which
_ -> False
exprToRhs dem _ expr
- = StgRhsClosure noCCS -- No cost centre (ToDo?)
- stgArgOcc -- safe
+ = upd `seq`
+ StgRhsClosure noCCS -- No cost centre (ToDo?)
+ stgArgOcc -- safe
noSRT -- figure out later
bOGUS_FVs
- (if isOnceDem dem then SingleEntry else Updatable)
- -- HA! Paydirt for "dem"
+ upd
[]
expr
+ where
+ upd = if isOnceDem dem then SingleEntry else Updatable
+ -- HA! Paydirt for "dem"
isDynCon :: DataCon -> Bool
isDynCon con = isDynName (dataConName con)
\begin{code}
coreExprToStgFloat env (Var var) dem
- = returnUs ([], StgApp (stgLookup env var) [])
+ = returnUs ([], mkStgApp (stgLookup env var) [])
coreExprToStgFloat env (Let bind body) dem
= coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
case stg_body' of
StgLam ty lam_bndrs lam_body ->
-- If the body reduced to a lambda too, join them up
- returnUs ([], StgLam expr_ty (binders' ++ lam_bndrs) lam_body)
+ returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
other ->
-- Body didn't reduce to a lambda, so return one
- returnUs ([], StgLam expr_ty binders' stg_body')
+ returnUs ([], mkStgLam expr_ty binders' stg_body')
\end{code}
(Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
returnUs (arg_floats,
- StgApp (stgLookup env fun_id) stg_args)
+ mkStgApp (stgLookup env fun_id) stg_args)
(non_var_fun, []) -> -- No value args, so recurse into the function
ASSERT( null arg_floats )
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) ->
returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
- StgApp fun_id stg_args)
+ mkStgApp fun_id stg_args)
where
-- Collect arguments and demands (*in reverse order*)
\begin{code}
coreExprToStgFloat env expr@(Con con args) dem
= let
+ expr_ty = coreExprType expr
(stricts,_) = conStrictness con
onces = case con of
DEFAULT -> panic "coreExprToStgFloat: DEFAULT"
_ -> returnUs con
) `thenUs` \ con' ->
- returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr))
+ returnUs (arg_floats, mkStgCon con' stg_atoms expr_ty)
\end{code}
(Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
= coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
where
- new_bndr = setIdType bndr ty
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
+ new_bndr = setIdType bndr ty
+ -- NB: SeqOp :: forall a. a -> Int#
+ -- So bndr has type Int#
+ -- But now we are going to scrutinise the SeqOp's argument directly,
+ -- so we must change the type of the case binder to match that
+ -- of the argument expression e. We can get this type from the argument
+ -- type of the SeqOp.
coreExprToStgFloat env
(Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem
= coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' ->
- returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr) [] (StgBindDefault default_rhs')))
+ returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs')))
where
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
| prim_case
= default_to_stg env deflt `thenUs` \ deflt' ->
mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (StgPrimAlts scrut_ty alts' deflt')
+ returnUs (mkStgPrimAlts scrut_ty alts' deflt')
| otherwise
= default_to_stg env deflt `thenUs` \ deflt' ->
mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (StgAlgAlts scrut_ty alts' deflt')
+ returnUs (mkStgAlgAlts scrut_ty alts' deflt')
alg_alt_to_stg env (DataCon con, bs, rhs)
- = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
- returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
+ = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
+ coreExprToStg env' rhs dem `thenUs` \ stg_rhs ->
+ returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
-- NB the filter isId. Some of the binders may be
-- existential type variables, which STG doesn't care about
newStgVar :: Type -> UniqSM Id
newStgVar ty
= getUniqueUs `thenUs` \ uniq ->
+ seqType ty `seq`
returnUs (mkSysLocal SLIT("stg") uniq ty)
\end{code}
\begin{code}
+{- Now redundant, I believe
-- we overload the demandInfo field of an Id to indicate whether the Id is definitely
-- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
-- some redundant cases (c.f. dataToTag# above).
new_env = extendVarEnv env id id'
in
returnUs (new_env, id')
+-}
+newEvaldLocalId env id = newLocalId NotTopLevel env id
newLocalId TopLevel env id
- = returnUs (env, id)
-- Don't clone top-level binders. MkIface relies on their
-- uniques staying the same, so it can snaffle IdInfo off the
-- STG ids to put in interface files.
+ = let
+ name = idName id
+ ty = idType id
+ in
+ name `seq`
+ seqType ty `seq`
+ returnUs (env, mkVanillaId name ty)
+
newLocalId NotTopLevel env id
= -- Local binder, give it a new unique Id.
getUniqueUs `thenUs` \ uniq ->
let
- id' = setIdUnique id uniq
- new_env = extendVarEnv env id id'
+ name = idName id
+ ty = idType id
+ new_id = mkVanillaId (setNameUnique name uniq) ty
+ new_env = extendVarEnv env id new_id
in
- returnUs (new_env, id')
+ name `seq`
+ seqType ty `seq`
+ returnUs (new_env, new_id)
newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
newLocalIds top_lev env []
\end{code}
+%************************************************************************
+%* *
+\subsection{Building STG syn}
+%* *
+%************************************************************************
+
+\begin{code}
+mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
+mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
+mkStgCon con args ty = seqType ty `seq` StgCon con args ty
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+
+mkStgApp :: Id -> [StgArg] -> StgExpr
+mkStgApp fn args = fn `seq` StgApp fn args
+ -- Force the lookup
+\end{code}
+
\begin{code}
-- Stg doesn't have a lambda *expression*,
deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
mkStgLamExpr ty bndrs body
= ASSERT( not (null bndrs) )
newStgVar ty `thenUs` \ fn ->
- returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
+ returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn []))
where
lam_closure = StgRhsClosure noCCS
stgArgOcc
projects / ghc-hetmet.git / blobdiff