Fix a huge space leak in the mighty Simplifier

This long-standing, terrible, adn somewhat subtle bug was exposed
by Trac #10370, thanks to Reid Barton's brilliant test case (comment:3).

The effect is large on the Trac #10370 test.
Here is what the profile report says:

Before:
 total time  =       24.35 secs   (24353 ticks @ 1000 us, 1 processor)
 total alloc = 11,864,360,816 bytes  (excludes profiling overheads)

After:
 total time  =       21.16 secs   (21160 ticks @ 1000 us, 1 processor)
 total alloc = 7,947,141,136 bytes  (excludes profiling overheads)

The /combined/ effect of the tidyOccName fix, plus this one, is dramtic
for Trac #10370.  Here is what +RTS -s says:

Before:
  15,490,210,952 bytes allocated in the heap
   1,783,919,456 bytes maximum residency (20 sample(s))

  MUT     time   30.117s  ( 31.383s elapsed)
  GC      time   90.103s  ( 90.107s elapsed)
  Total   time  120.843s  (122.065s elapsed)

After:
   7,928,671,936 bytes allocated in the heap
      52,914,832 bytes maximum residency (25 sample(s))

  MUT     time   13.912s  ( 15.110s elapsed)
  GC      time    6.809s  (  6.808s elapsed)
  Total   time   20.789s  ( 21.954s elapsed)

- Heap allocation halved
- Residency cut by a factor of more than 30.
- ELapsed time cut by a factor of 6

Not bad!

The details
~~~~~~~~~~~
The culprit was SimplEnv.mkCoreSubst, which used mapVarEnv to do some
impedence-matching from the substitituion used by the simplifier to
the one used by CoreSubst.  But the impedence-mactching was recursive!

  mk_subst tv_env cv_env id_env
    = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)

  fiddle (DoneEx e)          = e
  fiddle (DoneId v)          = Var v
  fiddle (ContEx tv cv id e) = CoreSubst.substExpr (mk_subst tv cv id) e

Inside fiddle, in the ContEx case, we may do another whole level of
fiddle.  And so on.  Moreover, UniqFM (which is built on Data.IntMap) is
strict, so the fiddling is done eagerly.  I didn't wok through all the
details but the result is a gargatuan blow-up of entirely unnecessary work.

Laziness would make this go away, I think, but I don't want to mess
with IntMap.  And in any case, the impedence matching is a royal pain.

In the end I simply ceased trying to use CoreSubst.substExpr in the
simplifier, and instead just use simplExpr.  That does mean bit of
duplication; e.g.  new code for simplRules.  But it's not a big deal
and it's far more direct and easy to reason about.

A bit of knock-on refactoring:

 * Data type ArgSummary moves to CoreUnfold.

 * interestingArg moves from CoreUnfold to SimplUtils, and gets a
   SimplEnv argument which can be used when we encounter a variable.

 * simplLamBndrs, addBndrRules move from SimplEnv to Simplify
   (because they now calls simplUnfolding, simplRules resp)

 * SimplUtils.substExpr, substUnfolding, mkCoreSubst die completely

 * In Simplify some several functions that were previously pure
   substitution-based functions are now monadic:
     - addBndrRules, simplRule
     - addCoerce, add_coerce in simplCast

 * In case 2c of Simplify.rebuildCase, there was a pretty disgusting
   expression-substitution taking place for 'rhs'; and we really don't
   want to make that monadic becuase 'rhs' can be big.
   Solution: reduce the arity of the rules for seq.
   See Note [User-defined RULES for seq] in MkId.

1 files changed, 208 insertions, 115 deletions

diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index aee62000fe..d708f4bf85 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -6,7 +6,7 @@
 
 {-# LANGUAGE CPP #-}
 
-module Simplify ( simplTopBinds, simplExpr ) where
+module Simplify ( simplTopBinds, simplExpr, simplRule ) where
 
 #include "HsVersions.h"
 
@@ -21,7 +21,7 @@ import Id
 import MkId             ( seqId, voidPrimId )
 import MkCore           ( mkImpossibleExpr, castBottomExpr )
 import IdInfo
-import Name             ( mkSystemVarName, isExternalName )
+import Name             ( Name, mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType_maybe )
@@ -36,14 +36,13 @@ import CoreUnfold
 import CoreUtils
 import CoreArity
 --import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
-import Rules            ( lookupRule, getRules )
+import Rules            ( mkSpecInfo, lookupRule, getRules )
 import TysPrim          ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
 import Maybes           ( orElse )
 --import Unique           ( hasKey ) -- temporalily commented out. See #8326
 import Control.Monad
-import Data.List        ( mapAccumL )
 import Outputable
 import FastString
 import Pair
@@ -234,9 +233,8 @@ simplTopBinds env0 binds0
                                       ; simpl_binds env' binds }
 
     simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
-    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
-        where
-          (env', b') = addBndrRules env b (lookupRecBndr env b)
+    simpl_bind env (NonRec b r) = do { (env', b') <- addBndrRules env b (lookupRecBndr env b)
+                                     ; simplRecOrTopPair env' TopLevel NonRecursive b b' r }
 
 {-
 ************************************************************************
@@ -253,17 +251,17 @@ simplRecBind :: SimplEnv -> TopLevelFlag
              -> [(InId, InExpr)]
              -> SimplM SimplEnv
 simplRecBind env0 top_lvl pairs0
-  = do  { let (env_with_info, triples) = mapAccumL add_rules env0 pairs0
+  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
         ; env1 <- go (zapFloats env_with_info) triples
         ; return (env0 `addRecFloats` env1) }
         -- addFloats adds the floats from env1,
         -- _and_ updates env0 with the in-scope set from env1
   where
-    add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr))
+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
         -- Add the (substituted) rules to the binder
-    add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs))
-        where
-          (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr)
+    add_rules env (bndr, rhs)
+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr)
+             ; return (env', (bndr, bndr', rhs)) }
 
     go env [] = return env
 
@@ -678,7 +676,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
       ; (new_arity, final_rhs) <- tryEtaExpandRhs env new_bndr new_rhs
 
         -- Simplify the unfolding
-      ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
+      ; new_unfolding <- simplLetUnfolding env top_lvl old_bndr final_rhs old_unf
 
       ; dflags <- getDynFlags
       ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info
@@ -729,7 +727,7 @@ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
 -- INVARIANT: the arity is correct on the incoming binders
 
 addPolyBind top_lvl env (NonRec poly_id rhs)
