RecFlag(..), isNonRuleLoopBreaker )
import Maybes ( orElse )
import Data.List ( mapAccumL )
+import MonadUtils ( foldlM )
+import StaticFlags ( opt_PassCaseBndrToJoinPoints )
import Outputable
import FastString
\end{code}
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam tvs' body3
- ; let env' = foldl (addPolyBind top_lvl) env poly_binds
+ ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
; return (env', rhs') }
; completeBind env' top_lvl bndr bndr1 rhs' }
-- * or by adding to the floats in the envt
completeBind env top_lvl old_bndr new_bndr new_rhs
- | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
- -- Inline and discard the binding
- = do { tick (PostInlineUnconditionally old_bndr)
- ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
- return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
- -- Use the substitution to make quite, quite sure that the
- -- substitution will happen, since we are going to discard the binding
+ = do { let old_info = idInfo old_bndr
+ old_unf = unfoldingInfo old_info
+ occ_info = occInfo old_info
- | 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
- -- or not (activeInline env old_bndr)
- -- Do *not* trim the unfolding in SimplGently, else
- -- the specialiser can't see it!
-
------------------
-addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
+ ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info old_unf new_rhs
+
+ ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
+ -- Inline and discard the binding
+ then do { tick (PostInlineUnconditionally old_bndr)
+ ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+ -- Use the substitution to make quite, quite sure that the
+ -- substitution will happen, since we are going to discard the binding
+
+ else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
+
+------------------------------
+addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM 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
-- 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
+ = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo noUnfolding rhs
+ -- Assumes that poly_id did not have an INLINE prag
+ -- which is perhaps wrong. ToDo: think about this
+ ; return (addNonRecWithUnf env poly_id rhs unfolding) }
-addPolyBind _ env bind@(Rec _) = extendFloats env bind
+addPolyBind _ 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
------------------
+------------------------------
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
- = ASSERT( isId new_bndr )
- WARN( new_arity < old_arity || new_arity < dmd_arity,
- (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
- 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
- dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+ -> OutId -> OutExpr -- New binder and RHS
+ -> Unfolding -- New unfolding
+ -> SimplEnv
+addNonRecWithUnf env new_bndr new_rhs new_unfolding
+ = let new_arity = exprArity new_rhs
old_arity = idArity new_bndr
-
- -- Arity info
- new_arity = exprArity rhs
- new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
-
- -- Unfolding info
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
-
- -- Demand info
- -- If the unfolding is a value, the demand info may
- -- go pear-shaped, so we nuke it. Example:
- -- let x = (a,b) in
- -- case x of (p,q) -> h p q x
- -- Here x is certainly demanded. But after we've nuked
- -- the case, we'll get just
- -- let x = (a,b) in h a b x
- -- and now x is not demanded (I'm assuming h is lazy)
- -- This really happens. Similarly
- -- let f = \x -> e in ...f..f...
- -- After inlining f at some of its call sites the original binding may
- -- (for example) be no longer strictly demanded.
- -- The solution here is a bit ad hoc...
- info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
- `setWorkerInfo` wkr
-
- final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
- | otherwise = info_w_unf
+ info1 = idInfo new_bndr `setArityInfo` new_arity
- final_id = new_bndr `setIdInfo` final_info
+ -- Unfolding info: Note [Setting the new unfolding]
+ info2 = info1 `setUnfoldingInfo` new_unfolding
+
+ -- Demand info: Note [Setting the demand info]
+ info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
+ | otherwise = info2
+
+ final_id = new_bndr `setIdInfo` info3
+ dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+ in
+ ASSERT( isId new_bndr )
+ WARN( new_arity < old_arity || new_arity < dmd_arity,
+ (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs )
+
+ final_id `seq` -- This seq forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+ addNonRec env final_id new_rhs
+ -- The addNonRec adds it to the in-scope set too
+
+
+------------------------------
+simplUnfolding :: SimplEnv-> TopLevelFlag
+ -> Id -- Debug output only
+ -> OccInfo -> Unfolding -> OutExpr
+ -> SimplM Unfolding
+simplUnfolding env top_lvl bndr occ_info old_unf new_rhs -- Note [Setting the new unfolding]
+ | omit_unfolding = WARN( is_inline_rule, ppr bndr ) return NoUnfolding
+ | is_inline_rule = return (substUnfolding env is_top_lvl old_unf)
+ | otherwise = return (mkUnfolding is_top_lvl new_rhs)
+ where
+ is_top_lvl = isTopLevel top_lvl
+ is_inline_rule = isInlineRule old_unf
+ omit_unfolding = isNonRuleLoopBreaker occ_info
\end{code}
+Note [Setting the new unfolding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* If there's an INLINE pragma, we use substUnfolding to retain the
+ supplied inlining
+
+* If not, we make an unfolding from the new RHS. But *only* for
+ non-loop-breakers. Making loop breakers not have an unfolding at all
+ means that we can avoid tests in exprIsConApp, for example. This is
+ important: if exprIsConApp says 'yes' for a recursive thing, then we
+ can get into an infinite loop
+
+If there's an INLINE pragma on a loop breaker, we simply discard it
+(with a DEBUG warning). The desugarer complains about binding groups
+that look likely to trigger this behaviour.
+
+
+Note [Setting the demand info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the unfolding is a value, the demand info may
+go pear-shaped, so we nuke it. Example:
+ let x = (a,b) in
+ case x of (p,q) -> h p q x
+Here x is certainly demanded. But after we've nuked
+the case, we'll get just
+ let x = (a,b) in h a b x
+and now x is not demanded (I'm assuming h is lazy)
+This really happens. Similarly
+ let f = \x -> e in ...f..f...
+After inlining f at some of its call sites the original binding may
+(for example) be no longer strictly demanded.
+The solution here is a bit ad hoc...
+
%************************************************************************
%* *
------------------
simplNonRecE :: SimplEnv
- -> InId -- The binder
+ -> InBndr -- The binder
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
-> ([InBndr], InExpr) -- Body of the let/lambda
-- \xs.e
= do { e' <- simplExpr (setEnclosingCC env currentCCS) e
; rebuild env (mkSCC cc e') cont }
--- See notes with SimplMonad.inlineMode
-simplNote env InlineMe e cont
- | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
- = do { -- Don't inline inside an INLINE expression
- e' <- simplExprC (setMode inlineMode env) e inside
- ; rebuild env (mkInlineMe e') outside }
-
- | 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 env e cont
-
-simplNote env (CoreNote s) e cont = do
- e' <- simplExpr env e
- rebuild env (Note (CoreNote s) e') cont
+simplNote env (CoreNote s) e cont
+ = do { e' <- simplExpr env e
+ ; rebuild env (Note (CoreNote s) e') cont }
\end{code}
Just unfolding -- There is an inlining!
-> do { tick (UnfoldingDone var)
; (if dopt Opt_D_dump_inlinings dflags then
- pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
+ pprTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr call_cont])
after the outer case, and that makes (a,b) alive. At least we do unless
the case binder is guaranteed dead.
+In practice, the scrutinee is almost always a variable, so we pretty
+much always zap the OccInfo of the binders. It doesn't matter much though.
+
+
+Note [Case of cast]
+~~~~~~~~~~~~~~~~~~~
+Consider case (v `cast` co) of x { I# ->
+ ... (case (v `cast` co) of {...}) ...
+We'd like to eliminate the inner case. We can get this neatly by
+arranging that inside the outer case we add the unfolding
+ v |-> x `cast` (sym co)
+to v. Then we should inline v at the inner case, cancel the casts, and away we go
+
Note [Improving seq]
~~~~~~~~~~~~~~~~~~~
Consider
-- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
-- ==> case e of t { (a,b) -> ...(a)... }
-- Look, Ma, a is alive now.
- zap_occ_info | isDeadBinder case_bndr' = \ident -> ident
- | otherwise = zapIdOccInfo
+ zap_occ_info = zapCasePatIdOcc case_bndr'
addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
addBinderUnfolding env bndr rhs
addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
addBinderOtherCon env bndr cons
= modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
+
+zapCasePatIdOcc :: Id -> Id -> Id
+-- Consider case e of b { (a,b) -> ... }
+-- Then if we bind b to (a,b) in "...", and b is not dead,
+-- then we must zap the deadness info on a,b
+zapCasePatIdOcc case_bndr
+ | isDeadBinder case_bndr = \ pat_id -> pat_id
+ | otherwise = \ pat_id -> zapIdOccInfo pat_id
\end{code}
; simplExprF env' rhs cont }
knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
- = do { let dead_bndr = isDeadBinder bndr -- bndr is an InId
- n_drop_tys = length (dataConUnivTyVars dc)
- ; env' <- bind_args env dead_bndr bs (drop n_drop_tys the_args)
+ = do { let n_drop_tys = length (dataConUnivTyVars dc)
+ ; env' <- bind_args env bs (drop n_drop_tys the_args)
; let
-- It's useful to bind bndr to scrut, rather than to a fresh
-- binding x = Con arg1 .. argn
; env'' <- simplNonRecX env' bndr bndr_rhs
; simplExprF env'' rhs cont }
where
- -- Ugh!
- bind_args env' _ [] _ = return env'
+ zap_occ = zapCasePatIdOcc bndr -- bndr is an InId
- bind_args env' dead_bndr (b:bs') (Type ty : args)
+ -- Ugh!
+ bind_args env' [] _ = return env'
+
+ bind_args env' (b:bs') (Type ty : args)
= ASSERT( isTyVar b )
- bind_args (extendTvSubst env' b ty) dead_bndr bs' args
+ bind_args (extendTvSubst env' b ty) bs' args
- bind_args env' dead_bndr (b:bs') (arg : args)
+ bind_args env' (b:bs') (arg : args)
= ASSERT( isId b )
- do { let b' = if dead_bndr then b else zapIdOccInfo b
+ do { let b' = zap_occ b
-- Note that the binder might be "dead", because it doesn't
-- occur in the RHS; and simplNonRecX may therefore discard
-- it via postInlineUnconditionally.
-- Nevertheless we must keep it if the case-binder is alive,
-- because it may be used in the con_app. See Note [zapOccInfo]
; env'' <- simplNonRecX env' b' arg
- ; bind_args env'' dead_bndr bs' args }
+ ; bind_args env'' bs' args }
- bind_args _ _ _ _ =
+ bind_args _ _ _ =
pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
text "scrut:" <+> ppr scrut
\end{code}
mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
-> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
-mkDupableAlt env case_bndr' (con, bndrs', rhs')
- | exprIsDupable rhs' -- Note [Small alternative rhs]
- = return (env, (con, bndrs', rhs'))
+mkDupableAlt env case_bndr1 (con, bndrs1, rhs1)
+ | exprIsDupable rhs1 -- Note [Small alternative rhs]
+ = return (env, (con, bndrs1, rhs1))
| otherwise
- = do { let rhs_ty' = exprType rhs'
- used_bndrs' = filter abstract_over (case_bndr' : bndrs')
- abstract_over bndr
+ = do { let abstract_over bndr
| isTyVar bndr = True -- Abstract over all type variables just in case
| otherwise = not (isDeadBinder bndr)
-- The deadness info on the new Ids is preserved by simplBinders
- ; (final_bndrs', final_args) -- Note [Join point abstraction]
- <- if (any isId used_bndrs')
- then return (used_bndrs', varsToCoreExprs used_bndrs')
+ inst_tys1 = tyConAppArgs (idType case_bndr1)
+ con_app dc = mkConApp dc (map Type inst_tys1 ++ varsToCoreExprs bndrs1)
+
+ (rhs2, final_bndrs) -- See Note [Passing the case binder to join points]
+ | isDeadBinder case_bndr1
+ = (rhs1, filter abstract_over bndrs1)
+ | opt_PassCaseBndrToJoinPoints, not (null bndrs1)
+ = (rhs1, (case_bndr1 : filter abstract_over bndrs1))
+ | otherwise
+ = case con of
+ DataAlt dc -> (Let (NonRec case_bndr1 (con_app dc)) rhs1, bndrs1)
+ LitAlt lit -> ASSERT( null bndrs1 ) (Let (NonRec case_bndr1 (Lit lit)) rhs1, [])
+ DEFAULT -> ASSERT( null bndrs1 ) (rhs1, [case_bndr1])
+
+ ; (final_bndrs1, final_args) -- Note [Join point abstraction]
+ <- if (any isId final_bndrs)
+ then return (final_bndrs, varsToCoreExprs final_bndrs)
else do { rw_id <- newId (fsLit "w") realWorldStatePrimTy
- ; return ([rw_id], [Var realWorldPrimId]) }
+ ; return (rw_id : final_bndrs,
+ Var realWorldPrimId : varsToCoreExprs final_bndrs) }
- ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty')
+ ; let rhs_ty1 = exprType rhs1
+ ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs1 rhs_ty1)
-- Note [Funky mkPiTypes]
; let -- We make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so
-- prevents the body of the join point being floated out by
-- the full laziness pass
- really_final_bndrs = map one_shot final_bndrs'
+ really_final_bndrs = map one_shot final_bndrs1
one_shot v | isId v = setOneShotLambda v
| otherwise = v
- join_rhs = mkLams really_final_bndrs rhs'
+ join_rhs = mkLams really_final_bndrs rhs2
join_call = mkApps (Var join_bndr) final_args
- ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
+ ; env1 <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs)
+ ; return (env1, (con, bndrs1, join_call)) }
-- See Note [Duplicated env]
\end{code}
+Note [Passing the case binder to join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ case e of cb { C1 -> r1[cb]; C2 x y z -> r2[cb,x] }
+and we want to make join points for the two alternatives,
+which mention the case binder 'cb'. Should we pass 'cb' to
+the join point, or reconstruct it? Here are the two alternatives
+for the C2 alternative:
+
+ Plan A(pass cb): j2 cb x = r2[cb,x]
+
+ Plan B(reconstruct cb): j2 x y z = let cb = C2 x y z in r2[cb,x]
+
+The advantge of Plan B is that we can "see" the definition of cb
+in r2, and that may be important when we inline stuff in r2. The
+disadvantage is that if this optimisation doesn't happen, we end up
+re-allocating C2, when it already exists. This does happen occasionally;
+an example is the function nofib/spectral/cichelli/Auxil.$whinsert.
+
+Plan B is always better if the constructor is nullary.
+
+In both cases we don't have liveness info for cb on a branch-by-branch
+basis, and it's possible that 'cb' is used in some branches but not
+others. Well, the absence analyser will find that out later, so it's
+not too bad.
+
+Sadly, at the time of writing, neither choice seems an unequivocal
+win. Here are nofib results, for adding -fpass-case-bndr-to-join-points
+(all others are zero effect):
+
+ Program Size Allocs Runtime Elapsed
+--------------------------------------------------------------------------------
+ cichelli +0.0% -4.4% 0.13 0.13
+ pic +0.0% -0.7% 0.01 0.04
+ transform -0.0% +2.8% -0.4% -9.1%
+ wave4main +0.0% +10.5% +3.1% +3.4%
+--------------------------------------------------------------------------------
+ Min -0.0% -4.4% -7.0% -31.9%
+ Max +0.1% +10.5% +3.1% +15.0%
+ Geometric Mean +0.0% +0.1% -1.7% -6.1%
+
+
Note [Duplicated env]
~~~~~~~~~~~~~~~~~~~~~
Some of the alternatives are simplified, but have not been turned into a join point
projects / ghc-hetmet.git / blobdiff