import Maybes ( orElse )
import Data.List ( mapAccumL )
import Outputable
-import MonadUtils
import FastString
\end{code}
; env1 <- go (zapFloats env_with_info) triples
; return (env0 `addRecFloats` env1) }
-- addFloats adds the floats from env1,
- -- *and* updates env0 with the in-scope set from env1
+ -- _and_ updates env0 with the in-scope set from env1
where
add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
-- Add the (substituted) rules to the binder
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam tvs' body3
- ; env' <- foldlM add_poly_bind env poly_binds
+ ; let env' = foldl (addPolyBind top_lvl) env poly_binds
; return (env', rhs') }
; completeBind env' top_lvl bndr bndr1 rhs' }
- where
- add_poly_bind env (NonRec poly_id rhs)
- = completeBind env top_lvl poly_id poly_id rhs
- -- completeBind adds the new binding in the
- -- proper way (ie complete with unfolding etc),
- -- and extends the in-scope set
- add_poly_bind env bind@(Rec _)
- = return (extendFloats env bind)
- -- Hack: letrecs are more awkward, so we extend "by steam"
- -- without adding unfoldings etc. At worst this leads to
- -- more simplifier iterations
\end{code}
A specialised variant of simplNonRec used when the RHS is already simplified,
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
- | otherwise
- = let
+ | otherwise
+ = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
+ where
+ unfolding | omit_unfolding = NoUnfolding
+ | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+ wkr = substWorker env (workerInfo old_info)
+ omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr)
+
+-----------------
+addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
+-- Add a new binding to the environment, complete with its unfolding
+-- but *do not* do postInlineUnconditionally, because we have already
+-- processed some of the scope of the binding
+-- We still want the unfolding though. Consider
+-- let
+-- x = /\a. let y = ... in Just y
+-- in body
+-- Then we float the y-binding out (via abstractFloats and addPolyBind)
+-- but 'x' may well then be inlined in 'body' in which case we'd like the
+-- opportunity to inline 'y' too.
+
+addPolyBind top_lvl env (NonRec poly_id rhs)
+ = addNonRecWithUnf env poly_id rhs unfolding NoWorker
+ where
+ unfolding | not (activeInline env poly_id) = NoUnfolding
+ | otherwise = mkUnfolding (isTopLevel top_lvl) rhs
+ -- addNonRecWithInfo adds the new binding in the
+ -- proper way (ie complete with unfolding etc),
+ -- and extends the in-scope set
+
+addPolyBind _ env bind@(Rec _) = extendFloats env bind
+ -- Hack: letrecs are more awkward, so we extend "by steam"
+ -- without adding unfoldings etc. At worst this leads to
+ -- more simplifier iterations
+
+-----------------
+addNonRecWithUnf :: SimplEnv
+ -> OutId -> OutExpr -- New binder and RHS
+ -> Unfolding -> WorkerInfo -- and unfolding
+ -> SimplEnv
+-- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
+addNonRecWithUnf env new_bndr rhs unfolding wkr
+ = final_id `seq` -- This seq forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ addNonRec env final_id rhs
+ -- The addNonRec adds it to the in-scope set too
+ where
-- Arity info
- new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+ new_bndr_info = idInfo new_bndr `setArityInfo` exprArity rhs
-- Unfolding info
-- Add the unfolding *only* for non-loop-breakers
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
- `setWorkerInfo` worker_info
+ `setWorkerInfo` wkr
- final_info | omit_unfolding = new_bndr_info
- | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
+ final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
| otherwise = info_w_unf
-
+
final_id = new_bndr `setIdInfo` final_info
- in
- -- These seqs forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- final_id `seq`
- -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
- return (addNonRec env final_id new_rhs)
- -- The addNonRec adds it to the in-scope set too
- where
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- worker_info = substWorker env (workerInfo old_info)
- omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr)
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
\end{code}
simplLam env [] body cont = simplExprF env body cont
- -- Type-beta reduction
-simplLam env (bndr:bndrs) body (ApplyTo _ (Type ty_arg) arg_se cont)
- = ASSERT( isTyVar bndr )
- do { tick (BetaReduction bndr)
- ; ty_arg' <- simplType (arg_se `setInScope` env) ty_arg
- ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
-
- -- Ordinary beta reduction
+ -- Beta reduction
simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
= do { tick (BetaReduction bndr)
; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
-- Why? Because of the binder-occ-info-zapping done before
-- the call to simplLam in simplExprF (Lam ...)
- -- First deal with type lets: let a = Type ty in b
+ -- First deal with type applications and type lets
+ -- (/\a. e) (Type ty) and (let a = Type ty in e)
simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
- = do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
+ = ASSERT( isTyVar bndr )
+ do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env') dup_cont
; return (env'', app_cont, nodup_cont) }
-mkDupableCont env cont@(Select _ _ [(_, bs, _rhs)] _ _)
+mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
-- See Note [Single-alternative case]
-- | not (exprIsDupable rhs && contIsDupable case_cont)
-- | not (isDeadBinder case_bndr)
- | all isDeadBinder bs -- InIds
+ | all isDeadBinder bs -- InIds
+ && not (isUnLiftedType (idType case_bndr))
+ -- Note [Single-alternative-unlifted]
= return (env, mkBoringStop, cont)
mkDupableCont env (Select _ case_bndr alts se cont)
join_rhs = mkLams really_final_bndrs rhs'
join_call = mkApps (Var join_bndr) final_args
- ; return (addNonRec env join_bndr join_rhs, (con, bndrs', join_call)) }
+ ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
-- See Note [Duplicated env]
\end{code}
When x is inlined into its full context, we find that it was a bad
idea to have pushed the outer case inside the (...) case.
+Note [Single-alternative-unlifted]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's another single-alternative where we really want to do case-of-case:
+
+data Mk1 = Mk1 Int#
+data Mk1 = Mk2 Int#
+
+M1.f =
+ \r [x_s74 y_s6X]
+ case
+ case y_s6X of tpl_s7m {
+ M1.Mk1 ipv_s70 -> ipv_s70;
+ M1.Mk2 ipv_s72 -> ipv_s72;
+ }
+ of
+ wild_s7c
+ { __DEFAULT ->
+ case
+ case x_s74 of tpl_s7n {
+ M1.Mk1 ipv_s77 -> ipv_s77;
+ M1.Mk2 ipv_s79 -> ipv_s79;
+ }
+ of
+ wild1_s7b
+ { __DEFAULT -> ==# [wild1_s7b wild_s7c];
+ };
+ };
+
+So the outer case is doing *nothing at all*, other than serving as a
+join-point. In this case we really want to do case-of-case and decide
+whether to use a real join point or just duplicate the continuation.
+
+Hence: check whether the case binder's type is unlifted, because then
+the outer case is *not* a seq.
projects / ghc-hetmet.git / blobdiff