summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2019-11-08 17:49:35 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-04-02 01:45:58 -0400
commitb943b25d0786da64031ac63ddf9b4574182057bb (patch)
tree529ac144237d1c4d7524360374fa8b33a6bd5ee4
parent3c09f636a459f50119bfbb5bf798b9a9e19eb464 (diff)
downloadhaskell-b943b25d0786da64031ac63ddf9b4574182057bb.tar.gz
Re-engineer the binder-swap transformation
The binder-swap transformation is implemented by the occurrence analyser -- see Note [Binder swap] in OccurAnal. However it had a very nasty corner in it, for the case where the case scrutinee was a GlobalId. This led to trouble and hacks, and ultimately to #16296. This patch re-engineers how the occurrence analyser implements the binder-swap, by actually carrying out a substitution rather than by adding a let-binding. It's all described in Note [The binder-swap substitution]. I did a few other things along the way * Fix a bug in StgCse, which could allow a loop breaker to be CSE'd away. See Note [Care with loop breakers] in StgCse. I think it can only show up if occurrence analyser sets up bad loop breakers, but still. * Better commenting in SimplUtils.prepareAlts * A little refactoring in CoreUnfold; nothing significant e.g. rename CoreUnfold.mkTopUnfolding to mkFinalUnfolding * Renamed CoreSyn.isFragileUnfolding to hasCoreUnfolding * Move mkRuleInfo to CoreFVs We observed respectively 4.6% and 5.9% allocation decreases for the following tests: Metric Decrease: T9961 haddock.base
Diffstat
-rw-r--r--compiler/GHC/Core.hs17
-rw-r--r--compiler/GHC/Core/FVs.hs7
-rw-r--r--compiler/GHC/Core/Op/OccurAnal.hs897
-rw-r--r--compiler/GHC/Core/Op/Simplify.hs7
-rw-r--r--compiler/GHC/Core/Op/Simplify/Utils.hs18
-rw-r--r--compiler/GHC/Core/Rules.hs7
-rw-r--r--compiler/GHC/Core/Subst.hs2
-rw-r--r--compiler/GHC/Core/Unfold.hs111
-rw-r--r--compiler/GHC/Core/Utils.hs139
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs14
-rw-r--r--compiler/GHC/Iface/Tidy.hs3
-rw-r--r--compiler/GHC/IfaceToCore.hs7
-rw-r--r--compiler/GHC/Stg/CSE.hs18
-rw-r--r--compiler/GHC/Types/Id/Info.hs7
-rw-r--r--compiler/GHC/Types/Id/Make.hs4
-rw-r--r--testsuite/tests/dependent/should_compile/dynamic-paper.stderr4
-rw-r--r--testsuite/tests/simplCore/should_compile/T17901.stdout10
-rw-r--r--testsuite/tests/simplCore/should_compile/T7360.hs4
-rw-r--r--testsuite/tests/simplCore/should_compile/T7360.stderr40
19 files changed, 657 insertions, 659 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 8c354b5298..b8d44d98a0 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -69,7 +69,7 @@ module GHC.Core (
maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
- isStableUnfolding, isFragileUnfolding, hasSomeUnfolding,
+ isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding,
isBootUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
@@ -1739,14 +1739,13 @@ neverUnfoldGuidance :: UnfoldingGuidance -> Bool
neverUnfoldGuidance UnfNever = True
neverUnfoldGuidance _ = False
-isFragileUnfolding :: Unfolding -> Bool
--- An unfolding is fragile if it mentions free variables or
--- is otherwise subject to change. A robust one can be kept.
--- See Note [Fragile unfoldings]
-isFragileUnfolding (CoreUnfolding {}) = True
-isFragileUnfolding (DFunUnfolding {}) = True
-isFragileUnfolding _ = False
- -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile
+hasCoreUnfolding :: Unfolding -> Bool
+-- An unfolding "has Core" if it contains a Core expression, which
+-- may mention free variables. See Note [Fragile unfoldings]
+hasCoreUnfolding (CoreUnfolding {}) = True
+hasCoreUnfolding (DFunUnfolding {}) = True
+hasCoreUnfolding _ = False
+ -- NoUnfolding, BootUnfolding, OtherCon have no Core
canUnfold :: Unfolding -> Bool
canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs
index 67577bcd9b..6995cc71a1 100644
--- a/compiler/GHC/Core/FVs.hs
+++ b/compiler/GHC/Core/FVs.hs
@@ -35,7 +35,7 @@ module GHC.Core.FVs (
idFVs,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
- rulesFreeVarsDSet,
+ rulesFreeVarsDSet, mkRuleInfo,
ruleLhsFreeIds, ruleLhsFreeIdsList,
expr_fvs,
@@ -469,6 +469,11 @@ rulesFVs = mapUnionFV ruleFVs
rulesFreeVarsDSet :: [CoreRule] -> DVarSet
rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
+-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
+-- for putting into an 'IdInfo'
+mkRuleInfo :: [CoreRule] -> RuleInfo
+mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
+
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
-- Just the variables free on the *rhs* of a rule
idRuleRhsVars is_active id
diff --git a/compiler/GHC/Core/Op/OccurAnal.hs b/compiler/GHC/Core/Op/OccurAnal.hs
index ac1c665e1e..997ff7dd5a 100644
--- a/compiler/GHC/Core/Op/OccurAnal.hs
+++ b/compiler/GHC/Core/Op/OccurAnal.hs
@@ -14,10 +14,7 @@ core expression with (hopefully) improved usage information.
{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module GHC.Core.Op.OccurAnal (
- occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap
- ) where
+module GHC.Core.Op.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where
#include "HsVersions.h"
@@ -30,7 +27,6 @@ import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp,
import GHC.Core.Arity ( joinRhsArity )
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Types.Name( localiseName )
import GHC.Types.Basic
import GHC.Types.Module( Module )
import GHC.Core.Coercion
@@ -47,14 +43,14 @@ import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import Util
+import Maybes( orElse, isJust )
import Outputable
import Data.List
-import Control.Arrow ( second )
{-
************************************************************************
* *
- occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap
+ occurAnalysePgm, occurAnalyseExpr
* *
************************************************************************
@@ -92,8 +88,7 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
-- a binding that was actually needed (albeit before its
-- definition site). #17724 threw this up.
- initial_uds = addManyOccsSet emptyDetails
- (rulesFreeVars imp_rules)
+ initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)
-- The RULES declarations keep things alive!
-- Note [Preventing loops due to imported functions rules]
@@ -117,17 +112,9 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
bs_usage
occurAnalyseExpr :: CoreExpr -> CoreExpr
- -- Do occurrence analysis, and discard occurrence info returned
-occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap
-
-occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr
-occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap
-
-occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr
-occurAnalyseExpr' enable_binder_swap expr
- = snd (occAnal env expr)
- where
- env = initOccEnv { occ_binder_swap = enable_binder_swap }
+-- Do occurrence analysis, and discard occurrence info returned
+occurAnalyseExpr expr
+ = snd (occAnal initOccEnv expr)
{- Note [Plugin rules]
~~~~~~~~~~~~~~~~~~~~~~
@@ -672,38 +659,66 @@ tail call with `n` arguments (counting both value and type arguments). Otherwise
'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the
rest of 'OccInfo' until it goes on the binder.
-Note [Rules and join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Join points and unfoldings/rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ let j2 y = blah
+ let j x = j2 (x+x)
+ {-# INLINE [2] j #-}
+ in case e of { A -> j 1; B -> ...; C -> j 2 }
-Things get fiddly with rules. Suppose we have:
+Before j is inlined, we'll have occurrences of j2 in
+both j's RHS and in its stable unfolding. We want to discover
+j2 as a join point. So we must do the adjustRhsUsage thing
+on j's RHS. That's why we pass mb_join_arity to calcUnfolding.
+
+Aame with rules. Suppose we have:
let j :: Int -> Int
j y = 2 * y
- k :: Int -> Int -> Int
- {-# RULES "SPEC k 0" k 0 = j #-}
+ let k :: Int -> Int -> Int
+ {-# RULES "SPEC k 0" k 0 y = j y #-}
k x y = x + 2 * y
- in ...
-
-Now suppose that both j and k appear only as saturated tail calls in the body.
-Thus we would like to make them both join points. The rule complicates matters,
-though, as its RHS has an unapplied occurrence of j. *However*, if we were to
-eta-expand the rule, all would be well:
-
- {-# RULES "SPEC k 0" forall a. k 0 a = j a #-}
-
-So conceivably we could notice that a potential join point would have an
-"undersaturated" rule and account for it. This would mean we could make
-something that's been specialised a join point, for instance. But local bindings
-are rarely specialised, and being overly cautious about rules only
-costs us anything when, for some `j`:
+ in case e of { A -> k 1 2; B -> k 3 5; C -> blah }
+
+We identify k as a join point, and we want j to be a join point too.
+Without the RULE it would be, and we don't want the RULE to mess it
+up. So provided the join-point arity of k matches the args of the
+rule we can allow the tail-cal info from the RHS of the rule to
+propagate.
+
+* Wrinkle for Rec case. In the recursive case we don't know the
+ join-point arity in advance, when calling occAnalUnfolding and
+ occAnalRules. (See makeNode.) We don't want to pass Nothing,
+ because then a recursive joinrec might lose its join-poin-hood
+ when SpecConstr adds a RULE. So we just make do with the
+ *current* join-poin-hood, stored in the Id.
+
+ In the non-recursive case things are simple: see occAnalNonRecBind
+
+* Wrinkle for RULES. Suppose the example was a bit different:
+ let j :: Int -> Int
+ j y = 2 * y
+ k :: Int -> Int -> Int
+ {-# RULES "SPEC k 0" k 0 = j #-}
+ k x y = x + 2 * y
+ in ...
+ If we eta-expanded the rule all woudl be well, but as it stands the
+ one arg of the rule don't match the join-point arity of 2.
+
+ Conceivably we could notice that a potential join point would have
+ an "undersaturated" rule and account for it. This would mean we
+ could make something that's been specialised a join point, for
+ instance. But local bindings are rarely specialised, and being
+ overly cautious about rules only costs us anything when, for some `j`:
* Before specialisation, `j` has non-tail calls, so it can't be a join point.
* During specialisation, `j` gets specialised and thus acquires rules.
* Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),
and so now `j` *could* become a join point.
-This appears to be very rare in practice. TODO Perhaps we should gather
-statistics to be sure.
+ This appears to be very rare in practice. TODO Perhaps we should gather
+ statistics to be sure.
------------------------------------------------------------
Note [Adjusting right-hand sides]
@@ -767,44 +782,62 @@ occAnalBind env lvl top_env (Rec pairs) body_usage
-----------------
occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr
-> UsageDetails -> (UsageDetails, [CoreBind])
-occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage
- | isTyVar binder -- A type let; we don't gather usage info
- = (body_usage, [NonRec binder rhs])
+occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage
+ | isTyVar bndr -- A type let; we don't gather usage info
+ = (body_usage, [NonRec bndr rhs])
- | not (binder `usedIn` body_usage) -- It's not mentioned
+ | not (bndr `usedIn` body_usage) -- It's not mentioned
= (body_usage, [])
| otherwise -- It's mentioned in the body
- = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs'])
+ = (body_usage' `andUDs` rhs_usage4, [NonRec final_bndr rhs'])
where
- (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder
- mb_join_arity = willBeJoinId_maybe tagged_binder
+ (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr
+ occ = idOccInfo tagged_bndr
- (bndrs, body) = collectBinders rhs
+ -- Get the join info from the *new* decision
+ -- See Note [Join points and unfoldings/rules]
+ mb_join_arity = willBeJoinId_maybe tagged_bndr
+ is_join_point = isJust mb_join_arity
- (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body
- rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'
- -- For a /non-recursive/ join point we can mark all
- -- its join-lambda as one-shot; and it's a good idea to do so
+ final_bndr = tagged_bndr `setIdUnfolding` unf'
+ `setIdSpecialisation` mkRuleInfo rules'
+
+ env1 | is_join_point = env -- See Note [Join point RHSs]
+ | certainly_inline = env -- See Note [Cascading inlines]
+ | otherwise = rhsCtxt env
+
+ -- See Note [Sources of one-shot information]
+ rhs_env = env1 { occ_one_shots = argOneShots dmd }
+
+ (rhs_usage1, rhs') = occAnalRhs rhs_env mb_join_arity rhs
-- Unfoldings
-- See Note [Unfoldings and join points]
- rhs_usage2 = case occAnalUnfolding env NonRecursive binder of
- Just unf_usage -> rhs_usage1 `andUDs` unf_usage
- Nothing -> rhs_usage1
+ unf = idUnfolding bndr
+ (unf_usage, unf') = occAnalUnfolding rhs_env mb_join_arity unf
+ rhs_usage2 = rhs_usage1 `andUDs` unf_usage
-- Rules
-- See Note [Rules are extra RHSs] and Note [Rule dependency info]
- rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder
+ rules_w_uds = occAnalRules rhs_env mb_join_arity bndr
rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds
+ rules' = map fstOf3 rules_w_uds
rhs_usage3 = foldr andUDs rhs_usage2 rule_uds
- rhs_usage4 = case lookupVarEnv imp_rule_edges binder of
+ rhs_usage4 = case lookupVarEnv imp_rule_edges bndr of
Nothing -> rhs_usage3
- Just vs -> addManyOccsSet rhs_usage3 vs
+ Just vs -> addManyOccs rhs_usage3 vs
-- See Note [Preventing loops due to imported functions rules]
- -- Final adjustment
- rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4
+ certainly_inline -- See Note [Cascading inlines]
+ = case occ of
+ OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch }
+ -> active && not_stable
+ _ -> False
+
+ dmd = idDemandInfo bndr
+ active = isAlwaysActive (idInlineActivation bndr)
+ not_stable = not (isStableUnfolding (idUnfolding bndr))
-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
@@ -866,8 +899,8 @@ occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds)
| otherwise -- At this point we always build a single Rec
= -- pprTrace "occAnalRec" (vcat
- -- [ text "weak_fvs" <+> ppr weak_fvs
- -- , text "lb nodes" <+> ppr loop_breaker_nodes])
+ -- [ text "weak_fvs" <+> ppr weak_fvs
+ -- , text "lb nodes" <+> ppr loop_breaker_nodes])
(final_uds, Rec pairs : binds)
where
@@ -931,10 +964,10 @@ recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
-- Return the bindings sorted into a plausible order, and marked with loop breakers.
loopBreakNodes depth bndr_set weak_fvs nodes binds
= -- pprTrace "loopBreakNodes" (ppr nodes) $
- go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds
+ go (stronglyConnCompFromEdgedVerticesUniqR nodes)
where
- go [] binds = binds
- go (scc:sccs) binds = loop_break_scc scc (go sccs binds)
+ go [] = binds
+ go (scc:sccs) = loop_break_scc scc (go sccs)
loop_break_scc scc binds
= case scc of
@@ -949,7 +982,7 @@ reOrderNodes _ _ _ [] _ = panic "reOrderNodes"
reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds
reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
= -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen
- -- , text "chosen" <+> ppr chosen_nodes ]) $
+ -- , text "chosen" <+> ppr chosen_nodes ]) $
loopBreakNodes new_depth bndr_set weak_fvs unchosen $
(map mk_loop_breaker chosen_nodes ++ binds)
where
@@ -1148,7 +1181,9 @@ type LetrecNode = Node Unique Details -- Node comes from Digraph
-- The Unique key is gotten from the Id
data Details
= ND { nd_bndr :: Id -- Binder
+
, nd_rhs :: CoreExpr -- RHS, already occ-analysed
+
, nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS
-- INVARIANT: (nd_rhs_bndrs nd, _) ==
-- collectBinders (nd_rhs nd)
@@ -1205,7 +1240,7 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
-- is still deterministic with edges in nondeterministic order as
-- explained in Note [Deterministic SCC] in Digraph.
where
- details = ND { nd_bndr = bndr
+ details = ND { nd_bndr = bndr'
, nd_rhs = rhs'
, nd_rhs_bndrs = bndrs'
, nd_uds = rhs_usage3
@@ -1214,24 +1249,35 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
, nd_active_rule_fvs = active_rule_fvs
, nd_score = pprPanic "makeNodeDetails" (ppr bndr) }
+ bndr' = bndr `setIdUnfolding` unf'
+ `setIdSpecialisation` mkRuleInfo rules'
+
+ -- Get join point info from the *current* decision
+ -- We don't know what the new decision will be!
+ -- Using the old decision at least allows us to
+ -- preserve existing join point, even RULEs are added
+ -- See Note [Join points and unfoldings/rules]
+ mb_join_arity = isJoinId_maybe bndr
+
-- Constructing the edges for the main Rec computation
-- See Note [Forming Rec groups]
(bndrs, body) = collectBinders rhs
- (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body
- rhs' = mkLams bndrs' body'
- rhs_usage2 = foldr andUDs rhs_usage1 rule_uds
+ rhs_env = rhsCtxt env
+ (rhs_usage1, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body
+ rhs' = mkLams bndrs' body'
+ rhs_usage3 = foldr andUDs rhs_usage1 rule_uds
+ `andUDs` unf_uds
-- Note [Rules are extra RHSs]
-- Note [Rule dependency info]
- rhs_usage3 = case mb_unf_uds of
- Just unf_uds -> rhs_usage2 `andUDs` unf_uds
- Nothing -> rhs_usage2
- node_fvs = udFreeVars bndr_set rhs_usage3
+ node_fvs = udFreeVars bndr_set rhs_usage3
-- Finding the free variables of the rules
is_active = occ_rule_act env :: Activation -> Bool
rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
- rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr
+ rules_w_uds = occAnalRules rhs_env mb_join_arity bndr
+
+ rules' = map fstOf3 rules_w_uds
rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs
rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):))
@@ -1244,16 +1290,20 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
, is_active a]
-- Finding the usage details of the INLINE pragma (if any)
- mb_unf_uds = occAnalUnfolding env Recursive bndr
+ unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness
+ -- here because that is what we are setting!
+ (unf_uds, unf') = occAnalUnfolding rhs_env mb_join_arity unf
-- Find the "nd_inl" free vars; for the loop-breaker phase
- inl_fvs = case mb_unf_uds of
- Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS
- Just unf_uds -> udFreeVars bndr_set unf_uds
- -- We could check for an *active* INLINE (returning
- -- emptyVarSet for an inactive one), but is_active
- -- isn't the right thing (it tells about
- -- RULE activation), so we'd need more plumbing
+ -- These are the vars that would become free if the function
+ -- was inlinined; usually that means the RHS, unless the
+ -- unfolding is a stable one.
+ -- Note: We could do this only for functions with an *active* unfolding
+ -- (returning emptyVarSet for an inactive one), but is_active
+ -- isn't the right thing (it tells about RULE activation),
+ -- so we'd need more plumbing
+ inl_fvs | isStableUnfolding unf = udFreeVars bndr_set unf_uds
+ | otherwise = udFreeVars bndr_set rhs_usage1
mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
-> VarSet
@@ -1271,22 +1321,24 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
mkLoopBreakerNodes env lvl bndr_set body_uds details_s
= (final_uds, zipWith mk_lb_node details_s bndrs')
where
- (final_uds, bndrs') = tagRecBinders lvl body_uds
- [ ((nd_bndr nd)
- ,(nd_uds nd)
- ,(nd_rhs_bndrs nd))
- | nd <- details_s ]
- mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr'
- = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps)
+ (final_uds, bndrs')
+ = tagRecBinders lvl body_uds
+ [ (bndr, uds, rhs_bndrs)
+ | ND { nd_bndr = bndr, nd_uds = uds, nd_rhs_bndrs = rhs_bndrs }
+ <- details_s ]
+
+ mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr
+ = DigraphNode nd' (varUnique old_bndr) (nonDetKeysUniqSet lb_deps)
-- It's OK to use nonDetKeysUniqSet here as
-- stronglyConnCompFromEdgedVerticesR is still deterministic with edges
-- in nondeterministic order as explained in
-- Note [Deterministic SCC] in Digraph.
where
- nd' = nd { nd_bndr = bndr', nd_score = score }
- score = nodeScore env bndr bndr' rhs lb_deps
+ nd' = nd { nd_bndr = new_bndr, nd_score = score }
+ score = nodeScore env new_bndr lb_deps nd
lb_deps = extendFvs_ rule_fv_env inl_fvs
+
rule_fv_env :: IdEnv IdSet
-- Maps a variable f to the variables from this group
-- mentioned in RHS of active rules for f
@@ -1301,12 +1353,13 @@ mkLoopBreakerNodes env lvl bndr_set body_uds details_s
------------------------------------------
nodeScore :: OccEnv
- -> Id -- Binder has old occ-info (just for loop-breaker-ness)
-> Id -- Binder with new occ-info
- -> CoreExpr -- RHS
-> VarSet -- Loop-breaker dependencies
+ -> Details
-> NodeScore
-nodeScore env old_bndr new_bndr bind_rhs lb_deps
+nodeScore env new_bndr lb_deps
+ (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })
+
| not (isId old_bndr) -- A type or coercion variable is never a loop breaker
= (100, 0, False)
@@ -1324,7 +1377,7 @@ nodeScore env old_bndr new_bndr bind_rhs lb_deps
-- where df is the exported dictionary. Then df makes a really
-- bad choice for loop breaker
- | DFunUnfolding { df_args = args } <- id_unfolding
+ | DFunUnfolding { df_args = args } <- old_unf
-- Never choose a DFun as a loop breaker
-- Note [DFuns should not be loop breakers]
= (9, length args, is_lb)
@@ -1332,13 +1385,13 @@ nodeScore env old_bndr new_bndr bind_rhs lb_deps
-- Data structures are more important than INLINE pragmas
-- so that dictionary/method recursion unravels
- | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding
+ | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf
= mk_score 6
| is_con_app rhs -- Data types help with cases:
= mk_score 5 -- Note [Constructor applications]
- | isStableUnfolding id_unfolding
+ | isStableUnfolding old_unf
, can_unfold
= mk_score 3
@@ -1355,23 +1408,23 @@ nodeScore env old_bndr new_bndr bind_rhs lb_deps
mk_score :: Int -> NodeScore
mk_score rank = (rank, rhs_size, is_lb)
- is_lb = isStrongLoopBreaker (idOccInfo old_bndr)
- rhs = case id_unfolding of
- CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }
- | isStableSource src
- -> unf_rhs
- _ -> bind_rhs
+ -- is_lb: see Note [Loop breakers, node scoring, and stability]
+ is_lb = isStrongLoopBreaker (idOccInfo old_bndr)
+
+ old_unf = realIdUnfolding old_bndr
+ can_unfold = canUnfold old_unf
+ rhs = case old_unf of
+ CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }
+ | isStableSource src
+ -> unf_rhs
+ _ -> bind_rhs
-- 'bind_rhs' is irrelevant for inlining things with a stable unfolding
- rhs_size = case id_unfolding of
+ rhs_size = case old_unf of
CoreUnfolding { uf_guidance = guidance }
| UnfIfGoodArgs { ug_size = size } <- guidance
-> size
_ -> cheapExprSize rhs
- can_unfold = canUnfold id_unfolding
- id_unfolding = realIdUnfolding old_bndr
- -- realIdUnfolding: Ignore loop-breaker-ness here because
- -- that is what we are setting!
-- Checking for a constructor application
-- Cheap and cheerful; the simplifier moves casts out of the way
@@ -1508,108 +1561,84 @@ Hence the is_lb field of NodeScore
************************************************************************
-}
-occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr
- -> (UsageDetails, [CoreBndr], CoreExpr)
- -- Returned usage details covers only the RHS,
- -- and *not* the RULE or INLINE template for the Id
-occAnalRhs env Recursive _ bndrs body
- = occAnalRecRhs env bndrs body
-occAnalRhs env NonRecursive id bndrs body
- = occAnalNonRecRhs env id bndrs body
-
-occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body
- -> (UsageDetails, [CoreBndr], CoreExpr)
- -- Returned usage details covers only the RHS,
- -- and *not* the RULE or INLINE template for the Id
-occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body
-
-occAnalNonRecRhs :: OccEnv
- -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body
- -- Binder is already tagged with occurrence info
- -> (UsageDetails, [CoreBndr], CoreExpr)
- -- Returned usage details covers only the RHS,
- -- and *not* the RULE or INLINE template for the Id
-occAnalNonRecRhs env bndr bndrs body
- = occAnalLamOrRhs rhs_env bndrs body
+occAnalRhs :: OccEnv -> Maybe JoinArity
+ -> CoreExpr -- RHS
+ -> (UsageDetails, CoreExpr)
+occAnalRhs env mb_join_arity rhs
+ = (rhs_usage, rhs')
where
- env1 | is_join_point = env -- See Note [Join point RHSs]
- | certainly_inline = env -- See Note [Cascading inlines]
- | otherwise = rhsCtxt env
-
- -- See Note [Sources of one-shot information]
- rhs_env = env1 { occ_one_shots = argOneShots dmd }
-
- certainly_inline -- See Note [Cascading inlines]
- = case occ of
- OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch }
- -> active && not_stable
- _ -> False
-
- is_join_point = isAlwaysTailCalled occ
- -- Like (isJoinId bndr) but happens one step earlier
- -- c.f. willBeJoinId_maybe
+ (bndrs, body) = collectBinders rhs
+ (body_usage, bndrs', body') = occAnalLamOrRhs env bndrs body
+ rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'
+ -- For a /non-recursive/ join point we can mark all
+ -- its join-lambda as one-shot; and it's a good idea to do so
- occ = idOccInfo bndr
- dmd = idDemandInfo bndr
- active = isAlwaysActive (idInlineActivation bndr)
- not_stable = not (isStableUnfolding (idUnfolding bndr))
+ -- Final adjustment
+ rhs_usage = adjustRhsUsage mb_join_arity NonRecursive bndrs' body_usage
occAnalUnfolding :: OccEnv
- -> RecFlag
- -> Id
- -> Maybe UsageDetails
- -- Just the analysis, not a new unfolding. The unfolding
- -- got analysed when it was created and we don't need to
- -- update it.
-occAnalUnfolding env rec_flag id
- = case realIdUnfolding id of -- ignore previous loop-breaker flag
- CoreUnfolding { uf_tmpl = rhs, uf_src = src }
- | not (isStableSource src)
- -> Nothing
- | otherwise
- -> Just $ markAllMany usage
+ -> Maybe JoinArity -- See Note [Join points and unfoldings/rules]
+ -> Unfolding
+ -> (UsageDetails, Unfolding)
+-- Occurrence-analyse a stable unfolding;
+-- discard a non-stable one altogether.
+occAnalUnfolding env mb_join_arity unf
+ = case unf of
+ unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+ | isStableSource src -> (usage, unf')
+ | otherwise -> (emptyDetails, unf)
+ where -- For non-Stable unfoldings we leave them undisturbed, but
+ -- don't count their usage because the simplifier will discard them.
+ -- We leave them undisturbed because nodeScore uses their size info
+ -- to guide its decisions. It's ok to leave un-substituted
+ -- expressions in the tree because all the variables that were in
+ -- scope remain in scope; there is no cloning etc.
+ (usage, rhs') = occAnalRhs env mb_join_arity rhs
+
+ unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]
+ | otherwise = unf { uf_tmpl = rhs' }
+
+ unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+ -> ( final_usage, unf { df_args = args' } )
where
- (bndrs, body) = collectBinders rhs
- (usage, _, _) = occAnalRhs env rec_flag id bndrs body
+ env' = env `addInScope` bndrs
+ (usage, args') = occAnalList env' args
+ final_usage = zapDetails (delDetailsList usage bndrs)
- DFunUnfolding { df_bndrs = bndrs, df_args = args }
- -> Just $ zapDetails (delDetailsList usage bndrs)
- where
- usage = andUDsList (map (fst . occAnal env) args)
-
- _ -> Nothing
+ unf -> (emptyDetails, unf)
occAnalRules :: OccEnv
- -> Maybe JoinArity -- If the binder is (or MAY become) a join
- -- point, what its join arity is (or WOULD
- -- become). See Note [Rules and join points].
- -> RecFlag
- -> Id
+ -> Maybe JoinArity -- See Note [Join points and unfoldings/rules]
+ -> Id -- Get rules from here
-> [(CoreRule, -- Each (non-built-in) rule
UsageDetails, -- Usage details for LHS
UsageDetails)] -- Usage details for RHS
-occAnalRules env mb_expected_join_arity rec_flag id
- = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id
- , let (lhs_uds, rhs_uds) = occ_anal_rule rule ]
+occAnalRules env mb_join_arity bndr
+ = map occ_anal_rule (idCoreRules bndr)
where
- occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
- = (lhs_uds, final_rhs_uds)
+ occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
+ = (rule', lhs_uds', rhs_uds')
where
- lhs_uds = addManyOccsSet emptyDetails $
- (exprsFreeVars args `delVarSetList` bndrs)
- (rhs_bndrs, rhs_body) = collectBinders rhs
- (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body
+ env' = env `addInScope` bndrs
+ rule' | noBinderSwaps env = rule -- Note [Unfoldings and rules]
+ | otherwise = rule { ru_args = args', ru_rhs = rhs' }
+
+ (lhs_uds, args') = occAnalList env' args
+ lhs_uds' = markAllMany $
+ lhs_uds `delDetailsList` bndrs
+
+ (rhs_uds, rhs') = occAnal env' rhs
-- Note [Rules are extra RHSs]
-- Note [Rule dependency info]
- final_rhs_uds = adjust_tail_info args $ markAllMany $
- (rhs_uds `delDetailsList` bndrs)
- occ_anal_rule _
- = (emptyDetails, emptyDetails)
-
- adjust_tail_info args uds -- see Note [Rules and join points]
- = case mb_expected_join_arity of
- Just ar | args `lengthIs` ar -> uds
- _ -> markAllNonTailCalled uds
+ rhs_uds' = markAllNonTailCalledIf (not exact_join) $
+ markAllMany $
+ rhs_uds `delDetailsList` bndrs
+
+ exact_join = exactJoin mb_join_arity args
+ -- See Note [Join points and unfoldings/rules]
+
+ occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails)
+
{- Note [Join point RHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
@@ -1622,6 +1651,19 @@ the FloatIn pass knows to float into join point RHSs; and the simplifier
does not float things out of join point RHSs. But it's a simple, cheap
thing to do. See #14137.
+Note [Unfoldings and rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally unfoldings and rules are already occurrence-analysed, so we
+don't want to reconstruct their trees; we just want to analyse them to
+find how they use their free variables.
+
+EXCEPT if there is a binder-swap going on, in which case we do want to
+produce a new tree.
+
+So we have a fast-path that keeps the old tree if the occ_bs_env is
+empty. This just saves a bit of allocation and reconstruction; not
+a big deal.
+
Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
By default we use an rhsCtxt for the RHS of a binding. This tells the
@@ -1674,6 +1716,12 @@ for the various clauses.
************************************************************************
-}
+occAnalList :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
+occAnalList _ [] = (emptyDetails, [])
+occAnalList env (e:es) = case occAnal env e of { (uds1, e') ->
+ case occAnalList env es of { (uds2, es') ->
+ (uds1 `andUDs` uds2, e' : es') } }
+
occAnal :: OccEnv
-> CoreExpr
-> (UsageDetails, -- Gives info only about the "interesting" Ids
@@ -1690,7 +1738,7 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], [])
-- weren't used at all.
occAnal _ (Coercion co)
- = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co)
+ = (addManyOccs emptyDetails (coVarsOfCo co), Coercion co)
-- See Note [Gather occurrences of coercion variables]
{-
@@ -1711,7 +1759,7 @@ occAnal env (Tick tickish body)
= (markAllNonTailCalled usage, Tick tickish body')
| Breakpoint _ ids <- tickish
- = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body')
+ = (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body')
-- never substitute for any of the Ids in a Breakpoint
| otherwise
@@ -1734,7 +1782,7 @@ occAnal env (Cast expr co)
-- usage1: if we see let x = y `cast` co
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
- usage2 = addManyOccsSet usage1 (coVarsOfCo co)
+ usage2 = addManyOccs usage1 (coVarsOfCo co)
-- usage2: see Note [Gather occurrences of coercion variables]
in (markAllNonTailCalled usage2, Cast expr' co)
}
@@ -1762,21 +1810,23 @@ occAnal env (Lam x body)
-- Then, the simplifier is careful when partially applying lambdas.
occAnal env expr@(Lam _ _)
- = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') ->
+ = case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->
let
- expr' = mkLams tagged_binders body'
+ expr' = mkLams tagged_bndrs body'
usage1 = markAllNonTailCalled usage
- one_shot_gp = all isOneShotBndr tagged_binders
- final_usage | one_shot_gp = usage1
- | otherwise = markAllInsideLam usage1
+ one_shot_gp = all isOneShotBndr tagged_bndrs
+ final_usage = markAllInsideLamIf (not one_shot_gp) usage1
in
(final_usage, expr') }
where
- (binders, body) = collectBinders expr
+ (bndrs, body) = collectBinders expr
occAnal env (Case scrut bndr ty alts)
- = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
- case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
+ = case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') ->
+ let alt_env = addBndrSwap scrut' bndr $
+ env { occ_encl = OccVanilla } `addInScope` [bndr]
+ in
+ case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
let
alts_usage = foldr orUDs emptyDetails alts_usage_s
(alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr
@@ -1784,27 +1834,10 @@ occAnal env (Case scrut bndr ty alts)
-- Alts can have tail calls, but the scrutinee can't
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
- where
- alt_env = mkAltEnv env scrut bndr
- occ_anal_alt = occAnalAlt alt_env
-
- occ_anal_scrut (Var v) (alt1 : other_alts)
- | not (null other_alts) || not (isDefaultAlt alt1)
- = (mkOneOcc env v IsInteresting 0, Var v)
- -- The 'True' says that the variable occurs in an interesting
- -- context; the case has at least one non-default alternative
- occ_anal_scrut (Tick t e) alts
- | t `tickishScopesLike` SoftScope
- -- No reason to not look through all ticks here, but only
- -- for soft-scoped ticks we can do so without having to
- -- update returned occurrence info (see occAnal)
- = second (Tick t) $ occ_anal_scrut e alts
-
- occ_anal_scrut scrut _alts
- = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt
occAnal env (Let bind body)
- = case occAnal env body of { (body_usage, body') ->
+ = case occAnal (env `addInScope` bindersOf bind)
+ body of { (body_usage, body') ->
case occAnalBind env NotTopLevel
noImpRuleEdges bind
body_usage of { (final_usage, new_binds) ->
@@ -1845,17 +1878,22 @@ Constructors are rather like lambdas in this way.
occAnalApp :: OccEnv
-> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])
-> (UsageDetails, Expr CoreBndr)
+-- Naked variables (not applied) end up here too
occAnalApp env (Var fun, args, ticks)
- | null ticks = (uds, mkApps (Var fun) args')
- | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args')
+ | null ticks = (all_uds, mkApps fun' args')
+ | otherwise = (all_uds, mkTicks ticks $ mkApps fun' args')
where
- uds = fun_uds `andUDs` final_args_uds
+ (fun', fun_id') = lookupVarEnv (occ_bs_env env) fun
+ `orElse` (Var fun, fun)
+ -- See Note [The binder-swap substitution]
+
+ fun_uds = mkOneOcc fun_id' int_cxt n_args
+ all_uds = fun_uds `andUDs` final_args_uds
!(args_uds, args') = occAnalArgs env args one_shots
- !final_args_uds
- | isRhsEnv env && is_exp = markAllNonTailCalled $
- markAllInsideLam args_uds
- | otherwise = markAllNonTailCalled args_uds
+ !final_args_uds = markAllNonTailCalled $
+ markAllInsideLamIf (isRhsEnv env && is_exp) $
+ args_uds
-- We mark the free vars of the argument of a constructor or PAP
-- as "inside-lambda", if it is the RHS of a let(rec).
-- This means that nothing gets inlined into a constructor or PAP
@@ -1868,7 +1906,11 @@ occAnalApp env (Var fun, args, ticks)
n_val_args = valArgCount args
n_args = length args
- fun_uds = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args
+ int_cxt = case occ_encl env of
+ OccScrut -> IsInteresting
+ _other | n_val_args > 0 -> IsInteresting
+ | otherwise -> NotInteresting
+
is_exp = isExpandableApp fun n_val_args
-- See Note [CONLIKE pragma] in GHC.Types.Basic
-- The definition of is_exp should match that in GHC.Core.Op.Simplify.prepareRhs
@@ -1891,11 +1933,6 @@ occAnalApp env (fun, args, ticks)
-- onto the context stack.
!(args_uds, args') = occAnalArgs env args []
-zapDetailsIf :: Bool -- If this is true
- -> UsageDetails -- Then do zapDetails on this
- -> UsageDetails
-zapDetailsIf True uds = zapDetails uds
-zapDetailsIf False uds = uds
{-
Note [Sources of one-shot information]
@@ -1987,9 +2024,12 @@ scrutinised y).
occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr
-> (UsageDetails, [CoreBndr], CoreExpr)
+-- Tags the returned binders with their OccInfo, but does
+-- not do any markInsideLam to the returned usage details
occAnalLamOrRhs env [] body
= case occAnal env body of (body_usage, body') -> (body_usage, [], body')
-- RHS of thunk or nullary join point
+
occAnalLamOrRhs env (bndr:bndrs) body
| isTyVar bndr
= -- Important: Keep the environment so that we don't inline into an RHS like
@@ -1997,6 +2037,7 @@ occAnalLamOrRhs env (bndr:bndrs) body
-- (see the beginning of Note [Cascading inlines]).
case occAnalLamOrRhs env bndrs body of
(body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body')
+
occAnalLamOrRhs env binders body
= case occAnal env_body body of { (body_usage, body') ->
let
@@ -2005,47 +2046,17 @@ occAnalLamOrRhs env binders body
in
(final_usage, tagged_binders, body') }
where
- (env_body, binders') = oneShotGroup env binders
+ env1 = env `addInScope` binders
+ (env_body, binders') = oneShotGroup env1 binders
-occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
- -> CoreAlt
- -> (UsageDetails, Alt IdWithOccInfo)
-occAnalAlt (env, scrut_bind) (con, bndrs, rhs)
- = case occAnal env rhs of { (rhs_usage1, rhs1) ->
+occAnalAlt :: OccEnv -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo)
+occAnalAlt env (con, bndrs, rhs)
+ = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) ->
let
(alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
- -- See Note [Binders in case alternatives]
- (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1
- in
- (alt_usg', (con, tagged_bndrs, rhs2)) }
-
-wrapAltRHS :: OccEnv
- -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv
- -> UsageDetails -- usage for entire alt (p -> rhs)
- -> [Var] -- alt binders
- -> CoreExpr -- alt RHS
- -> (UsageDetails, CoreExpr)
-wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs
- | occ_binder_swap env
- , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this
- -- handles condition (a) in Note [Binder swap]
- , not captured -- See condition (b) in Note [Binder swap]
- = ( alt_usg' `andUDs` let_rhs_usg
- , Let (NonRec tagged_scrut_var let_rhs') alt_rhs )
- where
- captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b)
-
- -- The rhs of the let may include coercion variables
- -- if the scrutinee was a cast, so we must gather their
- -- usage. See Note [Gather occurrences of coercion variables]
- -- Moreover, the rhs of the let may mention the case-binder, and
- -- we want to gather its occ-info as well
- (let_rhs_usg, let_rhs') = occAnal env let_rhs
-
- (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var
+ in -- See Note [Binders in case alternatives]
+ (alt_usg, (con, tagged_bndrs, rhs1)) }
-wrapAltRHS _ _ alt_usg _ alt_rhs
- = (alt_usg, alt_rhs)
{-
************************************************************************
@@ -2058,18 +2069,17 @@ wrapAltRHS _ _ alt_usg _ alt_rhs
data OccEnv
= OccEnv { occ_encl :: !OccEncl -- Enclosing context information
, occ_one_shots :: !OneShots -- See Note [OneShots]
- , occ_gbl_scrut :: GlobalScruts
-
- , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active
-
- , occ_rule_act :: Activation -> Bool -- Which rules are active
+ , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active
+ , occ_rule_act :: Activation -> Bool -- Which rules are active
-- See Note [Finding rule RHS free vars]
- , occ_binder_swap :: !Bool -- enable the binder_swap
- -- See CorePrep Note [Dead code in CorePrep]
+ -- See Note [The binder-swap substitution]
+ , occ_bs_env :: VarEnv (OutExpr, OutId)
+ , occ_bs_rng :: VarSet -- Vars free in the range of occ_bs_env
+ -- Domain is Global and Local Ids
+ -- Range is just Local Ids
}
-type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees]
-----------------------------
-- OccEncl is used to control whether to inline into constructor arguments
@@ -2079,15 +2089,22 @@ type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees]
-- z = f (p,q) -- Do inline p,q; it may make a rule fire
-- So OccEncl tells enough about the context to know what to do when
-- we encounter a constructor application or PAP.
+--
+-- OccScrut is used to set the "interesting context" field of OncOcc
data OccEncl
- = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
- -- Don't inline into constructor args here
- | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
- -- Do inline into constructor args here
+ = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
+ -- Don't inline into constructor args here
+
+ | OccScrut -- Scrutintee of a case
+ -- Can inline into constructor args
+
+ | OccVanilla -- Argument of function, body of lambda, etc
+ -- Do inline into constructor args here
instance Outputable OccEncl where
ppr OccRhs = text "occRhs"
+ ppr OccScrut = text "occScrut"
ppr OccVanilla = text "occVanilla"
-- See note [OneShots]
@@ -2097,15 +2114,30 @@ initOccEnv :: OccEnv
initOccEnv
= OccEnv { occ_encl = OccVanilla
, occ_one_shots = []
- , occ_gbl_scrut = emptyVarSet
+
-- To be conservative, we say that all
-- inlines and rules are active
, occ_unf_act = \_ -> True
, occ_rule_act = \_ -> True
- , occ_binder_swap = True }
-vanillaCtxt :: OccEnv -> OccEnv
-vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] }
+ , occ_bs_env = emptyVarEnv
+ , occ_bs_rng = emptyVarSet }
+
+noBinderSwaps :: OccEnv -> Bool
+noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env
+
+scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv
+scrutCtxt env alts
+ | interesting_alts = env { occ_encl = OccScrut, occ_one_shots = [] }
+ | otherwise = env { occ_encl = OccVanilla, occ_one_shots = [] }
+ where
+ interesting_alts = case alts of
+ [] -> False
+ [alt] -> not (isDefaultAlt alt)
+ _ -> True
+ -- 'interesting_alts' is True if the case has at least one
+ -- non-default alternative. That in turn influences
+ -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"!
rhsCtxt :: OccEnv -> OccEnv
rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }
@@ -2117,8 +2149,15 @@ argCtxt env (one_shots:one_shots_s)
= (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)
isRhsEnv :: OccEnv -> Bool
-isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
-isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
+isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
+ OccRhs -> True
+ _ -> False
+
+addInScope :: OccEnv -> [Var] -> OccEnv
+-- See Note [The binder-swap substitution]
+addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs
+ | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
+ | otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
oneShotGroup :: OccEnv -> [CoreBndr]
-> ( OccEnv
@@ -2222,14 +2261,14 @@ scrutinee of a case for occurrences of the case-binder:
(1) case x of b { pi -> ri }
==>
- case x of b { pi -> let x=b in ri }
+ case x of b { pi -> ri[b/x] }
(2) case (x |> co) of b { pi -> ri }
==>
- case (x |> co) of b { pi -> let x = b |> sym co in ri }
+ case (x |> co) of b { pi -> ri[b |> sym co/x] }
-In both cases, the trivial 'let' can be eliminated by the
-immediately following simplifier pass.
+The substitution ri[b/x] etc is done by the occurrence analyser.
+See Note [The binder-swap substitution].
There are two reasons for making this swap:
@@ -2257,20 +2296,6 @@ There are two reasons for making this swap:
The same can happen even if the scrutinee is a variable
with a cast: see Note [Case of cast]
-In both cases, in a particular alternative (pi -> ri), we only
-add the binding if
- (a) x occurs free in (pi -> ri)
- (ie it occurs in ri, but is not bound in pi)
- (b) the pi does not bind b (or the free vars of co)
-We need (a) and (b) for the inserted binding to be correct.
-
-For the alternatives where we inject the binding, we can transfer
-all x's OccInfo to b. And that is the point.
-
-Notice that
- * The deliberate shadowing of 'x'.
- * That (a) rapidly becomes false, so no bindings are injected.
-
The reason for doing these transformations /here in the occurrence
analyser/ is because it allows us to adjust the OccInfo for 'x' and
'b' as we go.
@@ -2279,15 +2304,9 @@ analyser/ is because it allows us to adjust the OccInfo for 'x' and
ri; then this transformation makes it occur just once, and hence
get inlined right away.
- * If instead we do this in the Simplifier, we don't know whether 'x'
- is used in ri, so we are forced to pessimistically zap b's OccInfo
- even though it is typically dead (ie neither it nor x appear in
- the ri). There's nothing actually wrong with zapping it, except
- that it's kind of nice to know which variables are dead. My nose
- tells me to keep this information as robustly as possible.
-
-The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
-{x=b}; it's Nothing if the binder-swap doesn't happen.
+ * If instead the Simplifier replaces occurrences of x with
+ occurrences of b, that will mess up b's occurrence info. That in
+ turn might have consequences.
There is a danger though. Consider
let v = x +# y
@@ -2299,6 +2318,75 @@ same simplifier pass that reduced (f v) to v.
I think this is just too bad. CSE will recover some of it.
+Note [The binder-swap substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The binder-swap is implemented by the occ_bs_env field of OccEnv.
+Given case x |> co of b { alts }
+we add [x :-> (b |> sym co)] to the occ_bs_env environment; this is
+done by addBndrSwap. Then, at an occurrence of a variable, we look
+up in the occ_bs_env to perform the swap. See occAnalApp.
+
+Some tricky corners:
+
+* We do the substitution before gathering occurrence info. So in
+ the above example, an occurrence of x turns into an occurrence
+ of b, and that's what we gather in the UsageDetails. It's as
+ if the binder-swap occurred before occurrence analysis.
+
+* We need care when shadowing. Suppose [x :-> b] is in occ_bs_env,
+ and we encounter:
+ - \x. blah
+ Here we want to delete the x-binding from occ_bs_env
+
+ - \b. blah
+ This is harder: we really want to delete all bindings that
+ have 'b' free in the range. That is a bit tiresome to implement,
+ so we compromise. We keep occ_bs_rng, which is the set of
+ free vars of rng(occc_bs_env). If a binder shadows any of these
+ variables, we discard all of occ_bs_env. Safe, if a bit
+ brutal. NB, however: the simplifer de-shadows the code, so the
+ next time around this won't happen.
+
+ These checks are implemented in addInScope.
+
+* The occurrence analyser itself does /not/ do cloning. It could, in
+ principle, but it'd make it a bit more complicated and there is no
+ great benefit. The simplifer uses cloning to get a no-shadowing
+ situation, the care-when-shadowing behaviour above isn't needed for
+ long.
+
+* The domain of occ_bs_env can include GlobaIds. Eg
+ case M.foo of b { alts }
+ We extend occ_bs_env with [M.foo :-> b]. That's fine.
+
+* We have to apply the substitution uniformly, including to rules and
+ unfoldings.
+
+Historical note
+---------------
+We used to do the binder-swap transformation by introducing
+a proxy let-binding, thus;
+
+ case x of b { pi -> ri }
+ ==>
+ case x of b { pi -> let x = b in ri }
+
+But that had two problems:
+
+1. If 'x' is an imported GlobalId, we'd end up with a GlobalId
+ on the LHS of a let-binding which isn't allowed. We worked
+ around this for a while by "localising" x, but it turned
+ out to be very painful #16296,
+
+2. In CorePrep we use the occurrence analyser to do dead-code
+ elimination (see Note [Dead code in CorePrep]). But that
+ occasionally led to an unlifted let-binding
+ case x of b { DEFAULT -> let x::Int# = b in ... }
+ which disobeys one of CorePrep's output invariants (no unlifted
+ let-bindings) -- see #5433.
+
+Doing a substitution (via occ_bs_env) is much better.
+
Note [Case of cast]
~~~~~~~~~~~~~~~~~~~
Consider case (x `cast` co) of b { I# ->
@@ -2307,25 +2395,12 @@ We'd like to eliminate the inner case. That is the motivation for
equation (2) in Note [Binder swap]. When we get to the inner case, we
inline x, cancel the casts, and away we go.
-Note [Binder swap on GlobalId scrutinees]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the scrutinee is a GlobalId we must take care in two ways
-
- i) In order to *know* whether 'x' occurs free in the RHS, we need its
- occurrence info. BUT, we don't gather occurrence info for
- GlobalIds. That's the reason for the (small) occ_gbl_scrut env in
- OccEnv is for: it says "gather occurrence info for these".
-
- ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
- has an External Name. See, for example, SimplEnv Note [Global Ids in
- the substitution].
-
Note [Zap case binders in proxy bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
From the original
case x of cb(dead) { p -> ...x... }
we will get
- case x of cb(live) { p -> let x = cb in ...x... }
+ case x of cb(live) { p -> ...cb... }
Core Lint never expects to find an *occurrence* of an Id marked
as Dead, so we must zap the OccInfo on cb before making the
@@ -2396,37 +2471,25 @@ binder-swap unconditionally and still get occurrence analysis
information right.
-}
-mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
--- Does three things: a) makes the occ_one_shots = OccVanilla
--- b) extends the GlobalScruts if possible
--- c) returns a proxy mapping, binding the scrutinee
--- to the case binder, if possible
-mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
- = case stripTicksTopE (const True) scrut of
- Var v -> add_scrut v case_bndr'
- Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co))
- -- See Note [Case of cast]
- _ -> (env { occ_encl = OccVanilla }, Nothing)
+addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
+-- See Note [The binder-swap substitution]
+addBndrSwap scrut case_bndr
+ env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })
+ | Just (v, rhs) <- try_swap (stripTicksTopE (const True) scrut)
+ = env { occ_bs_env = extendVarEnv swap_env v (rhs, case_bndr')
+ , occ_bs_rng = rng_vars `unionVarSet` exprFreeVars rhs }
+ | otherwise
+ = env
where
- add_scrut v rhs
- | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing)
- | otherwise = ( env { occ_encl = OccVanilla
- , occ_gbl_scrut = pe `extendVarSet` v }
- , Just (localise v, rhs) )
- -- ToDO: this isGlobalId stuff is a TEMPORARY FIX
- -- to avoid the binder-swap for GlobalIds
- -- See #16346
-
- case_bndr' = Var (zapIdOccInfo case_bndr)
- -- See Note [Zap case binders in proxy bindings]
-
- -- Localise the scrut_var before shadowing it; we're making a
- -- new binding for it, and it might have an External Name, or
- -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
- -- Also we don't want any INLINE or NOINLINE pragmas!
- localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var))
- (idType scrut_var)
+ try_swap :: OutExpr -> Maybe (OutVar, OutExpr)
+ try_swap (Var v) = Just (v, Var case_bndr')
+ try_swap (Cast (Var v) co) = Just (v, Cast (Var case_bndr') (mkSymCo co))
+ -- See Note [Case of cast]
+ try_swap _ = Nothing
+
+ case_bndr' = zapIdOccInfo case_bndr
+ -- See Note [Zap case binders in proxy bindings]
{-
************************************************************************
@@ -2437,7 +2500,6 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
Note [UsageDetails and zapping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
On many occasions, we must modify all gathered occurrence data at once. For
instance, all occurrences underneath a (non-one-shot) lambda set the
'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but
@@ -2476,45 +2538,36 @@ andUDs, orUDs
andUDs = combineUsageDetailsWith addOccInfo
orUDs = combineUsageDetailsWith orOccInfo
-andUDsList :: [UsageDetails] -> UsageDetails
-andUDsList = foldl' andUDs emptyDetails
-
-mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
-mkOneOcc env id int_cxt arity
+mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails
+mkOneOcc id int_cxt arity
| isLocalId id
- = singleton $ OneOcc { occ_in_lam = NotInsideLam
- , occ_one_br = InOneBranch
- , occ_int_cxt = int_cxt
- , occ_tail = AlwaysTailCalled arity }
- | id `elemVarSet` occ_gbl_scrut env
- = singleton noOccInfo
-
+ = emptyDetails { ud_env = unitVarEnv id occ_info }
| otherwise
= emptyDetails
where
- singleton info = emptyDetails { ud_env = unitVarEnv id info }
-
-addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
-addOneOcc ud id info
- = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info }
- `alterZappedSets` (`delVarEnv` id)
- where
- plus_zapped old new = doZapping ud id old `addOccInfo` new
+ occ_info = OneOcc { occ_in_lam = NotInsideLam
+ , occ_one_br = InOneBranch
+ , occ_int_cxt = int_cxt
+ , occ_tail = AlwaysTailCalled arity }
-addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails
-addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set
- -- It's OK to use nonDetFoldUFM here because addManyOccs commutes
+addManyOccId :: UsageDetails -> Id -> UsageDetails
+-- Add the non-committal (id :-> noOccInfo) to the usage details
+addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo }
-- Add several occurrences, assumed not to be tail calls
-addManyOccs :: Var -> UsageDetails -> UsageDetails
-addManyOccs v u | isId v = addOneOcc u v noOccInfo
- | otherwise = u
+addManyOcc :: Var -> UsageDetails -> UsageDetails
+addManyOcc v u | isId v = addManyOccId u v
+ | otherwise = u
-- Give a non-committal binder info (i.e noOccInfo) because
-- a) Many copies of the specialised thing can appear
-- b) We don't want to substitute a BIG expression inside a RULE
-- even if that's the only occurrence of the thing
-- (Same goes for INLINE.)
+addManyOccs :: UsageDetails -> VarSet -> UsageDetails
+addManyOccs usage id_set = nonDetFoldUniqSet addManyOcc usage id_set
+ -- It's OK to use nonDetFoldUFM here because addManyOcc commutes
+
delDetails :: UsageDetails -> Id -> UsageDetails
delDetails ud bndr
= ud `alterUsageDetails` (`delVarEnv` bndr)
@@ -2538,8 +2591,23 @@ markAllMany ud = ud { ud_z_many = ud_env ud }
markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud }
markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud }
+markAllInsideLamIf, markAllNonTailCalledIf :: Bool -> UsageDetails -> UsageDetails
+
+markAllInsideLamIf True ud = markAllInsideLam ud
+markAllInsideLamIf False ud = ud
+
+markAllNonTailCalledIf True ud = markAllNonTailCalled ud
+markAllNonTailCalledIf False ud = ud
+
+
zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo
+zapDetailsIf :: Bool -- If this is true
+ -> UsageDetails -- Then do zapDetails on this
+ -> UsageDetails
+zapDetailsIf True uds = zapDetails uds
+zapDetailsIf False uds = uds
+
lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails ud id
| isCoVar id -- We do not currently gather occurrence info (from types)
@@ -2595,14 +2663,17 @@ doZapping ud var occ
= doZappingByUnique ud (varUnique var) occ
doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo
-doZappingByUnique ud uniq
- = (if | in_subset ud_z_many -> markMany
- | in_subset ud_z_in_lam -> markInsideLam
- | otherwise -> id) .
- (if | in_subset ud_z_no_tail -> markNonTailCalled
- | otherwise -> id)
+doZappingByUnique (UD { ud_z_many = many
+ , ud_z_in_lam = in_lam
+ , ud_z_no_tail = no_tail })
+ uniq occ
+ = occ2
where
- in_subset field = uniq `elemVarEnvByKey` field ud
+ occ1 | uniq `elemVarEnvByKey` many = markMany occ
+ | uniq `elemVarEnvByKey` in_lam = markInsideLam occ
+ | otherwise = occ
+ occ2 | uniq `elemVarEnvByKey` no_tail = markNonTailCalled occ1
+ | otherwise = occ1
alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails
alterZappedSets ud f
@@ -2612,8 +2683,7 @@ alterZappedSets ud f
alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
alterUsageDetails ud f
- = ud { ud_env = f (ud_env ud) }
- `alterZappedSets` f
+ = ud { ud_env = f (ud_env ud) } `alterZappedSets` f
flattenUsageDetails :: UsageDetails -> UsageDetails
flattenUsageDetails ud
@@ -2623,25 +2693,26 @@ flattenUsageDetails ud
-------------------
-- See Note [Adjusting right-hand sides]
adjustRhsUsage :: Maybe JoinArity -> RecFlag
- -> [CoreBndr] -- Outer lambdas, AFTER occ anal
- -> UsageDetails -> UsageDetails
+ -> [CoreBndr] -- Outer lambdas, AFTER occ anal
+ -> UsageDetails -- From body of lambda
+ -> UsageDetails
adjustRhsUsage mb_join_arity rec_flag bndrs usage
- = maybe_mark_lam (maybe_drop_tails usage)
+ = markAllInsideLamIf (not one_shot) $
+ markAllNonTailCalledIf (not exact_join) $
+ usage
where
- maybe_mark_lam ud | one_shot = ud
- | otherwise = markAllInsideLam ud
- maybe_drop_tails ud | exact_join = ud
- | otherwise = markAllNonTailCalled ud
-
one_shot = case mb_join_arity of
Just join_arity
| isRec rec_flag -> False
| otherwise -> all isOneShotBndr (drop join_arity bndrs)
Nothing -> all isOneShotBndr bndrs
- exact_join = case mb_join_arity of
- Just join_arity -> bndrs `lengthIs` join_arity
- _ -> False
+ exact_join = exactJoin mb_join_arity bndrs
+
+exactJoin :: Maybe JoinArity -> [a] -> Bool
+exactJoin Nothing _ = False
+exactJoin (Just join_arity) args = args `lengthIs` join_arity
+ -- Remember join_arity includes type binders
type IdWithOccInfo = Id
@@ -2668,7 +2739,7 @@ tagLamBinder usage bndr
bndr' = setBinderOcc (markNonTailCalled occ) bndr
-- Don't try to make an argument into a join point
usage1 = usage `delDetails` bndr
- usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr)
+ usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)
-- This is effectively the RHS of a
-- non-join-point binding, so it's okay to use
-- addManyOccsSet, which assumes no tail calls
diff --git a/compiler/GHC/Core/Op/Simplify.hs b/compiler/GHC/Core/Op/Simplify.hs
index 5d7d91a37f..fcf2eaf168 100644
--- a/compiler/GHC/Core/Op/Simplify.hs
+++ b/compiler/GHC/Core/Op/Simplify.hs
@@ -45,7 +45,8 @@ import GHC.Core.Unfold
import GHC.Core.Utils
import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
-import GHC.Core.Rules ( mkRuleInfo, lookupRule, getRules )
+import GHC.Core.FVs ( mkRuleInfo )
+import GHC.Core.Rules ( lookupRule, getRules )
import GHC.Types.Basic ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
RecFlag(..), Arity )
import MonadUtils ( mapAccumLM, liftIO )
@@ -1422,7 +1423,7 @@ simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- fw a b x{=(a,b)} = ...
-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
simplLamBndr env bndr
- | isId bndr && isFragileUnfolding old_unf -- Special case
+ | isId bndr && hasCoreUnfolding old_unf -- Special case
= do { (env1, bndr1) <- simplBinder env bndr
; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr
old_unf (idType bndr1)
@@ -2883,7 +2884,7 @@ the unfolding (a,b), and *that* mentions b. If f has a RULE
RULE f (p, I# q) = ...
we want that rule to match, so we must extend the in-scope env with a
suitable unfolding for 'y'. It's *essential* for rule matching; but
-it's also good for case-elimintation -- suppose that 'f' was inlined
+it's also good for case-elimination -- suppose that 'f' was inlined
and did multi-level case analysis, then we'd solve it in one
simplifier sweep instead of two.
diff --git a/compiler/GHC/Core/Op/Simplify/Utils.hs b/compiler/GHC/Core/Op/Simplify/Utils.hs
index 4b85bff280..1b8c21f81b 100644
--- a/compiler/GHC/Core/Op/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Op/Simplify/Utils.hs
@@ -1872,22 +1872,26 @@ Historical note: if you use let-bindings instead of a substitution, beware of th
prepareAlts tries these things:
-1. Eliminate alternatives that cannot match, including the
- DEFAULT alternative.
+1. filterAlts: eliminate alternatives that cannot match, including
+ the DEFAULT alternative. Here "cannot match" includes knowledge
+ from GADTs
-2. If the DEFAULT alternative can match only one possible constructor,
- then make that constructor explicit.
+2. refineDefaultAlt: if the DEFAULT alternative can match only one
+ possible constructor, then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
+ See CoreUtils Note [Refine DEFAULT case alternatives]
-3. Returns a list of the constructors that cannot holds in the
- DEFAULT alternative (if there is one)
+3. combineIdenticalAlts: combine identical alternatives into a DEFAULT.
+ See CoreUtils Note [Combine identical alternatives], which also
+ says why we do this on InAlts not on OutAlts
-Here "cannot match" includes knowledge from GADTs
+4. Returns a list of the constructors that cannot holds in the
+ DEFAULT alternative (if there is one)
It's a good idea to do this stuff before simplifying the alternatives, to
avoid simplifying alternatives we know can't happen, and to come up with
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 0b1c0cccb9..dc2b203645 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -17,7 +17,7 @@ module GHC.Core.Rules (
ruleCheckProgram,
-- ** Manipulating 'RuleInfo' rules
- mkRuleInfo, extendRuleInfo, addRuleInfo,
+ extendRuleInfo, addRuleInfo,
addIdSpecialisations,
-- * Misc. CoreRule helpers
@@ -279,11 +279,6 @@ pprRulesForUser dflags rules
************************************************************************
-}
--- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
--- for putting into an 'IdInfo'
-mkRuleInfo :: [CoreRule] -> RuleInfo
-mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
-
extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
extendRuleInfo (RuleInfo rs1 fvs1) rs2
= RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)
diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index e36e4fb289..2770882d67 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -618,7 +618,7 @@ substIdInfo subst new_id info
where
old_rules = ruleInfo info
old_unf = unfoldingInfo info
- nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf)
+ nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf)
------------------
-- | Substitutes for the 'Id's within an unfolding
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 411a954428..58d460c826 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -22,9 +22,9 @@ find, unsurprisingly, a Core expression.
module GHC.Core.Unfold (
Unfolding, UnfoldingGuidance, -- Abstract types
- noUnfolding, mkImplicitUnfolding,
+ noUnfolding,
mkUnfolding, mkCoreUnfolding,
- mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
+ mkFinalUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
mkInlineUnfolding, mkInlineUnfoldingWithArity,
mkInlinableUnfolding, mkWwInlineRule,
mkCompulsoryUnfolding, mkDFunUnfolding,
@@ -48,12 +48,12 @@ import GhcPrelude
import GHC.Driver.Session
import GHC.Core
-import GHC.Core.Op.OccurAnal ( occurAnalyseExpr_NoBinderSwap )
+import GHC.Core.Op.OccurAnal ( occurAnalyseExpr )
import GHC.Core.SimpleOpt
import GHC.Core.Arity ( manifestArity )
import GHC.Core.Utils
import GHC.Types.Id
-import GHC.Types.Demand ( isBottomingSig )
+import GHC.Types.Demand ( StrictSig, isBottomingSig )
import GHC.Core.DataCon
import GHC.Types.Literal
import PrimOp
@@ -80,14 +80,22 @@ import Data.List
************************************************************************
-}
-mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding
-mkTopUnfolding dflags is_bottoming rhs
- = mkUnfolding dflags InlineRhs True is_bottoming rhs
+mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
+-- "Final" in the sense that this is a GlobalId that will not be further
+-- simplified; so the unfolding should be occurrence-analysed
+mkFinalUnfolding dflags src strict_sig expr
+ = mkUnfolding dflags src
+ True {- Top level -}
+ (isBottomingSig strict_sig)
+ expr
+
+mkCompulsoryUnfolding :: CoreExpr -> Unfolding
+mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
+ = mkCoreUnfolding InlineCompulsory True
+ (simpleOptExpr unsafeGlobalDynFlags expr)
+ (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
+ , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
-mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding
--- For implicit Ids, do a tiny bit of optimising first
-mkImplicitUnfolding dflags expr
- = mkTopUnfolding dflags False (simpleOptExpr dflags expr)
-- Note [Top-level flag on inline rules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -103,7 +111,7 @@ mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding bndrs con ops
= DFunUnfolding { df_bndrs = bndrs
, df_con = con
- , df_args = map occurAnalyseExpr_NoBinderSwap ops }
+ , df_args = map occurAnalyseExpr ops }
-- See Note [Occurrence analysis of unfoldings]
mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding
@@ -113,13 +121,6 @@ mkWwInlineRule dflags expr arity
(UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boringCxtNotOk })
-mkCompulsoryUnfolding :: CoreExpr -> Unfolding
-mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
- = mkCoreUnfolding InlineCompulsory True
- (simpleOptExpr unsafeGlobalDynFlags expr)
- (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
- , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
-
mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
-- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Op.WorkWrap
mkWorkerUnfolding dflags work_fn
@@ -309,20 +310,6 @@ I'm a bit worried that it's possible for the same kind of problem
to arise for non-0-ary functions too, but let's wait and see.
-}
-mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
- -> UnfoldingGuidance -> Unfolding
--- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding src top_lvl expr guidance
- = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr,
- -- See Note [Occurrence analysis of unfoldings]
- uf_src = src,
- uf_is_top = top_lvl,
- uf_is_value = exprIsHNF expr,
- uf_is_conlike = exprIsConLike expr,
- uf_is_work_free = exprIsWorkFree expr,
- uf_expandable = exprIsExpandable expr,
- uf_guidance = guidance }
-
mkUnfolding :: DynFlags -> UnfoldingSource
-> Bool -- Is top-level
-> Bool -- Definitely a bottoming binding
@@ -331,21 +318,28 @@ mkUnfolding :: DynFlags -> UnfoldingSource
-> Unfolding
-- Calculates unfolding guidance
-- Occurrence-analyses the expression before capturing it
-mkUnfolding dflags src is_top_lvl is_bottoming expr
- = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr,
+mkUnfolding dflags src top_lvl is_bottoming expr
+ = mkCoreUnfolding src top_lvl expr guidance
+ where
+ is_top_bottoming = top_lvl && is_bottoming
+ guidance = calcUnfoldingGuidance dflags is_top_bottoming expr
+ -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
+ -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+
+mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
+ -> UnfoldingGuidance -> Unfolding
+-- Occurrence-analyses the expression before capturing it
+mkCoreUnfolding src top_lvl expr guidance
+ = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
-- See Note [Occurrence analysis of unfoldings]
uf_src = src,
- uf_is_top = is_top_lvl,
+ uf_is_top = top_lvl,
uf_is_value = exprIsHNF expr,
uf_is_conlike = exprIsConLike expr,
- uf_expandable = exprIsExpandable expr,
uf_is_work_free = exprIsWorkFree expr,
+ uf_expandable = exprIsExpandable expr,
uf_guidance = guidance }
- where
- is_top_bottoming = is_top_lvl && is_bottoming
- guidance = calcUnfoldingGuidance dflags is_top_bottoming expr
- -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))!
- -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+
{-
Note [Occurrence analysis of unfoldings]
@@ -366,39 +360,6 @@ But more generally, the simplifier is designed on the
basis that it is looking at occurrence-analysed expressions, so better
ensure that they actually are.
-We use occurAnalyseExpr_NoBinderSwap instead of occurAnalyseExpr;
-see Note [No binder swap in unfoldings].
-
-Note [No binder swap in unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The binder swap can temporarily violate Core Lint, by assigning
-a LocalId binding to a GlobalId. For example, if A.foo{r872}
-is a GlobalId with unique r872, then
-
- case A.foo{r872} of bar {
- K x -> ...(A.foo{r872})...
- }
-
-gets transformed to
-
- case A.foo{r872} of bar {
- K x -> let foo{r872} = bar
- in ...(A.foo{r872})...
-
-This is usually not a problem, because the simplifier will transform
-this to:
-
- case A.foo{r872} of bar {
- K x -> ...(bar)...
-
-However, after occurrence analysis but before simplification, this extra 'let'
-violates the Core Lint invariant that we do not have local 'let' bindings for
-GlobalIds. That seems (just) tolerable for the occurrence analysis that happens
-just before the Simplifier, but not for unfoldings, which are Linted
-independently.
-As a quick workaround, we disable binder swap in this module.
-See #16288 and #16296 for further plans.
-
Note [Calculate unfolding guidance on the non-occ-anal'd expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we give the non-occur-analysed expression to
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 4663f54b26..526ba34fd0 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -696,7 +696,7 @@ filterAlts _tycon inst_tys imposs_cons alts
impossible_alt _ _ = False
-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.
--- See Note [Refine Default Alts]
+-- See Note [Refine DEFAULT case alternatives]
refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders
-> TyCon -- ^ Type constructor of scrutinee's type
-> [Type] -- ^ Type arguments of scrutinee's type
@@ -739,95 +739,62 @@ refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
| otherwise -- The common case
= (False, all_alts)
-{- Note [Refine Default Alts]
-
-refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one
-possible value it could be.
+{- Note [Refine DEFAULT case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+refineDefaultAlt replaces the DEFAULT alt with a constructor if there
+is one possible value it could be.
The simplest example being
+ foo :: () -> ()
+ foo x = case x of !_ -> ()
+which rewrites to
+ foo :: () -> ()
+ foo x = case x of () -> ()
+
+There are two reasons in general why replacing a DEFAULT alternative
+with a specific constructor is desirable.
+
+1. We can simplify inner expressions. For example
+
+ data Foo = Foo1 ()
+
+ test :: Foo -> ()
+ test x = case x of
+ DEFAULT -> mid (case x of
+ Foo1 x1 -> x1)
+
+ refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then
+ x becomes bound to `Foo ip1` so is inlined into the other case
+ which causes the KnownBranch optimisation to kick in. If we don't
+ refine DEFAULT to `Foo ip1`, we are left with both case expressions.
+
+2. combineIdenticalAlts does a better job. For exapple (Simon Jacobi)
+ data D = C0 | C1 | C2
+
+ case e of
+ DEFAULT -> e0
+ C0 -> e1
+ C1 -> e1
+
+ When we apply combineIdenticalAlts to this expression, it can't
+ combine the alts for C0 and C1, as we already have a default case.
+ But if we apply refineDefaultAlt first, we get
+ case e of
+ C0 -> e1
+ C1 -> e1
+ C2 -> e0
+ and combineIdenticalAlts can turn that into
+ case e of
+ DEFAULT -> e1
+ C2 -> e0
-foo :: () -> ()
-foo x = case x of !_ -> ()
-
-rewrites to
-
-foo :: () -> ()
-foo x = case x of () -> ()
-
-There are two reasons in general why this is desirable.
-
-1. We can simplify inner expressions
-
-In this example we can eliminate the inner case by refining the outer case.
-If we don't refine it, we are left with both case expressions.
-
-```
-{-# LANGUAGE BangPatterns #-}
-module Test where
-
-mid x = x
-{-# NOINLINE mid #-}
-
-data Foo = Foo1 ()
-
-test :: Foo -> ()
-test x =
- case x of
- !_ -> mid (case x of
- Foo1 x1 -> x1)
-
-```
-
-refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x
-becomes bound to `Foo ip1` so is inlined into the other case which
-causes the KnownBranch optimisation to kick in.
-
-
-2. combineIdenticalAlts does a better job
-
-Simon Jakobi also points out that that combineIdenticalAlts will do a better job
-if we refine the DEFAULT first.
-
-```
-data D = C0 | C1 | C2
-
-case e of
- DEFAULT -> e0
- C0 -> e1
- C1 -> e1
-```
-
-When we apply combineIdenticalAlts to this expression, it can't
-combine the alts for C0 and C1, as we already have a default case.
-
-If we apply refineDefaultAlt first, we get
-
-```
-case e of
- C0 -> e1
- C1 -> e1
- C2 -> e0
-```
-
-and combineIdenticalAlts can turn that into
-
-```
-case e of
- DEFAULT -> e1
- C2 -> e0
-```
-
-It isn't obvious that refineDefaultAlt does this but if you look at its one call
-site in GHC.Core.Op.Simplify.Utils then the `imposs_deflt_cons` argument is
-populated with constructors which are matched elsewhere.
-
--}
-
-
-
+ It isn't obvious that refineDefaultAlt does this but if you look
+ at its one call site in GHC.Core.Op.Simplify.Utils then the
+ `imposs_deflt_cons` argument is populated with constructors which
+ are matched elsewhere.
-{- Note [Combine identical alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Combine identical alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If several alternatives are identical, merge them into a single
DEFAULT alternative. I've occasionally seen this making a big
difference:
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index b6a14b4af5..5cdf084a33 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -347,10 +347,7 @@ The way we fix this is to:
* In cloneBndr, drop all unfoldings/rules
* In deFloatTop, run a simple dead code analyser on each top-level
- RHS to drop the dead local bindings. For that call to OccAnal, we
- disable the binder swap, else the occurrence analyser sometimes
- introduces new let bindings for cased binders, which lead to the bug
- in #5433.
+ RHS to drop the dead local bindings.
The reason we don't just OccAnal the whole output of CorePrep is that
the tidier ensures that all top-level binders are GlobalIds, so they
@@ -1316,14 +1313,13 @@ deFloatTop :: Floats -> [CoreBind]
deFloatTop (Floats _ floats)
= foldrOL get [] floats
where
- get (FloatLet b) bs = occurAnalyseRHSs b : bs
- get (FloatCase body var _ _ _) bs
- = occurAnalyseRHSs (NonRec var body) : bs
+ get (FloatLet b) bs = get_bind b : bs
+ get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs
get b _ = pprPanic "corePrepPgm" (ppr b)
-- See Note [Dead code in CorePrep]
- occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
- occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
+ get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)
+ get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
---------------------------------------------------------------------------
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 6459902a52..4bd11d227d 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -1239,8 +1239,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
| otherwise
= minimal_unfold_info
minimal_unfold_info = zapUnfolding unf_info
- unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
- is_bot = isBottomingSig final_sig
+ unf_from_rhs = mkFinalUnfolding dflags InlineRhs final_sig tidy_rhs
-- NB: do *not* expose the worker if show_unfold is off,
-- because that means this thing is a loop breaker or
-- marked NOINLINE or something like that
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 0024d92037..559587664e 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -63,7 +63,6 @@ import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Core.Op.OccurAnal ( occurAnalyseExpr )
-import GHC.Types.Demand
import GHC.Types.Module
import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
@@ -1506,14 +1505,12 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
| otherwise = InlineRhs
; return $ case mb_expr of
Nothing -> NoUnfolding
- Just expr -> mkUnfolding dflags unf_src
- True {- Top level -}
- (isBottomingSig strict_sig)
- expr
+ Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr
}
where
-- Strictness should occur before unfolding!
strict_sig = strictnessInfo info
+
tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr True toplvl name if_expr
; return (case mb_expr of
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index 538556c6af..4fbcf47a02 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -92,6 +92,7 @@ import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Stg.Syntax
import Outputable
+import GHC.Types.Basic (isWeakLoopBreaker)
import GHC.Types.Var.Env
import GHC.Core (AltCon(..))
import Data.List (mapAccumL)
@@ -391,6 +392,7 @@ stgCsePairs env0 ((b,e):pairs)
stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
stgCseRhs env bndr (StgRhsCon ccs dataCon args)
| Just other_bndr <- envLookup dataCon args' env
+ , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers]
= let env' = addSubst bndr other_bndr env
in (Nothing, env')
| otherwise
@@ -399,6 +401,7 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon args)
pair = (bndr, StgRhsCon ccs dataCon args')
in (Just pair, env')
where args' = substArgs env args
+
stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)
= let (env1, args') = substBndrs env args
env2 = forgetCse env1 -- See note [Free variables of an StgClosure]
@@ -416,6 +419,21 @@ mkStgCase scrut bndr ty alts | all isBndr alts = scrut
isBndr _ = False
+{- Note [Care with loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When doing CSE on a letrec we must be careful about loop
+breakers. Consider
+ rec { y = K z
+ ; z = K z }
+Now if, somehow (and wrongly)), y and z are both marked as
+loop-breakers, we do *not* want to drop the (z = K z) binding
+in favour of a substitution (z :-> y).
+
+I think this bug will only show up if the loop-breaker-ness is done
+wrongly (itself a bug), but it still seems better to do the right
+thing regardless.
+-}
+
-- Utilities
-- | This function short-cuts let-bindings that are now obsolete
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index e731fc1449..9f3b192848 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -86,7 +86,8 @@ module GHC.Types.Id.Info (
import GhcPrelude
-import GHC.Core
+import GHC.Core hiding( hasCoreUnfolding )
+import GHC.Core( hasCoreUnfolding )
import GHC.Core.Class
import {-# SOURCE #-} PrimOp (PrimOp)
@@ -567,8 +568,8 @@ zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })
zapFragileUnfolding :: Unfolding -> Unfolding
zapFragileUnfolding unf
- | isFragileUnfolding unf = noUnfolding
- | otherwise = unf
+ | hasCoreUnfolding unf = noUnfolding
+ | otherwise = unf
zapUnfolding :: Unfolding -> Unfolding
-- Squash all unfolding info, preserving only evaluated-ness
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 43b7aae72d..58a02f2f3d 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -42,7 +42,6 @@ module GHC.Types.Id.Make (
import GhcPrelude
-import GHC.Core.Rules
import TysPrim
import TysWiredIn
import GHC.Core.Op.ConstantFold
@@ -52,7 +51,8 @@ import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import TcType
import GHC.Core.Make
-import GHC.Core.Utils ( mkCast, mkDefaultCase )
+import GHC.Core.FVs ( mkRuleInfo )
+import GHC.Core.Utils ( mkCast, mkDefaultCase )
import GHC.Core.Unfold
import GHC.Types.Literal
import GHC.Core.TyCon
diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr
index 56da989d37..e9496e19e6 100644
--- a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr
+++ b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr
@@ -1,5 +1,5 @@
Simplifier ticks exhausted
- When trying UnfoldingDone delta
+ When trying UnfoldingDone delta1
To increase the limit, use -fsimpl-tick-factor=N (default 100).
If you need to increase the limit substantially, please file a
@@ -12,4 +12,4 @@ Simplifier ticks exhausted
simplifier non-termination has been judged acceptable.
To see detailed counts use -ddump-simpl-stats
- Total ticks: 140086
+ Total ticks: 140082
diff --git a/testsuite/tests/simplCore/should_compile/T17901.stdout b/testsuite/tests/simplCore/should_compile/T17901.stdout
index 406e81ef5f..99969cc0c1 100644
--- a/testsuite/tests/simplCore/should_compile/T17901.stdout
+++ b/testsuite/tests/simplCore/should_compile/T17901.stdout
@@ -4,13 +4,11 @@
C -> wombat1 T17901.C
= \ (@p) (wombat1 :: T -> p) (x :: T) ->
case x of wild { __DEFAULT -> wombat1 wild }
- (wombat2 [Occ=Once*!] :: S -> p)
- SA _ [Occ=Dead] -> wombat2 wild;
- SB -> wombat2 T17901.SB
+ Tmpl= \ (@p) (wombat2 [Occ=Once!] :: S -> p) (x [Occ=Once] :: S) ->
+ case x of wild [Occ=Once] { __DEFAULT -> wombat2 wild }}]
= \ (@p) (wombat2 :: S -> p) (x :: S) ->
case x of wild { __DEFAULT -> wombat2 wild }
- (wombat3 [Occ=Once*!] :: W -> p)
- WB -> wombat3 T17901.WB;
- WA _ [Occ=Dead] -> wombat3 wild
+ Tmpl= \ (@p) (wombat3 [Occ=Once!] :: W -> p) (x [Occ=Once] :: W) ->
+ case x of wild [Occ=Once] { __DEFAULT -> wombat3 wild }}]
= \ (@p) (wombat3 :: W -> p) (x :: W) ->
case x of wild { __DEFAULT -> wombat3 wild }
diff --git a/testsuite/tests/simplCore/should_compile/T7360.hs b/testsuite/tests/simplCore/should_compile/T7360.hs
index 2bf31f200a..4da49041f8 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.hs
+++ b/testsuite/tests/simplCore/should_compile/T7360.hs
@@ -6,7 +6,7 @@ module T7360 where
import GHC.List as L
data Foo = Foo1 | Foo2 | Foo3 !Int
-
+
fun1 :: Foo -> ()
{-# NOINLINE fun1 #-}
fun1 x = case x of
@@ -14,7 +14,7 @@ fun1 x = case x of
Foo2 -> ()
Foo3 {} -> ()
-fun2 x = (fun1 Foo1, -- Keep -ddump-simpl output
+fun2 x = (fun1 Foo1, -- Keep -ddump-simpl output
-- in a predictable order
case x of
[] -> L.length x
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index b74aee564e..45c88f376e 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 114, types: 53, coercions: 0, joins: 0/0}
+ = {terms: 106, types: 47, coercions: 0, joins: 0/0}
-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
T7360.$WFoo3 [InlPrag=INLINE[0]] :: Int -> Foo
@@ -25,21 +25,13 @@ fun1 [InlPrag=NOINLINE] :: Foo -> ()
fun1 = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Tuple.() }
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T7360.fun5 :: ()
+T7360.fun4 :: ()
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
-T7360.fun5 = fun1 T7360.Foo1
+T7360.fun4 = fun1 T7360.Foo1
--- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T7360.fun4 :: Int
-[GblId,
- Cpr=m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
-T7360.fun4 = GHC.Types.I# 0#
-
--- RHS size: {terms: 16, types: 13, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 11, types: 8, coercions: 0, joins: 0/0}
fun2 :: forall {a}. [a] -> ((), Int)
[GblId,
Arity=1,
@@ -48,24 +40,18 @@ fun2 :: forall {a}. [a] -> ((), Int)
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
- Tmpl= \ (@a) (x [Occ=Once!] :: [a]) ->
- (T7360.fun5,
- case x of wild [Occ=Once] {
- [] -> T7360.fun4;
- : _ [Occ=Dead] _ [Occ=Dead] ->
- case GHC.List.$wlenAcc @a wild 0# of ww2 [Occ=Once] { __DEFAULT ->
- GHC.Types.I# ww2
- }
+ Tmpl= \ (@a) (x [Occ=Once] :: [a]) ->
+ (T7360.fun4,
+ case x of wild [Occ=Once] { __DEFAULT ->
+ case GHC.List.$wlenAcc @a wild 0# of ww2 [Occ=Once] { __DEFAULT ->
+ GHC.Types.I# ww2
+ }
})}]
fun2
= \ (@a) (x :: [a]) ->
- (T7360.fun5,
- case x of wild {
- [] -> T7360.fun4;
- : ds ds1 ->
- case GHC.List.$wlenAcc @a wild 0# of ww2 { __DEFAULT ->
- GHC.Types.I# ww2
- }
+ (T7360.fun4,
+ case GHC.List.$wlenAcc @a x 0# of ww2 { __DEFAULT ->
+ GHC.Types.I# ww2
})
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
View Lorry Controller Status