import CoreUtils ( coreExprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
- externallyVisibleId, setIdUnique, idName, getIdDemandInfo
+import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, mkVanillaId,
+ externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
)
import Var ( Var, varType, modifyIdInfo )
import IdInfo ( setDemandInfo, StrictnessInfo(..) )
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
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
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) ->
returnUs (new_bind:floats, stg_body)
\end{code}
-Covert core @scc@ expression directly to STG @scc@ expression.
+Convert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
coreExprToStgFloat env (Note (SCC cc) expr) dem
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}
\begin{code}
coreExprToStgFloat env expr@(App _ _) dem
= let
- (fun,rads,_,_) = collect_args expr
- ads = reverse rads
+ (fun,rads,_,ss) = collect_args expr
+ ads = reverse rads
+ final_ads | null ss = ads
+ | otherwise = zap ads -- Too few args to satisfy strictness info
+ -- so we have to ignore all the strictness info
+ -- e.g. + (error "urk")
+ -- Here, we can't evaluate the arg strictly,
+ -- because this partial application might be seq'd
in
- coreArgsToStg env ads `thenUs` \ (arg_floats, stg_args) ->
+ coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
-- Now deal with the function
case (fun, stg_args) of
(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*)
collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
in (the_fun,ads,applyTy fun_ty tyarg,ss)
collect_args (App fun arg)
- = case ss of
- [] -> -- Strictness info has run out
- (the_fun, (arg, mkDemTy wwLazy arg_ty) : zap ads, res_ty, repeat wwLazy)
- (ss1:ss_rest) -> -- Enough strictness info
- (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
+ = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
where
+ (ss1, ss_rest) = case ss of
+ (ss1:ss_rest) -> (ss1, ss_rest)
+ [] -> (wwLazy, [])
(the_fun, ads, fun_ty, ss) = collect_args fun
(arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
splitFunTy_maybe fun_ty
\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}
%* *
%************************************************************************
+First, two special cases. We mangle cases involving
+ par# and seq#
+inthe scrutinee.
+
+Up to this point, seq# will appear like this:
+
+ case seq# e of
+ 0# -> seqError#
+ _ -> <stuff>
+
+This code comes from an unfolding for 'seq' in Prelude.hs.
+The 0# branch is purely to bamboozle the strictness analyser.
+For example, if <stuff> is strict in x, and there was no seqError#
+branch, the strictness analyser would conclude that the whole expression
+was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
+
+Now that the evaluation order is safe, we translate this into
+
+ case e of
+ _ -> ...
+
+This used to be done in the post-simplification phase, but we need
+unfoldings involving seq# to appear unmangled in the interface file,
+hence we do this mangling here.
+
+Similarly, par# has an unfolding in PrelConc.lhs that makes it show
+up like this:
+
+ case par# e of
+ 0# -> rhs
+ _ -> parError#
+
+
+ ==>
+ case par# e of
+ _ -> rhs
+
+fork# isn't handled like this - it's an explicit IO operation now.
+The reason is that fork# returns a ThreadId#, which gets in the
+way of the above scheme. And anyway, IO is the only guaranteed
+way to enforce ordering --SDM.
+
+
+\begin{code}
+coreExprToStgFloat env
+ (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
+ = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
+ where
+ (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
+ | maybeToBool maybe_default
+ = 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')))
+ where
+ (other_alts, maybe_default) = findDefault alts
+ Just default_rhs = maybe_default
+\end{code}
+
+Now for normal case expressions...
+
\begin{code}
coreExprToStgFloat env (Case scrut bndr alts) dem
= coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
| 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