Make UnfoldingGuidance account for free variableswip/T3781

For over a decade (#3781) I've wondered whether GHC's
UnfoldingGuidance should take account of free variables.  For example:

   f x = let g y = case x of ....
         in
         ...(case x of ....g e....)...

If we inline the call to g in the body of the case x, we can save
re-evaluating (and case analysis of) x. This very similar to the
"discounts" we give for arguments.  All we need is to do it for
free variables.

It turned out to be rather easy.

* Beef up GHC.Core.Unfold.sizeExpr to accumulate discounts for
  free variables.

* Beef up GHC.Core.Unfold.callSiteInline to compute those
  discounts, based on info in the InScopeSet

Fixes #3781
Also fixes #19643 (which reminded me of this issue)

6 files changed, 221 insertions, 118 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 2e41f9932b..41c1e138e2 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -95,7 +95,7 @@ module GHC.Core (
 import GHC.Prelude
 import GHC.Platform
 
-import GHC.Types.Var.Env( InScopeSet )
+import GHC.Types.Var.Env( InScopeSet, IdEnv )
 import GHC.Types.Var
 import GHC.Core.Type
 import GHC.Core.Coercion
@@ -1304,6 +1304,7 @@ data UnfoldingGuidance
       ug_args ::  [Int],  -- Discount if the argument is evaluated.
                           -- (i.e., a simplification will definitely
                           -- be possible).  One elt of the list per *value* arg.
+      ug_fvs :: IdEnv Int,   -- Discount for free variables
 
       ug_size :: Int,     -- The "size" of the unfolding.
 
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 1398bfd6e7..d046e44a11 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -2008,7 +2008,7 @@ simplIdF env var cont
 
 completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
 completeCall env var cont
-  | Just expr <- callSiteInline logger uf_opts case_depth var active_unf
+  | Just expr <- callSiteInline logger uf_opts in_scope case_depth var active_unf
                                 lone_variable arg_infos interesting_cont
   -- Inline the variable's RHS
   = do { checkedTick (UnfoldingDone var)
@@ -2027,6 +2027,7 @@ completeCall env var cont
   where
     uf_opts    = seUnfoldingOpts env
     case_depth = seCaseDepth env
+    in_scope   = seInScope env
     logger     = seLogger env
     (lone_variable, arg_infos, call_cont) = contArgs cont
     n_val_args       = length arg_infos
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index f1791dfebf..1bee1c58a5 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -32,6 +32,7 @@ import GHC.Core.Stats (exprStats)
 import GHC.Types.Literal( pprLiteral )
 import GHC.Types.Name( pprInfixName, pprPrefixName )
 import GHC.Types.Var
+import GHC.Types.Var.Env( isEmptyVarEnv )
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Demand
@@ -582,11 +583,13 @@ instance Outputable UnfoldingGuidance where
         parens (text "arity="     <> int arity    <> comma <>
                 text "unsat_ok="  <> ppr unsat_ok <> comma <>
                 text "boring_ok=" <> ppr boring_ok)
-    ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
-      = hsep [ text "IF_ARGS",
-               brackets (hsep (map int cs)),
-               int size,
-               int discount ]
+    ppr (UnfIfGoodArgs { ug_args = cs, ug_fvs = fvs
+                       , ug_size = size, ug_res = discount })
+      = hsep [ text "IF_ARGS"
+             , brackets (hsep (map int cs))
+             , if isEmptyVarEnv fvs then empty else ppr fvs
+             , int size
+             , int discount ]
 
 instance Outputable UnfoldingSource where
   ppr InlineCompulsory  = text "Compulsory"
diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs
index 0addae9775..3bfa34e1fd 100644
--- a/compiler/GHC/Core/Seq.hs
+++ b/compiler/GHC/Core/Seq.hs
@@ -112,5 +112,6 @@ seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
 seqUnfolding _ = ()
 
 seqGuidance :: UnfoldingGuidance -> ()
-seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
-seqGuidance _                      = ()
+seqGuidance (UnfIfGoodArgs ns ds n b) = n `seq` sum ns `seq` ds `seq` b `seq` ()
+                                        -- We use strict maps so I think `seq` ds will do
+seqGuidance _                         = ()
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 08c5a10b30..c7914c31e1 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -51,13 +51,15 @@ import GHC.Types.Basic  ( Arity )
 import GHC.Core.Type
 import GHC.Builtin.Names
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
-import GHC.Data.Bag
 import GHC.Utils.Logger
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Types.ForeignCall
 import GHC.Types.Name
 import GHC.Types.Tickish
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set
+import GHC.Types.Unique.FM( nonDetStrictFoldUFM_Directly )
 
 import qualified Data.ByteString as BS
 import Data.List (isPrefixOf)
@@ -237,7 +239,7 @@ calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)
 calcUnfoldingGuidance opts is_top_bottoming expr
   = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of
       TooBig -> UnfNever
-      SizeIs size cased_bndrs scrut_discount
+      SizeIs size id_discounts scrut_discount
         | uncondInline expr n_val_bndrs size
         -> UnfWhen { ug_unsat_ok = unSaturatedOk
                    , ug_boring_ok =  boringCxtOk
@@ -247,10 +249,11 @@ calcUnfoldingGuidance opts is_top_bottoming expr
         -> UnfNever   -- See Note [Do not inline top-level bottoming functions]
 
         | otherwise
-        -> UnfIfGoodArgs { ug_args  = map (mk_discount cased_bndrs) val_bndrs
+        -> UnfIfGoodArgs { ug_args  = map (lookupDiscount id_discounts) val_bndrs
+                         , ug_fvs   = mapVarEnv getDiscount $
+                                      id_discounts `delVarEnvList` val_bndrs
                          , ug_size  = size
                          , ug_res   = scrut_discount }
-
   where
     (bndrs, body) = collectBinders expr
     bOMB_OUT_SIZE = unfoldingCreationThreshold opts
@@ -258,17 +261,7 @@ calcUnfoldingGuidance opts is_top_bottoming expr
     val_bndrs   = filter isId bndrs
     n_val_bndrs = length val_bndrs
 
-    mk_discount :: Bag (Id,Int) -> Id -> Int
-    mk_discount cbs bndr = foldl' combine 0 cbs
-           where
-             combine acc (bndr', disc)
-               | bndr == bndr' = acc `plus_disc` disc
-               | otherwise     = acc
 
-             plus_disc :: Int -> Int -> Int
-             plus_disc | isFunTy (idType bndr) = max
-                       | otherwise             = (+)
-             -- See Note [Function and non-function discounts]
 
 {- Note [Inline unsafeCoerce]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -424,46 +417,58 @@ sizeExpr :: UnfoldingOpts
 -- Forcing bOMB_OUT_SIZE early prevents repeated
 -- unboxing of the Int argument.
 sizeExpr opts !bOMB_OUT_SIZE top_args expr
-  = size_up expr
+  = size_up (mkVarSet top_args, emptyVarSet) expr
   where
-    size_up (Cast e _) = size_up e
-    size_up (Tick _ e) = size_up e
-    size_up (Type _)   = sizeZero           -- Types cost nothing
-    size_up (Coercion _) = sizeZero
-    size_up (Lit lit)  = sizeN (litSize lit)
-    size_up (Var f) | isRealWorldId f = sizeZero
+    size_up :: IgnoreSet -> CoreExpr -> ExprSize
+      -- The IdSet are the Ids that we *don't* want to collect
+      -- discount information for; namely, the Ids bound locally in
+      -- the expression
+
+    size_up ig (Cast e _)   = size_up ig e
+    size_up ig (Tick _ e)   = size_up ig e
+    size_up _  (Type _)     = sizeZero           -- Types cost nothing
+    size_up _  (Coercion _) = sizeZero
+    size_up _  (Lit lit)    = sizeN (litSize lit)
+    size_up ig (Var f) | isRealWorldId f = sizeZero
                       -- Make sure we get constructor discounts even
                       -- on nullary constructors
-                    | otherwise       = size_up_call f [] 0
+                    | otherwise       = size_up_call ig f [] 0
 
-    size_up (App fun arg)
-      | isTyCoArg arg = size_up fun
-      | otherwise     = size_up arg  `addSizeNSD`
-                        size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0)
+    size_up ig (App fun arg)
+      | isTyCoArg arg = size_up ig fun
+      | otherwise     = size_up ig arg  `addSizeNSD`
+                        size_up_app ig fun [arg] (if isRealWorldExpr arg then 1 else 0)
 
-    size_up (Lam b e)
-      | isId b && not (isRealWorldId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)
-      | otherwise = size_up e
+    size_up ig (Lam b e)
+      | isId b && not (isRealWorldId b) = lamScrutDiscount opts (size_up ig' e `addSizeN` 10)
+      | otherwise = size_up ig' e
+      where
+        ig' = ig `extendIgnore` b
 
-    size_up (Let (NonRec binder rhs) body)
-      = size_up_rhs (binder, rhs) `addSizeNSD`
-        size_up body              `addSizeN`
+    size_up ig (Let (NonRec binder rhs) body)
+      = size_up_rhs ig (binder, rhs) `addSizeNSD`
+        size_up ig' body              `addSizeN`
         size_up_alloc binder
+      where
+       ig' = ig `extendIgnore` binder
 
-    size_up (Let (Rec pairs) body)
-      = foldr (addSizeNSD . size_up_rhs)
-              (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs))
+    size_up ig (Let (Rec pairs) body)
+      = foldr (addSizeNSD . size_up_rhs ig')
+              (size_up ig' body `addSizeN` sum (map (size_up_alloc . fst) pairs))
               pairs
+      where
+        ig' = ig `extendIgnoreList` map fst pairs
 
-    size_up (Case e _ _ alts)
+    size_up ig (Case e bndr _ alts)
         | null alts
-        = size_up e    -- case e of {} never returns, so take size of scrutinee
+        = size_up (ig `extendIgnore` bndr) e
+          -- case e of {} never returns, so take size of scrutinee
 
-    size_up (Case e _ _ alts)
+    size_up ig (Case e bndr _ alts)
         -- Now alts is non-empty
-        | Just v <- is_top_arg e -- We are scrutinising an argument variable
+        | Just v <- is_var e -- We are scrutinising a variable
         = let
-            alt_sizes = map size_up_alt alts
+            alt_sizes = map (size_up_alt ig') alts
 
                   -- alts_size tries to compute a good discount for
                   -- the case when we are scrutinising an argument variable
@@ -471,17 +476,17 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
                           -- Size of all alternatives
                       (SizeIs max _        _)
                           -- Size of biggest alternative
-                  = SizeIs tot (unitBag (v, 20 + tot - max)
-                      `unionBags` tot_disc) tot_scrut
+                  = SizeIs tot (unitDisc ig v (CaseDisc (20 + tot - max))
+                                `addDiscs` tot_disc) tot_scrut
                           -- If the variable is known, we produce a
                           -- discount that will take us back to 'max',
                           -- the size of the largest alternative The
-                          -- 1+ is a little discount for reduced
+                          -- 20+ is a little discount for reduced
                           -- allocation in the caller
                           --
                           -- Notice though, that we return tot_disc,
-                          -- the total discount from all branches.  I
-                          -- think that's right.
+                          -- the total discount from all branches.
+                          -- I think that's right.
 
             alts_size tot_size _ = tot_size
           in
@@ -491,14 +496,18 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
                 -- that may eliminate allocation in the caller
                 -- And it eliminates the case itself
         where
-          is_top_arg (Var v) | v `elem` top_args = Just v
-          is_top_arg (Cast e _) = is_top_arg e
-          is_top_arg _ = Nothing
+          ig' = ig `extendIgnore` bndr
 
+          is_var (Var v)    = Just v
+          is_var (Cast e _) = is_var e
+          is_var _          = Nothing
 
-    size_up (Case e _ _ alts) = size_up e  `addSizeNSD`
-                                foldr (addAltSize . size_up_alt) case_size alts
+
+    size_up ig (Case e bndr _ alts) = size_up ig' e  `addSizeNSD`
+                                      foldr (addAltSize . size_up_alt ig') case_size alts
       where
+          ig' = ig `extendIgnore` bndr
+
           case_size
            | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)
            | otherwise = sizeZero
@@ -532,42 +541,44 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
               | otherwise
                 = False
 
-    size_up_rhs (bndr, rhs)
+    size_up_rhs ig (bndr, rhs)
       | Just join_arity <- isJoinId_maybe bndr
         -- Skip arguments to join point
-      , (_bndrs, body) <- collectNBinders join_arity rhs
-      = size_up body
+      , (bndrs, body) <- collectNBinders join_arity rhs
+      = size_up (ig `extendIgnoreList` bndrs) body
       | otherwise
-      = size_up rhs
+      = size_up ig rhs
 
     ------------
     -- size_up_app is used when there's ONE OR MORE value args
-    size_up_app (App fun arg) args voids
-        | isTyCoArg arg                  = size_up_app fun args voids
-        | isRealWorldExpr arg            = size_up_app fun (arg:args) (voids + 1)
-        | otherwise                      = size_up arg  `addSizeNSD`
-                                           size_up_app fun (arg:args) voids
-    size_up_app (Var fun)     args voids = size_up_call fun args voids
-    size_up_app (Tick _ expr) args voids = size_up_app expr args voids
-    size_up_app (Cast expr _) args voids = size_up_app expr args voids
-    size_up_app other         args voids = size_up other `addSizeN`
-                                           callSize (length args) voids
+    size_up_app ig (App fun arg) args voids
+        | isTyCoArg arg                  = size_up_app ig fun args voids
+        | isRealWorldExpr arg            = size_up_app ig fun (arg:args) (voids + 1)
+        | otherwise                      = size_up ig arg  `addSizeNSD`
+                                           size_up_app ig fun (arg:args) voids
+    size_up_app ig (Var fun)     args voids = size_up_call ig fun args voids
+    size_up_app ig (Tick _ expr) args voids = size_up_app ig expr args voids
+    size_up_app ig (Cast expr _) args voids = size_up_app ig expr args voids
+    size_up_app ig other         args voids = size_up ig other `addSizeN`
+                                              callSize (length args) voids
        -- if the lhs is not an App or a Var, or an invisible thing like a
        -- Tick or Cast, then we should charge for a complete call plus the
        -- size of the lhs itself.
 
     ------------
-    size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
-    size_up_call fun val_args voids
+    size_up_call :: IgnoreSet -> Id -> [CoreExpr] -> Int -> ExprSize
+    size_up_call ig fun val_args voids
        = case idDetails fun of
            FCallId _        -> sizeN (callSize (length val_args) voids)
            DataConWorkId dc -> conSize    dc (length val_args)
            PrimOpId op      -> primOpSize op (length val_args)
-           ClassOpId _      -> classOpSize opts top_args val_args
-           _                -> funSize opts top_args fun (length val_args) voids
+           ClassOpId _      -> classOpSize opts ig val_args
+           _                -> funSize opts ig fun (length val_args) voids
 
     ------------
-    size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10
+    size_up_alt ig (Alt _con bndrs rhs) = size_up ig' rhs `addSizeN` 10
+      where
+        ig' = ig `extendIgnoreList` bndrs
         -- Don't charge for args, so that wrappers look cheap
         -- (See comments about wrappers with Case)
         --
@@ -591,26 +602,28 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
     addSizeN TooBig          _  = TooBig
     addSizeN (SizeIs n xs d) m  = mkSizeIs bOMB_OUT_SIZE (n + m) xs d
 
-        -- addAltSize is used to add the sizes of case alternatives
-    addAltSize TooBig            _      = TooBig
+    -- addAltSize is used to add the sizes of case alternatives
+    -- The /second/ argument is expected to be the bigger one; force it first
     addAltSize _                 TooBig = TooBig
+    addAltSize TooBig            _      = TooBig
     addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
         = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
-                                 (xs `unionBags` ys)
+                                 (xs `addDiscs` ys)
                                  (d1 + d2) -- Note [addAltSize result discounts]
 
-        -- This variant ignores the result discount from its LEFT argument
-        -- It's used when the second argument isn't part of the result
-    addSizeNSD TooBig            _      = TooBig
+    -- This variant ignores the result discount from its FIRST argument
+    -- It's used when the first argument isn't part of the result
+    -- The second argument is also expected to be bigger: force it first
     addSizeNSD _                 TooBig = TooBig
+    addSizeNSD TooBig            _      = TooBig
     addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)
         = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
-                                 (xs `unionBags` ys)
+                                 (xs `addDiscs` ys)
                                  d2  -- Ignore d1
 
     isRealWorldId id = idType id `eqType` realWorldStatePrimTy
 
-    -- an expression of type State# RealWorld must be a variable
+    -- An expression of type State# RealWorld must be a variable
     isRealWorldExpr (Var id)   = isRealWorldId id
     isRealWorldExpr (Tick _ e) = isRealWorldExpr e
     isRealWorldExpr _          = False
@@ -627,11 +640,11 @@ litSize _other = 0    -- Must match size of nullary constructors
                       -- Key point: if  x |-> 4, then x must inline unconditionally
                       --            (eg via case binding)
 
-classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize
+classOpSize :: UnfoldingOpts -> IgnoreSet -> [CoreExpr] -> ExprSize
 -- See Note [Conlike is interesting]
 classOpSize _ _ []
   = sizeZero
-classOpSize opts top_args (arg1 : other_args)
+classOpSize opts ig (arg1 : other_args)
   = SizeIs size arg_discount 0
   where
     size = 20 + (10 * length other_args)
@@ -639,9 +652,8 @@ classOpSize opts top_args (arg1 : other_args)
     -- give it a discount, to encourage the inlining of this function
     -- The actual discount is rather arbitrarily chosen
     arg_discount = case arg1 of
-                     Var dict | dict `elem` top_args
-                              -> unitBag (dict, unfoldingDictDiscount opts)
-                     _other   -> emptyBag
+                     Var dict -> unitDisc ig dict (CaseDisc (unfoldingDictDiscount opts))
+                     _other   -> emptyIdDiscounts
 
 -- | The size of a function call
 callSize
@@ -664,10 +676,10 @@ jumpSize n_val_args voids = 2 * (1 + n_val_args - voids)
   -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a
   -- better solution?
 
-funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize
+funSize :: UnfoldingOpts -> IgnoreSet -> Id -> Int -> Int -> ExprSize
 -- Size for functions that are not constructors or primops
 -- Note [Function applications]
-funSize opts top_args fun n_val_args voids
+funSize opts ig fun n_val_args voids
   | fun `hasKey` buildIdKey   = buildSize
   | fun `hasKey` augmentIdKey = augmentSize
   | otherwise = SizeIs size arg_discount res_discount
@@ -681,9 +693,9 @@ funSize opts top_args fun n_val_args voids
 
         --                  DISCOUNTS
         --  See Note [Function and non-function discounts]
-    arg_discount | some_val_args && fun `elem` top_args
-                 = unitBag (fun, unfoldingFunAppDiscount opts)
-                 | otherwise = emptyBag
+    arg_discount | some_val_args
+                 = unitDisc ig fun (AppDisc (unfoldingFunAppDiscount opts))
+                 | otherwise = emptyIdDiscounts
         -- If the function is an argument and is applied
         -- to some values, give it an arg-discount
 
@@ -694,13 +706,13 @@ funSize opts top_args fun n_val_args voids
 
 conSize :: DataCon -> Int -> ExprSize
 conSize dc n_val_args
-  | n_val_args == 0 = SizeIs 0 emptyBag 10    -- Like variables
+  | n_val_args == 0 = SizeIs 0 emptyIdDiscounts 10    -- Like variables
 
 -- See Note [Unboxed tuple size and result discount]
-  | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10
+  | isUnboxedTupleDataCon dc = SizeIs 0 emptyIdDiscounts 10
 
 -- See Note [Constructor size and result discount]
-  | otherwise = SizeIs 10 emptyBag 10
+  | otherwise = SizeIs 10 emptyIdDiscounts 10
 
 {- Note [Constructor size and result discount]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -778,8 +790,8 @@ the function to a constructor application, so we *want* a big discount
 if the argument is scrutinised by many case expressions.
 
 Conclusion:
-  - For functions, take the max of the discounts
-  - For data values, take the sum of the discounts
+  - For functions,   take the max of the discounts (AppDisc)
+  - For data values, take the sum of the discounts (CaseDisc)
 
 
 Note [Literal integer size]
@@ -804,7 +816,7 @@ primOpSize op n_val_args
 
 
 buildSize :: ExprSize
-buildSize = SizeIs 0 emptyBag 40
+buildSize = SizeIs 0 emptyIdDiscounts 40
         -- We really want to inline applications of build
         -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
         -- Indeed, we should add a result_discount because build is
@@ -813,14 +825,14 @@ buildSize = SizeIs 0 emptyBag 40
         -- The "4" is rather arbitrary.
 
 augmentSize :: ExprSize
-augmentSize = SizeIs 0 emptyBag 40
+augmentSize = SizeIs 0 emptyIdDiscounts 40
         -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
         -- e plus ys. The -2 accounts for the \cn
 
 -- When we return a lambda, give a discount if it's used (applied)
 lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize
 lamScrutDiscount opts (SizeIs n vs _) = SizeIs n vs (unfoldingFunAppDiscount opts)
-lamScrutDiscount _      TooBig          = TooBig
+lamScrutDiscount _      TooBig        = TooBig
 
 {-
 Note [addAltSize result discounts]
@@ -895,13 +907,71 @@ Code for manipulating sizes
 data ExprSize
     = TooBig
     | SizeIs { _es_size_is  :: {-# UNPACK #-} !Int -- ^ Size found
-             , _es_args     :: !(Bag (Id,Int))
+
+             , _es_args     :: !IdDiscounts
                -- ^ Arguments cased herein, and discount for each such
+
              , _es_discount :: {-# UNPACK #-} !Int
                -- ^ Size to subtract if result is scrutinised by a case
                -- expression
              }
 
+type IgnoreSet
+  = ( IdSet     -- Lambda-bound binders for this unfolding
+    , IdSet )   -- Locally-bound binders, within this unfolding
+
+type IdDiscounts = IdEnv IdDiscount
+
+
+lookupDiscount :: IdDiscounts -> Id -> Int
+lookupDiscount discounts bndr
+  = case lookupVarEnv discounts bndr of
+       Just d  -> getDiscount d
+       Nothing -> 0
+
+emptyIdDiscounts :: IdDiscounts
+emptyIdDiscounts = emptyVarEnv
+
+extendIgnore :: IgnoreSet -> Id -> IgnoreSet
+extendIgnore (tops,locals) v = (tops, locals `extendVarSet` v)
+
+extendIgnoreList :: IgnoreSet -> [Id] -> IgnoreSet
+extendIgnoreList (tops,locals) vs = (tops, locals `extendVarSetList` vs)
+
+unitDisc :: IgnoreSet -> Id -> IdDiscount -> IdDiscounts
+-- Record a discount for the use of an Id
+-- But not if it is
+--   (a) a GlobalId
+--   (b) bound locally within the function body we are analysing
+--   (c) an AppDisc for a free variable
+--   (d) has no unfolding
+unitDisc (top_args, ignore_these) v disc
+  | isLocalId v
+  , not (v `elemVarSet` ignore_these)
+  , case disc of { AppDisc _ -> v `elemVarSet` top_args
+                 ; CaseDisc {} -> True }
+  , not (hasCoreUnfolding (idUnfolding v))
+  = unitVarEnv v disc
+  | otherwise
+  = emptyIdDiscounts
+
+addDiscs :: IdDiscounts -> IdDiscounts -> IdDiscounts
+addDiscs = plusVarEnv_C addIdDiscount
+
+data IdDiscount
+  = CaseDisc {-# UNPACK #-} !Int
+  | AppDisc  {-# UNPACK #-} !Int  -- See Note [Function and non-function discounts]
+
+getDiscount :: IdDiscount -> Int
+getDiscount (CaseDisc n) = n
+getDiscount (AppDisc n)  = n
+
+addIdDiscount :: IdDiscount -> IdDiscount -> IdDiscount
+addIdDiscount (CaseDisc n1) (CaseDisc n2) = CaseDisc (n1+n2)
+addIdDiscount (CaseDisc n1) (AppDisc n2)  = AppDisc  (n1 `max` n2)
+addIdDiscount (AppDisc n1)  (CaseDisc n2) = AppDisc  (n1 `max` n2)
+addIdDiscount (AppDisc n1)  (AppDisc n2)  = AppDisc  (n1 `max` n2)
+
 instance Outputable ExprSize where
   ppr TooBig         = text "TooBig"
   ppr (SizeIs a _ c) = brackets (int a <+> int c)
@@ -911,7 +981,7 @@ instance Outputable ExprSize where
 --      tup = (a_1, ..., a_99)
 --      x = case tup of ...
 --
-mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
+mkSizeIs :: Int -> Int -> IdDiscounts -> Int -> ExprSize
 mkSizeIs max n xs d | (n - d) > max = TooBig
                     | otherwise     = SizeIs n xs d
 
@@ -924,8 +994,8 @@ maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2   = s1
 sizeZero :: ExprSize
 sizeN :: Int -> ExprSize
 
-sizeZero = SizeIs 0 emptyBag 0
-sizeN n  = SizeIs n emptyBag 0
+sizeZero = SizeIs 0 emptyIdDiscounts 0
+sizeN n  = SizeIs n emptyIdDiscounts 0
 
 {-
 ************************************************************************
@@ -1019,6 +1089,7 @@ instance Outputable CallCtxt where
 
 callSiteInline :: Logger
                -> UnfoldingOpts
+               -> InScopeSet
                -> Int                   -- Case depth
                -> Id                    -- The Id
                -> Bool                  -- True <=> unfolding is active
@@ -1026,7 +1097,8 @@ callSiteInline :: Logger
                -> [ArgSummary]          -- One for each value arg; True if it is interesting
                -> CallCtxt              -- True <=> continuation is interesting
                -> Maybe CoreExpr        -- Unfolding, if any
-callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_infos cont_info
+callSiteInline logger opts in_scope !case_depth id
+               active_unfolding lone_variable arg_infos cont_info
   = case idUnfolding id of
       -- idUnfolding checks for loop-breakers, returning NoUnfolding
       -- Things with an INLINE pragma may have an unfolding *and*
@@ -1034,7 +1106,7 @@ callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_inf
         CoreUnfolding { uf_tmpl = unf_template
                       , uf_is_work_free = is_wf
                       , uf_guidance = guidance, uf_expandable = is_exp }
-          | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable
+          | active_unfolding -> tryUnfolding logger opts in_scope case_depth id lone_variable
                                     arg_infos cont_info unf_template
                                     is_wf is_exp guidance
           | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing
@@ -1157,10 +1229,11 @@ needed on a per-module basis.
 
 -}
 
-tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt
+tryUnfolding :: Logger -> UnfoldingOpts -> InScopeSet -> Int -> Id
+             -> Bool -> [ArgSummary] -> CallCtxt
              -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance
              -> Maybe CoreExpr
-tryUnfolding logger opts !case_depth id lone_variable
+tryUnfolding logger opts in_scope !case_depth id lone_variable
              arg_infos cont_info unf_template
              is_wf is_exp guidance
  = case guidance of
@@ -1176,7 +1249,8 @@ tryUnfolding logger opts !case_depth id lone_variable
           some_benefit = calc_some_benefit uf_arity
           enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
 
-     UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
+     UnfIfGoodArgs { ug_args = arg_discounts, ug_fvs = fv_discounts
+                   , ug_res = res_discount, ug_size = size }
         | unfoldingVeryAggressive opts
         -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)
         | is_wf && some_benefit && small_enough
@@ -1195,7 +1269,8 @@ tryUnfolding logger opts !case_depth id lone_variable
                         | otherwise       = (size * (case_depth - depth_treshold)) `div` depth_scaling
           adjusted_size = size + depth_penalty - discount
           small_enough = adjusted_size <= unfoldingUseThreshold opts
-          discount = computeDiscount arg_discounts res_discount arg_infos cont_info
+          discount = computeDiscount in_scope arg_discounts fv_discounts res_discount
+                                     arg_infos cont_info
 
   where
     mk_doc some_benefit extra_doc yes_or_no
@@ -1441,9 +1516,13 @@ which Roman did.
 
 -}
 
-computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt
+computeDiscount :: InScopeSet
+                -> [Int]       -- Argument discounts
+                -> VarEnv Int  -- Free-variable discounts
+                -> Int -> [ArgSummary] -> CallCtxt
                 -> Int
-computeDiscount arg_discounts res_discount arg_infos cont_info
+computeDiscount in_scope arg_discounts fv_discounts res_discount
+                arg_infos cont_info
 
   = 10          -- Discount of 10 because the result replaces the call
                 -- so we count 10 for the function itself
@@ -1452,10 +1531,17 @@ computeDiscount arg_discounts res_discount arg_infos cont_info
                -- Discount of 10 for each arg supplied,
                -- because the result replaces the call
 
-    + total_arg_discount + res_discount'
+    + total_arg_discount + fv_discount + res_discount'
   where
     actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos
     total_arg_discount   = sum actual_arg_discounts
+    fv_discount = nonDetStrictFoldUFM_Directly add_fv 0 fv_discounts
+    add_fv uniq disc tot_disc
+      | Just v <- lookupInScope_Directly in_scope uniq
+      , hasCoreUnfolding (idUnfolding v)
+      = disc + tot_disc
+      | otherwise
+      = disc
 
     mk_arg_discount _        TrivArg    = 0
     mk_arg_discount _        NonTrivArg = 10
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
index 265345e2ec..e56aaf2108 100644
--- a/compiler/GHC/Types/Unique/FM.hs
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -64,7 +64,8 @@ module GHC.Types.Unique.FM (
         intersectUFM_C,
         disjointUFM,
         equalKeysUFM,
-        nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM,
+        nonDetStrictFoldUFM, nonDetStrictFoldUFM_Directly,
+        foldUFM, nonDetStrictFoldUFM_DirectlyM,
         anyUFM, allUFM, seqEltsUFM,
         mapUFM, mapUFM_Directly,
         mapMaybeUFM,
@@ -412,6 +413,16 @@ nonDetKeysUFM (UFM m) = map getUnique $ M.keys m
 nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a
 nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m
 
+-- See Note [Deterministic UniqFM] to learn about nondeterminism.
+-- If you use this please provide a justification why it doesn't introduce
+-- nondeterminism.
+{-# INLINE nonDetStrictFoldUFM_Directly #-} -- Allow specialization
+nonDetStrictFoldUFM_Directly :: (Unique -> a -> elt ->  a) -> a -> UniqFM key elt -> a
+nonDetStrictFoldUFM_Directly f z (UFM m) = M.foldlWithKey' c z m
+  -- See Note [List fusion and continuations in 'c']
+  where c acc u x = f (getUnique u) acc x
+        {-# INLINE c #-}
+
 -- | In essence foldM
 -- See Note [Deterministic UniqFM] to learn about nondeterminism.
 -- If you use this please provide a justification why it doesn't introduce