[Git][ghc/ghc][master] Re-engineer the binder-swap transformation

Marge Bot gitlab at gitlab.haskell.org
Thu Apr 2 05:46:15 UTC 2020



 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
b943b25d by Simon Peyton Jones at 2020-04-02T01:45:58-04:00
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

- - - - -


19 changed files:

- compiler/GHC/Core.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Op/OccurAnal.hs
- compiler/GHC/Core/Op/Simplify.hs
- compiler/GHC/Core/Op/Simplify/Utils.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/dependent/should_compile/dynamic-paper.stderr
- testsuite/tests/simplCore/should_compile/T17901.stdout
- testsuite/tests/simplCore/should_compile/T7360.hs
- testsuite/tests/simplCore/should_compile/T7360.stderr


Changes:

=====================================
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)


=====================================
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


=====================================
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 at 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


=====================================
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.
 


=====================================
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


=====================================
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)


=====================================
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


=====================================
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


=====================================
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:


=====================================
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]
 
 ---------------------------------------------------------------------------
 


=====================================
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


=====================================
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


=====================================
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


=====================================
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


=====================================
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


=====================================
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


=====================================
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 }


=====================================
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


=====================================
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 it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b943b25d0786da64031ac63ddf9b4574182057bb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b943b25d0786da64031ac63ddf9b4574182057bb
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200402/339ab6c7/attachment-0001.html>


More information about the ghc-commits mailing list