import SimplUtils ( findDefault )
import CostCentre ( noCCS )
import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
- externallyVisibleId, setIdUnique, idName, getIdDemandInfo
+ externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
)
import Var ( Var, varType, modifyIdInfo )
import IdInfo ( setDemandInfo, StrictnessInfo(..) )
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 )
+import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
\end{code}
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
+exprToRhs dem _ expr
= StgRhsClosure noCCS -- No cost centre (ToDo?)
stgArgOcc -- safe
noSRT -- figure out later
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
\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
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
%* *
%************************************************************************
+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
+ new_bndr = setIdType bndr ty
+ (other_alts, maybe_default) = findDefault alts
+ Just default_rhs = maybe_default
+
+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') ->
= 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
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
projects / ghc-hetmet.git / blobdiff