import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
-import CoreMonad ( SimplifierSwitch(..), Tick(..) )
+import CoreMonad ( Tick(..), SimplifierMode(..) )
import CoreSyn
-import Demand ( isStrictDmd, splitStrictSig )
+import Demand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkUnfolding, mkCoreUnfolding
- , mkInlineUnfolding, mkSimpleUnfolding
- , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
+import CoreUnfold
import CoreUtils
import qualified CoreSubst
-import CoreArity ( exprArity )
+import CoreArity
import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict, Arity )
import CostCentre ( currentCCS, pushCCisNop )
trace_bind False _ = \x -> x
simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
- simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
+ simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
where
(env', b') = addBndrRules env b (lookupRecBndr env b)
\end{code}
go env [] = return env
go env ((old_bndr, new_bndr, rhs) : pairs)
- = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+ = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
; go env' pairs }
\end{code}
\begin{code}
simplRecOrTopPair :: SimplEnv
- -> TopLevelFlag
+ -> TopLevelFlag -> RecFlag
-> InId -> OutBndr -> InExpr -- Binder and rhs
-> SimplM SimplEnv -- Returns an env that includes the binding
-simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
| preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
= do { tick (PreInlineUnconditionally old_bndr)
; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
| otherwise
- = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
- -- May not actually be recursive, but it doesn't matter
+ = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
\end{code}
-- * or by adding to the floats in the envt
completeBind env top_lvl old_bndr new_bndr new_rhs
- = do { let old_info = idInfo old_bndr
- old_unf = unfoldingInfo old_info
- occ_info = occInfo old_info
+ = ASSERT( isId new_bndr )
+ do { let old_info = idInfo old_bndr
+ old_unf = unfoldingInfo old_info
+ occ_info = occInfo old_info
- ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
+ -- Do eta-expansion on the RHS of the binding
+ -- See Note [Eta-expanding at let bindings] in SimplUtils
+ ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
- ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
+ -- Simplify the unfolding
+ ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
+
+ ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
-- Inline and discard the binding
- then do { tick (PostInlineUnconditionally old_bndr)
- ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $
- return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+ then do { tick (PostInlineUnconditionally old_bndr)
+ ; -- pprTrace "postInlineUnconditionally"
+ -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $
+ return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
+ else
+ do { let info1 = idInfo new_bndr `setArityInfo` new_arity
+
+ -- Unfolding info: Note [Setting the new unfolding]
+ info2 = info1 `setUnfoldingInfo` new_unfolding
- else return (addNonRecWithUnf env new_bndr new_rhs 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
+
+ ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+ return (addNonRec env final_id final_rhs) } }
+ -- The addNonRec adds it to the in-scope set too
------------------------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
-- opportunity to inline 'y' too.
addPolyBind top_lvl env (NonRec poly_id rhs)
- = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
+ = do { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
-- 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) }
+ ; let final_id = setIdInfo poly_id $
+ idInfo poly_id `setUnfoldingInfo` unfolding
+ `setArityInfo` exprArity rhs
-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
+ ; return (addNonRec env final_id rhs) }
-------------------------------
-addNonRecWithUnf :: SimplEnv
- -> 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
- info1 = idInfo new_bndr `setArityInfo` new_arity
-
- -- 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 $ idStrictness new_bndr
- in
- ASSERT( isId new_bndr )
- WARN( new_arity < old_arity || new_arity < dmd_arity,
- (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity
- <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) )
- -- Note [Arity decrease]
-
- 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
+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
------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
- -> Id
- -> OccInfo -> OutExpr
+ -> InId
+ -> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
+simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
= return (DFunUnfolding ar con ops')
where
- ops' = map (substExpr (text "simplUnfolding") env) ops
+ ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
-simplUnfolding env top_lvl id _ _
+simplUnfolding env top_lvl id _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_src = src, uf_guidance = guide })
| isStableSource src
; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
is_top_lvl = isTopLevel top_lvl
; case guide of
- UnfIfGoodArgs{} ->
- -- We need to force bottoming, or the new unfolding holds
- -- on to the old unfolding (which is part of the id).
- let bottoming = isBottomingId id
- in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr')
+ UnfWhen sat_ok _ -- Happens for INLINE things
+ -> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
+ -- Refresh the boring-ok flag, in case expr'
+ -- has got small. This happens, notably in the inlinings
+ -- for dfuns for single-method classes; see
+ -- Note [Single-method classes] in TcInstDcls.
+ -- A test case is Trac #4138
+ in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
+ -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+ _other -- Happens for INLINABLE things
+ -> let bottoming = isBottomingId id
+ in bottoming `seq` -- See Note [Force bottoming field]
+ return (mkUnfolding src' is_top_lvl bottoming expr')
-- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-- unfolding, and we need to make sure the guidance is kept up
-- to date with respect to any changes in the unfolding.
- _other ->
- return (mkCoreUnfolding src' is_top_lvl expr' arity guide)
- -- See Note [Top-level flag on inline rules] in CoreUnfold
}
where
act = idInlineActivation id
rule_env = updMode (updModeForInlineRules act) env
-- See Note [Simplifying inside InlineRules] in SimplUtils
-simplUnfolding _ top_lvl id _occ_info new_rhs _
- = -- We need to force bottoming, or the new unfolding holds
- -- on to the old unfolding (which is part of the id).
- let bottoming = isBottomingId id
- in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
- -- We make an unfolding *even for loop-breakers*.
- -- Reason: (a) It might be useful to know that they are WHNF
- -- (b) In TidyPgm we currently assume that, if we want to
- -- expose the unfolding then indeed we *have* an unfolding
- -- to expose. (We could instead use the RHS, but currently
- -- we don't.) The simple thing is always to have one.
+simplUnfolding _ top_lvl id new_rhs _
+ = let bottoming = isBottomingId id
+ in bottoming `seq` -- See Note [Force bottoming field]
+ return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
+ -- We make an unfolding *even for loop-breakers*.
+ -- Reason: (a) It might be useful to know that they are WHNF
+ -- (b) In TidyPgm we currently assume that, if we want to
+ -- expose the unfolding then indeed we *have* an unfolding
+ -- to expose. (We could instead use the RHS, but currently
+ -- we don't.) The simple thing is always to have one.
\end{code}
+Note [Force bottoming field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to force bottoming, or the new unfolding holds
+on to the old unfolding (which is part of the id).
+
Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~
Generally speaking the arity of a binding should not decrease. But it *can*
ApplyTo NoDup arg env cont
simplExprF' env expr@(Lam _ _) cont
- = simplLam env (map zap bndrs) body cont
+ = simplLam env zapped_bndrs body cont
-- The main issue here is under-saturated lambdas
-- (\x1. \x2. e) arg1
-- Here x1 might have "occurs-once" occ-info, because occ-info
-- is computed assuming that a group of lambdas is applied
-- all at once. If there are too few args, we must zap the
- -- occ-info.
+ -- occ-info, UNLESS the remaining binders are one-shot
where
- n_args = countArgs cont
- n_params = length bndrs
(bndrs, body) = collectBinders expr
- zap | n_args >= n_params = \b -> b
- | otherwise = \b -> if isTyCoVar b then b
- else zapLamIdInfo b
- -- NB: we count all the args incl type args
- -- so we must count all the binders (incl type lambdas)
+ zapped_bndrs | need_to_zap = map zap bndrs
+ | otherwise = bndrs
+
+ need_to_zap = any zappable_bndr (drop n_args bndrs)
+ n_args = countArgs cont
+ -- NB: countArgs counts all the args (incl type args)
+ -- and likewise drop counts all binders (incl type lambdas)
+
+ zappable_bndr b = isId b && not (isOneShotBndr b)
+ zap b | isTyCoVar b = b
+ | otherwise = zapLamIdInfo b
simplExprF' env (Type ty) cont
= ASSERT( contIsRhsOrArg cont )
; rebuild env (Type ty') cont }
simplExprF' env (Case scrut bndr _ alts) cont
- | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+ | sm_case_case (getMode env)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- At this point the substitution in the SimplEnv should be irrelevant
-- only the in-scope set and floats should matter
-rebuild env expr cont0
- = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
- case cont0 of
+rebuild env expr cont
+ = case cont of
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
%* *
%************************************************************************
+Note [Zap unfolding when beta-reducing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound variables can have stable unfoldings, such as
+ $j = \x. \b{Unf=Just x}. e
+See Note [Case binders and join points] below; the unfolding for lets
+us optimise e better. However when we beta-reduce it we want to
+revert to using the actual value, otherwise we can end up in the
+stupid situation of
+ let x = blah in
+ let b{Unf=Just x} = y
+ in ...b...
+Here it'd be far better to drop the unfolding and use the actual RHS.
+
\begin{code}
simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-- 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 }
+ ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
+ where
+ zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing]
+ | isId bndr, isStableUnfolding (realIdUnfolding bndr)
+ = setIdUnfolding bndr NoUnfolding
+ | otherwise = bndr
-- Not enough args, so there are real lambdas left to put in the result
simplLam env bndrs body cont
; case activeRule dflags env of {
Nothing -> return Nothing ; -- No rules apply
Just act_fn ->
- case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of {
+ case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of {
Nothing -> return Nothing ; -- No rule matches
Just (rule, rule_rhs) ->
return (Just (ruleArity rule, rule_rhs)) }}}}
where
trace_dump dflags rule rule_rhs stuff
- | not (dopt Opt_D_dump_rule_firings dflags) = stuff
- | not (dopt Opt_D_verbose_core2core dflags)
+ | not (dopt Opt_D_dump_rule_firings dflags)
+ , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
+ | not (dopt Opt_D_dump_rule_rewrites dflags)
= pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
| otherwise
= pprTrace "Rule fired"
(vcat [text "Rule:" <+> ftext (ru_name rule),
- text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
+ text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont])
stuff
Now again the case may be elminated by the CaseElim transformation.
+Note [CaseElimination: lifted case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not use exprOkForSpeculation in the lifted case. Consider
+ case (case a ># b of { True -> (p,q); False -> (q,p) }) of
+ r -> blah
+The scrutinee is ok-for-speculation (it looks inside cases), but we do
+not want to transform to
+ let r = case a ># b of { True -> (p,q); False -> (q,p) }
+ in blah
+because that builds an unnecessary thunk.
+
Further notes about case elimination
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Nothing -> missingAlt env case_bndr alts cont
Just (_, bs, rhs) -> simple_rhs bs rhs }
- | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut
+ | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
-- Works when the scrutinee is a variable with a known unfolding
-- as well as when it's an explicit constructor application
= do { tick (KnownBranch case_bndr)
| all isDeadBinder bndrs -- bndrs are [InId]
-- Check that the scrutinee can be let-bound instead of case-bound
- , exprOkForSpeculation scrut
- -- OK not to evaluate it
- -- This includes things like (==# a# b#)::Bool
- -- so that we simplify
- -- case ==# a# b# of { True -> x; False -> x }
- -- to just
- -- x
- -- This particular example shows up in default methods for
- -- comparision operations (e.g. in (>=) for Int.Int32)
- || exprIsHNF scrut -- It's already evaluated
- || var_demanded_later scrut -- It'll be demanded later
-
--- || not opt_SimplPedanticBottoms) -- Or we don't care!
--- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
--- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
--- its argument: case x of { y -> dataToTag# y }
--- Here we must *not* discard the case, because dataToTag# just fetches the tag from
--- the info pointer. So we'll be pedantic all the time, and see if that gives any
--- other problems
--- Also we don't want to discard 'seq's
+ , if isUnLiftedType (idType case_bndr)
+ then exprOkForSpeculation scrut
+ -- Satisfy the let-binding invariant
+ -- This includes things like (==# a# b#)::Bool
+ -- so that we simplify
+ -- case ==# a# b# of { True -> x; False -> x }
+ -- to just
+ -- x
+ -- This particular example shows up in default methods for
+ -- comparision operations (e.g. in (>=) for Int.Int32)
+
+ else exprIsHNF scrut || var_demanded_later scrut
+ -- It's already evaluated, or will be demanded later
+ -- See Note [Case elimination: lifted case]
= do { tick (CaseElim case_bndr)
; env' <- simplNonRecX env case_bndr scrut
+ -- If case_bndr is deads, simplNonRecX will discard
; simplExprF env' rhs cont }
where
-- The case binder is going to be evaluated later,
projects / ghc-hetmet.git / blobdiff