import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,
opt_SimplNoPreInlining,
+ dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion, findAlt,
- simplBinder, simplBinders, simplIds, findDefault,
+import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
+ simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinder,
SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
contResultType, discardInline, countArgs, contIsDupable,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
-import Var ( mkSysTyVar, tyVarKind )
+import Var ( mkSysTyVar, tyVarKind, mustHaveLocalBinding )
import VarEnv
-import VarSet ( elemVarSet )
-import Id ( Id, idType, idInfo, isDataConId,
+import Literal ( Literal )
+import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,
idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
- idDemandInfo, setIdInfo,
- idOccInfo, setIdOccInfo,
+ idNewDemandInfo, setIdInfo,
+ idOccInfo, setIdOccInfo,
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
setArityInfo,
- setUnfoldingInfo, atLeastArity,
+ setUnfoldingInfo,
occInfo
)
-import Demand ( isStrict )
+import NewDemand ( isStrictDmd )
import DataCon ( dataConNumInstArgs, dataConRepStrictness,
dataConSig, dataConArgTys
)
import CoreSyn
-import CoreFVs ( mustHaveLocalBinding, exprFreeVars )
+import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
callSiteInline
)
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
- exprIsConApp_maybe, mkPiType,
+ exprIsConApp_maybe, mkPiType, findAlt, findDefault,
exprType, coreAltsType, exprIsValue,
- exprOkForSpeculation, exprArity, exprIsCheap,
+ exprOkForSpeculation, exprArity,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
import Rules ( lookupRule )
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
mkFunTy, splitTyConApp_maybe, tyConAppArgs,
- funResultTy
+ funResultTy, splitFunTy_maybe, splitFunTy, eqType
)
-import Subst ( mkSubst, substTy,
- isInScope, lookupIdSubst, substIdInfo
+import Subst ( mkSubst, substTy, substEnv, substExpr,
+ isInScope, lookupIdSubst, simplIdInfo
)
import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import OrdList
import Maybes ( maybeToBool )
-import Util ( zipWithEqual )
import Outputable
\end{code}
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- simplIds (bindersOfBinds binds) $ \ bndrs' ->
+ simplRecIds (bindersOfBinds binds) $ \ bndrs' ->
simpl_binds binds bndrs' `thenSmpl` \ (binds', _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (fromOL binds')
simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
-- Simplify an expression, returning floated binds
-simplExprF (Var v) cont
- = simplVar v cont
-
-simplExprF (Lit lit) (Select _ bndr alts se cont)
- = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
-
-simplExprF (Lit lit) cont
- = rebuild (Lit lit) cont
+simplExprF (Var v) cont = simplVar v cont
+simplExprF (Lit lit) cont = simplLit lit cont
+simplExprF expr@(Lam _ _) cont = simplLam expr cont
+simplExprF (Note note expr) cont = simplNote note expr cont
simplExprF (App fun arg) cont
= getSubstEnv `thenSmpl` \ se ->
simplExprF fun (ApplyTo NoDup arg se cont)
+simplExprF (Type ty) cont
+ = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
+ simplType ty `thenSmpl` \ ty' ->
+ rebuild (Type ty') cont
+
simplExprF (Case scrut bndr alts) cont
= getSubstEnv `thenSmpl` \ subst_env ->
getSwitchChecker `thenSmpl` \ chkr ->
(mkStop (contResultType cont))) `thenSmpl` \ case_expr' ->
rebuild case_expr' cont
-
simplExprF (Let (Rec pairs) body) cont
- = simplIds (map fst pairs) $ \ bndrs' ->
+ = simplRecIds (map fst pairs) $ \ bndrs' ->
-- NB: bndrs' don't have unfoldings or spec-envs
-- We add them as we go down, using simplPrags
simplRecBind False pairs bndrs' (simplExprF body cont)
-simplExprF expr@(Lam _ _) cont = simplLam expr cont
-
-simplExprF (Type ty) cont
- = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
- simplType ty `thenSmpl` \ ty' ->
- rebuild (Type ty') cont
-
--- Comments about the Coerce case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- It's worth checking for a coerce in the continuation,
--- in case we can cancel them. For example, in the initial form of a worker
--- we may find (coerce T (coerce S (\x.e))) y
--- and we'd like it to simplify to e[y/x] in one round of simplification
-
-simplExprF (Note (Coerce to from) e) (CoerceIt outer_to cont)
- = simplType from `thenSmpl` \ from' ->
- if outer_to == from' then
- -- The coerces cancel out
- simplExprF e cont
- else
- -- They don't cancel, but the inner one is redundant
- simplExprF e (CoerceIt outer_to cont)
-
-simplExprF (Note (Coerce to from) e) cont
- = simplType to `thenSmpl` \ to' ->
- simplExprF e (CoerceIt to' cont)
-
--- hack: we only distinguish subsumed cost centre stacks for the purposes of
--- inlining. All other CCCSs are mapped to currentCCS.
-simplExprF (Note (SCC cc) e) cont
- = setEnclosingCC currentCCS $
- simplExpr e `thenSmpl` \ e ->
- rebuild (mkSCC cc e) cont
-
-simplExprF (Note InlineCall e) cont
- = simplExprF e (InlinePlease cont)
+-- A non-recursive let is dealt with by simplNonRecBind
+simplExprF (Let (NonRec bndr rhs) body) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplNonRecBind bndr rhs se (contResultType cont) $
+ simplExprF body cont
--- Comments about the InlineMe case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Don't inline in the RHS of something that has an
--- inline pragma. But be careful that the InScopeEnv that
--- we return does still have inlinings on!
---
--- It really is important to switch off inlinings. This function
--- may be inlinined in other modules, so we don't want to remove
--- (by inlining) calls to functions that have specialisations, or
--- that may have transformation rules in an importing scope.
--- E.g. {-# INLINE f #-}
--- f x = ...g...
--- and suppose that g is strict *and* has specialisations.
--- If we inline g's wrapper, we deny f the chance of getting
--- the specialised version of g when f is inlined at some call site
--- (perhaps in some other module).
--- It's also important not to inline a worker back into a wrapper.
--- A wrapper looks like
--- wraper = inline_me (\x -> ...worker... )
--- Normally, the inline_me prevents the worker getting inlined into
--- the wrapper (initially, the worker's only call site!). But,
--- if the wrapper is sure to be called, the strictness analyser will
--- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
--- continuation. That's why the keep_inline predicate returns True for
--- ArgOf continuations. It shouldn't do any harm not to dissolve the
--- inline-me note under these circumstances
+---------------------------------
+simplType :: InType -> SimplM OutType
+simplType ty
+ = getSubst `thenSmpl` \ subst ->
+ let
+ new_ty = substTy subst ty
+ in
+ seqType new_ty `seq`
+ returnSmpl new_ty
-simplExprF (Note InlineMe e) cont
- | keep_inline cont -- Totally boring continuation
- = -- Don't inline inside an INLINE expression
- setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' ->
- rebuild (mkInlineMe e') cont
+---------------------------------
+simplLit :: Literal -> SimplCont -> SimplM OutExprStuff
- | otherwise -- Dissolve the InlineMe note if there's
- -- an interesting context of any kind to combine with
- -- (even a type application -- anything except Stop)
- = simplExprF e cont
- where
- keep_inline (Stop _ _) = True -- See notes above
- keep_inline (ArgOf _ _ _) = True -- about this predicate
- keep_inline other = False
+simplLit lit (Select _ bndr alts se cont)
+ = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
--- A non-recursive let is dealt with by simplBeta
-simplExprF (Let (NonRec bndr rhs) body) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplBeta bndr rhs se (contResultType cont) $
- simplExprF body cont
+simplLit lit cont = rebuild (Lit lit) cont
\end{code}
----------------------------------
+%************************************************************************
+%* *
+\subsection{Lambdas}
+%* *
+%************************************************************************
\begin{code}
simplLam fun cont
-- Ordinary beta reduction
go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
= tick (BetaReduction bndr) `thenSmpl_`
- simplBeta zapped_bndr arg arg_se cont_ty
+ simplNonRecBind zapped_bndr arg arg_se cont_ty
(go body body_cont)
where
zapped_bndr = zap_it bndr
-- to avoid allocating this thing altogether
completeLam rev_bndrs (Lam bndr body) cont
- = simplBinder bndr $ \ bndr' ->
+ = simplLamBinder bndr $ \ bndr' ->
completeLam (bndr':rev_bndrs) body cont
completeLam rev_bndrs body cont
Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
where
-- We don't use CoreUtils.etaReduce, because we can be more
- -- efficient here: (a) we already have the binders, (b) we can do
- -- the triviality test before computing the free vars
+ -- efficient here:
+ -- (a) we already have the binders,
+ -- (b) we can do the triviality test before computing the free vars
+ -- [in fact I take the simple path and look for just a variable]
+ -- (c) we don't want to eta-reduce a data con worker or primop
+ -- because we only have to eta-expand them later when we saturate
try_eta body | not opt_SimplDoEtaReduction = Nothing
| otherwise = go rev_bndrs body
go [] body | ok_body body = Just body -- Success!
go _ _ = Nothing -- Failure!
- ok_body body = exprIsTrivial body && not (any (`elemVarSet` exprFreeVars body) rev_bndrs)
- ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+ ok_body (Var v) = not (v `elem` rev_bndrs) && not (hasNoBinding v)
+ ok_body other = False
+ ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
mkLamBndrZapper :: CoreExpr -- Function
-> SimplCont -- The context
\end{code}
----------------------------------
+%************************************************************************
+%* *
+\subsection{Notes}
+%* *
+%************************************************************************
+
\begin{code}
-simplType :: InType -> SimplM OutType
-simplType ty
- = getSubst `thenSmpl` \ subst ->
+simplNote (Coerce to from) body cont
+ = getInScope `thenSmpl` \ in_scope ->
let
- new_ty = substTy subst ty
+ addCoerce s1 k1 (CoerceIt t1 cont)
+ -- coerce T1 S1 (coerce S1 K1 e)
+ -- ==>
+ -- e, if T1=K1
+ -- coerce T1 K1 e, otherwise
+ --
+ -- For example, in the initial form of a worker
+ -- we may find (coerce T (coerce S (\x.e))) y
+ -- and we'd like it to simplify to e[y/x] in one round
+ -- of simplification
+ | t1 `eqType` k1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt t1 cont -- They don't cancel, but
+ -- the inner one is redundant
+
+ addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
+ | Just (s1, s2) <- splitFunTy_maybe s1s2
+ -- (coerce (T1->T2) (S1->S2) F) E
+ -- ===>
+ -- coerce T2 S2 (F (coerce S1 T1 E))
+ --
+ -- t1t2 must be a function type, T1->T2
+ -- but s1s2 might conceivably not be
+ --
+ -- When we build the ApplyTo we can't mix the out-types
+ -- with the InExpr in the argument, so we simply substitute
+ -- to make it all consistent. This isn't a common case.
+ = let
+ (t1,t2) = splitFunTy t1t2
+ new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope arg_se) arg)
+ in
+ ApplyTo dup new_arg emptySubstEnv (addCoerce t2 s2 cont)
+
+ addCoerce to' _ cont = CoerceIt to' cont
in
- seqType new_ty `seq`
- returnSmpl new_ty
+ simplType to `thenSmpl` \ to' ->
+ simplType from `thenSmpl` \ from' ->
+ simplExprF body (addCoerce to' from' cont)
+
+
+-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
+-- inlining. All other CCCSs are mapped to currentCCS.
+simplNote (SCC cc) e cont
+ = setEnclosingCC currentCCS $
+ simplExpr e `thenSmpl` \ e ->
+ rebuild (mkSCC cc e) cont
+
+simplNote InlineCall e cont
+ = simplExprF e (InlinePlease cont)
+
+-- Comments about the InlineMe case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Don't inline in the RHS of something that has an
+-- inline pragma. But be careful that the InScopeEnv that
+-- we return does still have inlinings on!
+--
+-- It really is important to switch off inlinings. This function
+-- may be inlinined in other modules, so we don't want to remove
+-- (by inlining) calls to functions that have specialisations, or
+-- that may have transformation rules in an importing scope.
+-- E.g. {-# INLINE f #-}
+-- f x = ...g...
+-- and suppose that g is strict *and* has specialisations.
+-- If we inline g's wrapper, we deny f the chance of getting
+-- the specialised version of g when f is inlined at some call site
+-- (perhaps in some other module).
+
+-- It's also important not to inline a worker back into a wrapper.
+-- A wrapper looks like
+-- wraper = inline_me (\x -> ...worker... )
+-- Normally, the inline_me prevents the worker getting inlined into
+-- the wrapper (initially, the worker's only call site!). But,
+-- if the wrapper is sure to be called, the strictness analyser will
+-- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+-- continuation. That's why the keep_inline predicate returns True for
+-- ArgOf continuations. It shouldn't do any harm not to dissolve the
+-- inline-me note under these circumstances
+
+simplNote InlineMe e cont
+ | keep_inline cont -- Totally boring continuation
+ = -- Don't inline inside an INLINE expression
+ noInlineBlackList `thenSmpl` \ bl ->
+ setBlackList bl (simplExpr e) `thenSmpl` \ e' ->
+ rebuild (mkInlineMe e') cont
+
+ | otherwise -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ = simplExprF e cont
+ where
+ keep_inline (Stop _ _) = True -- See notes above
+ keep_inline (ArgOf _ _ _) = True -- about this predicate
+ keep_inline other = False
\end{code}
%* *
%************************************************************************
-@simplBeta@ is used for non-recursive lets in expressions,
+@simplNonRecBind@ is used for non-recursive lets in expressions,
as well as true beta reduction.
Very similar to @simplLazyBind@, but not quite the same.
\begin{code}
-simplBeta :: InId -- Binder
+simplNonRecBind :: InId -- Binder
-> InExpr -> SubstEnv -- Arg, with its subst-env
-> OutType -- Type of thing computed by the context
-> SimplM OutExprStuff -- The body
-> SimplM OutExprStuff
#ifdef DEBUG
-simplBeta bndr rhs rhs_se cont_ty thing_inside
+simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| isTyVar bndr
- = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
+ = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
#endif
-simplBeta bndr rhs rhs_se cont_ty thing_inside
+simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally False {- not black listed -} bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
extendSubst bndr (ContEx rhs_se rhs) thing_inside
| otherwise
- = -- Simplify the RHS
- simplBinder bndr $ \ bndr' ->
+ = -- Simplify the binder.
+ -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId bndr $ \ bndr' ->
+ getSubst `thenSmpl` \ bndr_subst ->
let
+ -- Substitute its IdInfo (which simplLetId does not)
+ -- The appropriate substitution env is the one right here,
+ -- not rhs_se. Often they are the same, when all this
+ -- has arisen from an application (\x. E) RHS, perhaps they aren't
+ bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr'
bndr_ty' = idType bndr'
- is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
+ is_strict = isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty'
in
+ modifyInScope bndr'' bndr'' $
+
+ -- Simplify the argument
simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-- Now complete the binding and simplify the body
if needsCaseBinding bndr_ty' rhs' then
- addCaseBind bndr' rhs' thing_inside
+ addCaseBind bndr'' rhs' thing_inside
else
- completeBinding bndr bndr' False False rhs' thing_inside
+ completeBinding bndr bndr'' False False rhs' thing_inside
\end{code}
thing_inside
| otherwise
- = getSubst `thenSmpl` \ subst ->
- let
+ = let
-- We make new IdInfo for the new binder by starting from the old binder,
-- doing appropriate substitutions.
-- Then we add arity and unfolding info to get the new binder
- new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
- `setArityInfo` arity_info
+ new_bndr_info = idInfo new_bndr `setArityInfo` arity
-- Add the unfolding *only* for non-loop-breakers
-- Making loop breakers not have an unfolding at all
loop_breaker = isLoopBreaker occ_info
trivial_rhs = exprIsTrivial new_rhs
must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
- arity_info = atLeastArity (exprArity new_rhs)
+ arity = exprArity new_rhs
\end{code}
else
-- Simplify the RHS
- getSubstEnv `thenSmpl` \ rhs_se ->
+ getSubst `thenSmpl` \ rhs_subst ->
+ let
+ -- Substitute IdInfo on binder, in the light of earlier
+ -- substitutions in this very letrec, and extend the in-scope
+ -- env so that it can see the new thing
+ bndr'' = simplIdInfo rhs_subst (idInfo bndr) bndr'
+ in
+ modifyInScope bndr'' bndr'' $
+
simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
(idType bndr')
- rhs rhs_se $ \ rhs' ->
+ rhs (substEnv rhs_subst) $ \ rhs' ->
-- Now compete the binding and simplify the body
- completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside
+ completeBinding bndr bndr'' top_lvl black_listed rhs' thing_inside
\end{code}
let
(floats2, rhs2) = splitFloats float_ubx floats1 rhs1
in
- -- There's a subtlety here. There may be a binding (x* = e) in the
- -- floats, where the '*' means 'will be demanded'. So is it safe
- -- to float it out? Answer no, but it won't matter because
- -- we only float if arg' is a WHNF,
- -- and so there can't be any 'will be demanded' bindings in the floats.
- -- Hence the assert
- WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) )
-
-- Transform the RHS
-- It's important that we do eta expansion on function *arguments* (which are
-- simplified with simplRhs), as well as let-bound right-hand sides.
-- Float lets if (a) we're at the top level
-- or (b) the resulting RHS is one we'd like to expose
- if (top_lvl || exprIsCheap rhs4) then
+ --
+ -- NB: the test used to say "exprIsCheap", but that caused a strictness bug.
+ -- x = let y* = E in case (scc y) of { T -> F; F -> T}
+ -- The case expression is 'cheap', but it's wrong to transform to
+ -- y* = E; x = case (scc y) of {...}
+ -- Either we must be careful not to float demanded non-values, or
+ -- we must use exprIsValue for the test, which ensures that the
+ -- thing is non-strict. I think. The WARN below tests for this
+ if (top_lvl || exprIsValue rhs4) then
+
+ -- There's a subtlety here. There may be a binding (x* = e) in the
+ -- floats, where the '*' means 'will be demanded'. So is it safe
+ -- to float it out? Answer no, but it won't matter because
+ -- we only float if arg' is a WHNF,
+ -- and so there can't be any 'will be demanded' bindings in the floats.
+ -- Hence the assert
+ WARN( any demanded_float (fromOL floats2),
+ ppr (filter demanded_float (fromOL floats2)) )
+
(if (isNilOL floats2 && null floats3 && null floats4) then
returnSmpl ()
else
-- Don't do the float
thing_inside (wrapFloats floats1 rhs1)
-demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b))
+demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
-- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
demanded_float (Rec _) = False
-- won't occur for things that have specialisations till a later phase, so
-- it's ok to try for inlining first.
--
- -- Don't apply rules for a loop breaker: doing so might give rise
- -- to an infinite loop, for the same reasons that inlining the ordinary
- -- RHS of a loop breaker might.
+ -- You might think that we shouldn't apply rules for a loop breaker:
+ -- doing so might give rise to an infinite loop, because a RULE is
+ -- rather like an extra equation for the function:
+ -- RULE: f (g x) y = x+y
+ -- Eqn: f a y = a-y
+ --
+ -- But it's too drastic to disable rules for loop breakers.
+ -- Even the foldr/build rule would be disabled, because foldr
+ -- is recursive, and hence a loop breaker:
+ -- foldr k z (build g) = g k z
+ -- So it's up to the programmer: rules can cause divergence
getSwitchChecker `thenSmpl` \ chkr ->
let
- maybe_rule | switchIsOn chkr DontApplyRules
- || isLoopBreaker occ_info = Nothing
+ maybe_rule | switchIsOn chkr DontApplyRules = Nothing
| otherwise = lookupRule in_scope var args'
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
tick (RuleFired rule_name) `thenSmpl_`
+#ifdef DEBUG
+ (if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Rule fired" (vcat [
+ text "Rule:" <+> ptext rule_name,
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args'),
+ text "After: " <+> pprCoreExpr rule_rhs])
+ else
+ id) $
+#endif
simplExprF rule_rhs call_cont ;
Nothing -> -- No rules
-- Even though x get's an occurrence of 'many', its RHS looks cheap,
-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
= getBlackList `thenSmpl` \ old_bl ->
- setBlackList noInlineBlackList $
+ noInlineBlackList `thenSmpl` \ ni_bl ->
+ setBlackList ni_bl $
go args $ \ args' ->
setBlackList old_bl $
thing_inside args'
(rhs1:other_rhss) = rhssOfAlts alts
binders_unused (_, bndrs, _) = all isDeadBinder bndrs
- var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later
+ var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo bndr) -- It's going to be evaluated later
var_demanded_later other = False
-> SimplM OutExprStuff
knownCon expr con args bndr alts se cont
- = tick (KnownBranch bndr) `thenSmpl_`
+ = -- Arguments should be atomic;
+ -- yell if not
+ WARN( not (all exprIsTrivial args),
+ text "knownCon" <+> ppr expr )
+ tick (KnownBranch bndr) `thenSmpl_`
setSubstEnv se (
simplBinder bndr $ \ bndr' ->
completeBinding bndr bndr' False False expr $
let
(_,_,ex_tyvars,_,_,_) = dataConSig data_con
in
- getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
+ getUniquesSmpl `thenSmpl` \ tv_uniqs ->
let
- ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+ ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys data_con
(inst_tys ++ mkTyVarTys ex_tyvars')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
- handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
+ (con_alts,_) = findDefault alts
+ handled_cons = scrut_cons ++ [con | (con,_,_) <- con_alts]
simpl_alt (DEFAULT, _, rhs)
= -- In the default case we record the constructors that the
cat_evals [] [] = []
cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
- | otherwise = v' : cat_evals vs strs
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isStrictDmd str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
+ | otherwise = v' : cat_evals vs strs
where
v' = zap_occ_info v
\end{code}
-- Consider: let j = if .. then I# 3 else I# 4
-- in case .. of { A -> j; B -> j; C -> ... }
--
- -- Now CPR should not w/w j because it's a thunk, so
+ -- Now CPR doesn't w/w j because it's a thunk, so
-- that means that the enclosing function can't w/w either,
-- which is a lose. Here's the example that happened in practice:
-- kgmod :: Int -> Int -> Int
-- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
-- then 78
-- else 5
+ --
+ -- I have seen a case alternative like this:
+ -- True -> \v -> ...
+ -- It's a bit silly to add the realWorld dummy arg in this case, making
+ -- $j = \s v -> ...
+ -- True -> $j s
+ -- (the \v alone is enough to make CPR happy) but I think it's rare
then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
projects / ghc-hetmet.git / blobdiff