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 IdInfo ( setDemandInfo, StrictnessInfo(..) )
+import IdInfo ( setDemandInfo, StrictnessInfo(..), zapIdInfoForStg )
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 )
+ UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType )
import TysPrim ( intPrimTy )
import UniqSupply -- all of it, really
import Util ( lengthExceeds )
-import BasicTypes ( TopLevelFlag(..) )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
+import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn )
+import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
\end{code}
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))
later. For this pass
we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
+When printing out the Stg we need non-bottom values in these
+locations.
+
\begin{code}
bOGUS_LVs :: StgLiveVars
-bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
+bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
+ | otherwise =panic "bOGUS_LVs"
bOGUS_FVs :: [Id]
-bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
+bOGUS_FVs | opt_D_verbose_stg2stg = []
+ | otherwise = panic "bOGUS_FVs"
\end{code}
\begin{code}
ppr b ) -- No top-level cases!
mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgNonRec bndr (exprToRhs dem new_rhs) : new_bs)
+ returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
+ : new_bs)
-- Keep all the floats inside...
-- Some might be cases etc
-- We might want to revisit this decision
do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_expr) ->
mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
-- NB: stg_expr' might still be a StgLam (and we want that)
- returnUs (exprToRhs dem stg_expr')
+ returnUs (exprToRhs dem top_lev stg_expr')
where
dem = bdrDem bndr
\end{code}
%************************************************************************
\begin{code}
-exprToRhs :: RhsDemand -> StgExpr -> StgRhs
-exprToRhs dem (StgLam _ bndrs body)
+exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
+exprToRhs dem _ (StgLam _ bndrs body)
= ASSERT( not (null bndrs) )
StgRhsClosure noCCS
stgArgOcc
constructors (ala C++ static class constructors) which will
then be run at load time to fix up static closures.
-}
-exprToRhs dem (StgCon (DataCon con) args _)
- | not is_dynamic &&
- all (not.is_lit_lit) args = StgRhsCon noCCS con args
+exprToRhs dem toplev (StgCon (DataCon con) args _)
+ | isNotTopLevel toplev ||
+ (not is_dynamic &&
+ all (not.is_lit_lit) args) = StgRhsCon noCCS con args
where
is_dynamic = isDynCon con || any (isDynArg) args
Literal l -> isLitLitLit l
_ -> False
-exprToRhs dem expr
- = StgRhsClosure noCCS -- No cost centre (ToDo?)
- stgArgOcc -- safe
+exprToRhs dem _ expr
+ = 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}
= 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
mk_stg_let bndr rhs dem floats body
#endif
- | isUnLiftedType bndr_ty -- Use a case/PrimAlts
- = ASSERT( not (isUnboxedTupleType bndr_ty) )
+ | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
+ = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
mkStgBinds floats $
- mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
| is_whnf
= if is_strict then
-- Strict let with WHNF rhs
mkStgBinds floats $
- StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
+ StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
else
-- Lazy let with WHNF rhs; float until we find a strict binding
let
in
mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
mkStgBinds floats_out $
- StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body
+ StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
| otherwise -- Not WHNF
= if is_strict then
-- Strict let with non-WHNF rhs
mkStgBinds floats $
- mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
else
-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body)
+ returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
where
- bndr_ty = idType bndr
- is_strict = isStrictDem dem
- is_whnf = case rhs of
- StgCon _ _ _ -> True
- StgLam _ _ _ -> True
- other -> False
+ bndr_rep_ty = repType (idType bndr)
+ is_strict = isStrictDem dem
+ is_whnf = case rhs of
+ StgCon _ _ _ -> True
+ StgLam _ _ _ -> True
+ other -> False
-- Split at the first strict binding
splitFloats fs@(NonRecF _ _ dem _ : _)
projects / ghc-hetmet.git / blobdiff