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 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 occ_info 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
+
+ -- Demand info: Note [Setting the demand info]
+ info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
+ | otherwise = info2
+
+ final_id = new_bndr `setIdInfo` info3
- else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
+ ; -- 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
= do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo 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
| isStableSource src
= do { expr' <- simplExpr rule_env expr
; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
- ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
+ 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')
+ -- 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 _
- = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) 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
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
; 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) ->
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)
projects / ghc-hetmet.git / blobdiff