-  = do  { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
+  = do  { unfolding <- simplLetUnfolding env top_lvl poly_id rhs noUnfolding
                         -- Assumes that poly_id did not have an INLINE prag
                         -- which is perhaps wrong.  ToDo: think about this
         ; let final_id = setIdInfo poly_id $
@@ -743,66 +741,8 @@ addPolyBind _ env bind@(Rec _)
         -- without adding unfoldings etc.  At worst this leads to
         -- more simplifier iterations
 
-------------------------------
-simplUnfolding :: SimplEnv-> TopLevelFlag
-               -> InId
-               -> OutExpr
-               -> Unfolding -> SimplM Unfolding
--- Note [Setting the new unfolding]
-simplUnfolding env top_lvl id new_rhs unf
-  = case unf of
-      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
-        -> do { (env', bndrs') <- simplBinders rule_env bndrs
-              ; args' <- mapM (simplExpr env') args
-              ; return (mkDFunUnfolding bndrs' con args') }
-
-      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
-        | isStableSource src
-        -> do { expr' <- simplExpr rule_env expr
-              ; case guide of
-                  UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok }  -- Happens for INLINE things
-                     -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok
-                                             , ug_boring_ok = inlineBoringOk expr' }
-                        -- Refresh the boring-ok flag, in case expr'
-                        -- has got small. This happens, notably in the inlinings
-                        -- for dfuns for single-method classes; see
-                        -- Note [Single-method classes] in TcInstDcls.
-                        -- A test case is Trac #4138
-                        in return (mkCoreUnfolding src is_top_lvl expr' guide')
-                            -- See Note [Top-level flag on inline rules] in CoreUnfold
-
-                  _other              -- Happens for INLINABLE things
-                     -> bottoming `seq` -- See Note [Force bottoming field]
-                        do { dflags <- getDynFlags
-                           ; return (mkUnfolding dflags src is_top_lvl bottoming expr') } }
-                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-                -- unfolding, and we need to make sure the guidance is kept up
-                -- to date with respect to any changes in the unfolding.
-
-      _other -> bottoming `seq`  -- See Note [Force bottoming field]
-                do { dflags <- getDynFlags
-                   ; return (mkUnfolding dflags InlineRhs is_top_lvl bottoming new_rhs) }
-                     -- We make an  unfolding *even for loop-breakers*.
-                     -- Reason: (a) It might be useful to know that they are WHNF
-                     --         (b) In TidyPgm we currently assume that, if we want to
-                     --             expose the unfolding then indeed we *have* an unfolding
-                     --             to expose.  (We could instead use the RHS, but currently
-                     --             we don't.)  The simple thing is always to have one.
-  where
-    bottoming = isBottomingId id
-    is_top_lvl = isTopLevel top_lvl
-    act      = idInlineActivation id
-    rule_env = updMode (updModeForStableUnfoldings act) env
-               -- See Note [Simplifying inside stable unfoldings] in SimplUtils
-
-{-
-Note [Force bottoming field]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to force bottoming, or the new unfolding holds
-on to the old unfolding (which is part of the id).
-
-Note [Arity decrease]
-~~~~~~~~~~~~~~~~~~~~~
+{- Note [Arity decrease]
+~~~~~~~~~~~~~~~~~~~~~~~~
 Generally speaking the arity of a binding should not decrease.  But it *can*
 legitimately happen because of RULES.  Eg
         f = g Int
@@ -824,22 +764,6 @@ Here opInt has arity 1; but when we apply the rule its arity drops to 0.
 That's why Specialise goes to a little trouble to pin the right arity
 on specialised functions too.
 
-Note [Setting the new unfolding]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
-  should do nothing at all, but simplifying gently might get rid of
-  more crap.
-
-* If not, we make an unfolding from the new RHS.  But *only* for
-  non-loop-breakers. Making loop breakers not have an unfolding at all
-  means that we can avoid tests in exprIsConApp, for example.  This is
-  important: if exprIsConApp says 'yes' for a recursive thing, then we
-  can get into an infinite loop
-
-If there's an stable unfolding on a loop breaker (which happens for
-INLINEABLE), we hang on to the inlining.  It's pretty dodgy, but the
-user did say 'INLINE'.  May need to revisit this choice.
-
 Note [Setting the demand info]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If the unfolding is a value, the demand info may
@@ -1204,14 +1128,14 @@ rebuild env expr cont
 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
           -> SimplM (SimplEnv, OutExpr)
 simplCast env body co0 cont0
-  = do  { co1 <- simplCoercion env co0
-        ; -- pprTrace "simplCast" (ppr co1) $
-          simplExprF env body (addCoerce co1 cont0) }
+  = do  { co1   <- simplCoercion env co0
+        ; cont1 <- addCoerce co1 cont0
+        ; simplExprF env body cont1 }
   where
        addCoerce co cont = add_coerce co (coercionKind co) cont
 
        add_coerce _co (Pair s1 k1) cont     -- co :: ty~ty
-         | s1 `eqType` k1 = cont    -- is a no-op
+         | s1 `eqType` k1 = return cont    -- is a no-op
 
        add_coerce co1 (Pair s1 _k2) (CastIt co2 cont)
          | (Pair _l1 t1) <- coercionKind co2
@@ -1224,15 +1148,16 @@ simplCast env body co0 cont0
                 -- we may find  (coerce T (coerce S (\x.e))) y
                 -- and we'd like it to simplify to e[y/x] in one round
                 -- of simplification
-         , s1 `eqType` t1  = cont            -- The coerces cancel out
-         | otherwise       = CastIt (mkTransCo co1 co2) cont
+         , s1 `eqType` t1  = return cont     -- The coerces cancel out
+         | otherwise       = return (CastIt (mkTransCo co1 co2) cont)
 
        add_coerce co (Pair s1s2 _t1t2) cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
                 -- This implements the PushT rule from the paper
          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
          = ASSERT( isTyVar tyvar )
-           cont { sc_cont = addCoerce new_cast tail }
+           do { cont' <- addCoerce new_cast tail
+              ; return (cont { sc_cont = cont' }) }
          where
            new_cast = mkInstCo co arg_ty
 
@@ -1254,19 +1179,28 @@ simplCast env body co0 cont0
                 -- But it isn't a common case.
                 --
                 -- Example of use: Trac #995
-         = ApplyToVal { sc_arg  = mkCast arg' (mkSymCo co1)
-                      , sc_env  = zapSubstEnv arg_se
-                      , sc_dup  = dup
-                      , sc_cont = addCoerce co2 cont }
+         = do { (dup', arg_se', arg') <- simplArg env dup arg_se arg
+              ; cont'                <- addCoerce co2 cont
+              ; return (ApplyToVal { sc_arg  = mkCast arg' (mkSymCo co1)
+                                   , sc_env  = arg_se'
+                                   , sc_dup  = dup'
+                                   , sc_cont = cont' }) }
          where
            -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
            -- t2 ~ s2 with left and right on the curried form:
            --    (->) t1 t2 ~ (->) s1 s2
            [co1, co2] = decomposeCo 2 co
-           arg'       = substExpr (text "move-cast") arg_se' arg
-           arg_se'    = arg_se `setInScope` env
 
-       add_coerce co _ cont = CastIt co cont
+       add_coerce co _ cont = return (CastIt co cont)
+
+simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr
+         -> SimplM (DupFlag, StaticEnv, OutExpr)
+simplArg env dup_flag arg_env arg
+  | isSimplified dup_flag
+  = return (dup_flag, arg_env, arg)
+  | otherwise
+  = do { arg' <- simplExpr (arg_env `setInScope` env) arg
+       ; return (Simplified, zapSubstEnv arg_env, arg') }
 
 {-
 ************************************************************************
@@ -1325,6 +1259,29 @@ simplLam env bndrs body cont
         ; new_lam <- mkLam bndrs' body' cont
         ; rebuild env' new_lam cont }
 
+simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
+
+-------------
+simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
+-- Used for lambda binders.  These sometimes have unfoldings added by
+-- the worker/wrapper pass that must be preserved, because they can't
+-- be reconstructed from context.  For example:
+--      f x = case x of (a,b) -> fw a b x
+--      fw a b x{=(a,b)} = ...
+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
+simplLamBndr env bndr
+  | isId bndr && hasSomeUnfolding old_unf   -- Special case
+  = do { (env1, bndr1) <- simplBinder env bndr
+       ; unf'          <- simplUnfolding env1 NotTopLevel bndr old_unf
+       ; let bndr2 = bndr1 `setIdUnfolding` unf'
+       ; return (modifyInScope env1 bndr2, bndr2) }
+
+  | otherwise
+  = simplBinder env bndr                -- Normal case
+  where
+    old_unf = idUnfolding bndr
+
 ------------------
 simplNonRecE :: SimplEnv
              -> InBndr                  -- The binder
@@ -1371,7 +1328,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
            | otherwise
            -> ASSERT( not (isTyVar bndr) )
               do { (env1, bndr1) <- simplNonRecBndr env bndr
-                 ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
+                 ; (env2, bndr2) <- addBndrRules env1 bndr bndr1
                  ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
                  ; simplLam env3 bndrs body cont }
 
@@ -1929,18 +1886,20 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
   --     b) a rule for seq applies
   -- See Note [User-defined RULES for seq] in MkId
   | is_plain_seq
-  = do { let rhs' = substExpr (text "rebuild-case") env rhs
-             env' = zapSubstEnv env
-             scrut_ty = substTy env (idType case_bndr)
+  = do { let scrut_ty = exprType scrut
+             rhs_ty   = substTy env (exprType rhs)
              out_args = [ TyArg { as_arg_ty  = scrut_ty
                                 , as_hole_ty = seq_id_ty }
-                        , TyArg { as_arg_ty  = exprType rhs'
+                        , TyArg { as_arg_ty  = rhs_ty
                                 , as_hole_ty = applyTy seq_id_ty scrut_ty }
-                        , ValArg scrut, ValArg rhs']
-                      -- Lazily evaluated, so we don't do most of this
+                        , ValArg scrut]
+             rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
+                                    , sc_env = env, sc_cont = cont }
+             env' = zapSubstEnv env
+             -- Lazily evaluated, so we don't do most of this
 
        ; rule_base <- getSimplRules
-       ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args cont
+       ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args rule_cont
        ; case mb_rule of
            Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont'
            Nothing                -> reallyRebuildCase env scrut case_bndr alts cont }
@@ -2413,15 +2372,15 @@ mkDupableCont env cont@(ApplyToTy { sc_cont = tail })
   = do  { (env', dup_cont, nodup_cont) <- mkDupableCont env tail
         ; return (env', cont { sc_cont = dup_cont }, nodup_cont ) }
 
-mkDupableCont env (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = cont })
+mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se, sc_cont = cont })
   =     -- e.g.         [...hole...] (...arg...)
         --      ==>
         --              let a = ...arg...
         --              in [...hole...] a
     do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
-        ; arg' <- simplExpr (se `setInScope` env') arg
+        ; (_, se', arg') <- simplArg env' dup se arg
         ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
-        ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = zapSubstEnv env''
+        ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = se'
                                     , sc_dup = OkToDup, sc_cont = dup_cont }
         ; return (env'', app_cont, nodup_cont) }
 
@@ -2873,4 +2832,138 @@ whether to use a real join point or just duplicate the continuation:
 
 Hence: check whether the case binder's type is unlifted, because then
 the outer case is *not* a seq.
+
+************************************************************************
+*                                                                      *
+                    Unfoldings
+*                                                                      *
+************************************************************************
 -}
+
+simplLetUnfolding :: SimplEnv-> TopLevelFlag
+                  -> InId
+                  -> OutExpr
+                  -> Unfolding -> SimplM Unfolding
+simplLetUnfolding env top_lvl id new_rhs unf
+  | isStableUnfolding unf
+  = simplUnfolding env top_lvl id unf
+  | otherwise
+  = bottoming `seq`  -- See Note [Force bottoming field]
+    do { dflags <- getDynFlags
+       ; return (mkUnfolding dflags InlineRhs (isTopLevel top_lvl) bottoming new_rhs) }
+            -- We make an  unfolding *even for loop-breakers*.
+            -- Reason: (a) It might be useful to know that they are WHNF
+            --         (b) In TidyPgm we currently assume that, if we want to
+            --             expose the unfolding then indeed we *have* an unfolding
+            --             to expose.  (We could instead use the RHS, but currently
+            --             we don't.)  The simple thing is always to have one.
+  where
+    bottoming = isBottomingId id
+
+simplUnfolding :: SimplEnv-> TopLevelFlag -> InId -> Unfolding -> SimplM Unfolding
+-- Note [Setting the new unfolding]
+simplUnfolding env top_lvl id unf
+  = case unf of
+      NoUnfolding -> return unf
+      OtherCon {} -> return unf
+
+      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
+        -> do { (env', bndrs') <- simplBinders rule_env bndrs
+              ; args' <- mapM (simplExpr env') args
+              ; return (mkDFunUnfolding bndrs' con args') }
+
+      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
+        | isStableSource src
+        -> do { expr' <- simplExpr rule_env expr
+              ; case guide of
+                  UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok }  -- Happens for INLINE things
+                     -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok
+                                             , ug_boring_ok = inlineBoringOk expr' }
+                        -- Refresh the boring-ok flag, in case expr'
+                        -- has got small. This happens, notably in the inlinings
+                        -- for dfuns for single-method classes; see
+                        -- Note [Single-method classes] in TcInstDcls.
+                        -- A test case is Trac #4138
+                        in return (mkCoreUnfolding src is_top_lvl expr' guide')
+                            -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+                  _other              -- Happens for INLINABLE things
+                     -> bottoming `seq` -- See Note [Force bottoming field]
+                        do { dflags <- getDynFlags
+                           ; return (mkUnfolding dflags src is_top_lvl bottoming expr') } }
+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
+                -- unfolding, and we need to make sure the guidance is kept up
+                -- to date with respect to any changes in the unfolding.
+
+        | otherwise -> return noUnfolding   -- Discard unstable unfoldings
+  where
+    bottoming = isBottomingId id
+    is_top_lvl = isTopLevel top_lvl
+    act        = idInlineActivation id
+    rule_env   = updMode (updModeForStableUnfoldings act) env
+               -- See Note [Simplifying inside stable unfoldings] in SimplUtils
+
+{-
+Note [Force bottoming field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to force bottoming, or the new unfolding holds
+on to the old unfolding (which is part of the id).
+
+Note [Setting the new unfolding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
+  should do nothing at all, but simplifying gently might get rid of
+  more crap.
+
+* If not, we make an unfolding from the new RHS.  But *only* for
+  non-loop-breakers. Making loop breakers not have an unfolding at all
+  means that we can avoid tests in exprIsConApp, for example.  This is
+  important: if exprIsConApp says 'yes' for a recursive thing, then we
+  can get into an infinite loop
+
+If there's an stable unfolding on a loop breaker (which happens for
+INLINEABLE), we hang on to the inlining.  It's pretty dodgy, but the
+user did say 'INLINE'.  May need to revisit this choice.
+
+************************************************************************
+*                                                                      *
+                    Rules
+*                                                                      *
+************************************************************************
+
+Note [Rules in a letrec]
+~~~~~~~~~~~~~~~~~~~~~~~~
+After creating fresh binders for the binders of a letrec, we
+substitute the RULES and add them back onto the binders; this is done
+*before* processing any of the RHSs.  This is important.  Manuel found
+cases where he really, really wanted a RULE for a recursive function
+to apply in that function's own right-hand side.
+
+See Note [Loop breaking and RULES] in OccAnal.
+-}
+
+addBndrRules :: SimplEnv -> InBndr -> OutBndr -> SimplM (SimplEnv, OutBndr)
+-- Rules are added back into the bin
+addBndrRules env in_id out_id
+  | null old_rules
+  = return (env, out_id)
+  | otherwise
+  = do { new_rules <- mapM (simplRule env (Just (idName out_id))) old_rules
+       ; let final_id  = out_id `setIdSpecialisation` mkSpecInfo new_rules
+       ; return (modifyInScope env final_id, final_id) }
+  where
+    old_rules = specInfoRules (idSpecialisation in_id)
+
+simplRule :: SimplEnv -> Maybe Name -> CoreRule -> SimplM CoreRule
+simplRule _   _         rule@(BuiltinRule {}) = return rule
+simplRule env mb_new_nm rule@(Rule { ru_bndrs = bndrs, ru_args = args
+                                   , ru_fn = fn_name, ru_rhs = rhs
+                                   , ru_act = act })
+  = do { (env, bndrs') <- simplBinders env bndrs
+       ; let rule_env = updMode (updModeForStableUnfoldings act) env
+       ; args' <- mapM (simplExpr rule_env) args
+       ; rhs'  <- simplExpr rule_env rhs
+       ; return (rule { ru_bndrs = bndrs'
+                      , ru_fn    = mb_new_nm `orElse` fn_name
+                      , ru_args  = args'
+                      , ru_rhs   = rhs' }) }