Implement as separate analysis instead; feed on that in Simplifier

11 files changed, 284 insertions, 142 deletions

diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index 4e53da0711..a746e4feb8 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -808,7 +808,7 @@ occAnalRecBind env lvl imp_rule_edges pairs body_usage
 
     bndrs    = map fst pairs
     bndr_set = mkVarSet bndrs
-    rhs_env  = env `addInScope` bndrs `addInterestingStaticArgs` pairs
+    rhs_env  = env `addInScope` bndrs
 
 
 -----------------------------
@@ -1082,10 +1082,8 @@ mk_loop_breaker :: Id -> Id
 mk_loop_breaker bndr
   = bndr `setIdOccInfo` occ'
   where
-    occ'        = strongLoopBreaker { occ_tail = tail_info
-                                  , occ_static_args = static_args }
-    tail_info   = tailCallInfo (idOccInfo bndr)
-    static_args = staticArgsInfo (idOccInfo bndr)
+    occ'      = strongLoopBreaker { occ_tail = tail_info }
+    tail_info = tailCallInfo (idOccInfo bndr)
 
 mk_non_loop_breaker :: VarSet -> Id -> Id
 -- See Note [Weak loop breakers]
@@ -1977,7 +1975,6 @@ occAnal env (Let bind body)
                      body_usage          of { (final_usage, new_binds) ->
        (final_usage, mkLets new_binds body') }}
 
-
 occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
 occAnalArgs _ [] _
   = (emptyDetails, [])
@@ -2035,7 +2032,7 @@ occAnalApp env (Var fun, args, ticks)
                       `orElse` (Var fun, fun)
                      -- See Note [The binder-swap substitution]
 
-    fun_uds = mkOneOcc env fun_id' int_cxt args
+    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
@@ -2053,6 +2050,7 @@ occAnalApp env (Var fun, args, ticks)
        -- See Note [Arguments of let-bound constructors]
 
     n_val_args = valArgCount args
+    n_args     = length args
     int_cxt    = case occ_encl env of
                    OccScrut -> IsInteresting
                    _other   | n_val_args > 0 -> IsInteresting
@@ -2219,15 +2217,12 @@ data OccEnv
            , 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]
-           -- lkj , occ_sat_args :: ![Staticness Var] -- It's not worth the bother
-           , occ_sat_env  :: VarEnv [Var] -- TODO shadowing of lambda binders
 
            -- 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
-                   -- FIXME: Why is this not an InScopeSet?!!
     }
 
 
@@ -2270,8 +2265,6 @@ initOccEnv
            , occ_unf_act   = \_ -> True
            , occ_rule_act  = \_ -> True
 
-           , occ_sat_env  = emptyVarEnv
-
            , occ_bs_env = emptyVarEnv
            , occ_bs_rng = emptyVarSet }
 
@@ -2280,11 +2273,9 @@ noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env
 
 scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv
 scrutCtxt env alts
-  = env { occ_encl = encl, occ_one_shots = [] }
+  | interesting_alts =  env { occ_encl = OccScrut,   occ_one_shots = [] }
+  | otherwise        =  env { occ_encl = OccVanilla, occ_one_shots = [] }
   where
-    encl
-      | interesting_alts = OccScrut
-      | otherwise        = OccVanilla
     interesting_alts = case alts of
                          []    -> False
                          [alt] -> not (isDefaultAlt alt)
@@ -2310,19 +2301,9 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
 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_sat_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
+  | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
   | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
 
--- | Extends 'occ_sat_env' with the expected static argument binders for the
--- interesting cases (singleton recursive groups).
-addInterestingStaticArgs :: OccEnv -> [(Id, CoreExpr)] -> OccEnv
-addInterestingStaticArgs env [(fn, rhs)]
-  = env { occ_sat_env = extendVarEnv (occ_sat_env env) fn bndrs }
-  where
-    (bndrs, _body) = collectBinders rhs
-addInterestingStaticArgs env _
-  = env
-
 oneShotGroup :: OccEnv -> [CoreBndr]
              -> ( OccEnv
                 , [CoreBndr] )
@@ -2374,8 +2355,8 @@ markJoinOneShots mb_join_arity bndrs
           | otherwise = b
 
 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
-addAppCtxt env@(OccEnv { occ_one_shots = oss }) args
-  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ oss }
+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
+  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }
 
 --------------------
 transClosureFV :: VarEnv VarSet -> VarEnv VarSet
@@ -2703,24 +2684,17 @@ andUDs, orUDs
 andUDs = combineUsageDetailsWith addOccInfo
 orUDs  = combineUsageDetailsWith orOccInfo
 
-mkOneOcc :: OccEnv -> Id -> InterestingCxt -> [CoreArg] -> UsageDetails
-mkOneOcc env id int_cxt args
+mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails
+mkOneOcc id int_cxt arity
   | isLocalId id
   = emptyDetails { ud_env = unitVarEnv id occ_info }
   | otherwise
   = emptyDetails
   where
-    n_args   = length args
-    static_args
-      | Just decl_vars <- lookupVarEnv (occ_sat_env env) id
-      = mkStaticArgs $ zipWith asStaticArg decl_vars args
-      | otherwise -- not interesting for SAT
-      = noStaticArgs
-    occ_info = OneOcc { occ_in_lam      = NotInsideLam
-                      , occ_n_br        = oneBranch
-                      , occ_int_cxt     = int_cxt
-                      , occ_tail        = AlwaysTailCalled n_args
-                      , occ_static_args = static_args }
+    occ_info = OneOcc { occ_in_lam  = NotInsideLam
+                      , occ_n_br    = oneBranch
+                      , occ_int_cxt = int_cxt
+                      , occ_tail    = AlwaysTailCalled arity }
 
 addManyOccId :: UsageDetails -> Id -> UsageDetails
 -- Add the non-committal (id :-> noOccInfo) to the usage details
@@ -2974,22 +2948,16 @@ tagRecBinders lvl body_uds triples
            = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if
              Nothing                   -- we are making join points!
 
-     rhs_uds' = foldr1 andUDs rhs_udss'
-
      -- 3. Compute final usage details from adjusted RHS details
-     adj_uds   = body_uds `andUDs` rhs_uds'
+     adj_uds   = foldr andUDs body_uds rhs_udss'
 
      -- 4. Tag each binder with its adjusted details
-     bndrs'    = [ setBinderOcc (adj_occ{occ_static_args = rhs_static_args}) bndr
-                 | bndr <- bndrs
-                 , let adj_occ = lookupDetails adj_uds bndr
-                 , let rhs_static_args = staticArgsInfo (lookupDetails rhs_uds' bndr)
-                 ]
+     bndrs'    = [ setBinderOcc (lookupDetails adj_uds bndr) bndr
+                 | bndr <- bndrs ]
 
      -- 5. Drop the binders from the adjusted details and return
      usage'    = adj_uds `delDetailsList` bndrs
    in
-   pprTrace "tagRecBinders" (ppr bndrs' $$ ppr body_uds $$ ppr rhs_udss' $$ ppr adj_uds $$ ppr (map idOccInfo bndrs')) $
    (usage', bndrs')
 
 setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
@@ -3100,16 +3068,8 @@ unravels; so ignoring INLINE pragmas on recursive things isn't good
 either.
 
 See Invariant 2a of Note [Invariants on join points] in GHC.Core
--}
 
-asStaticArg :: Var -> CoreArg -> Staticness Var
-asStaticArg v arg
-  | isId v,         Var id <- arg, v == id                     = Static v
-  | isTyVar v,      Type t <- arg, mkTyVarTy v `eqType` t      = Static v
-  | isCoVar v, Coercion co <- arg, mkCoVarCo v `eqCoercion` co = Static v
-  | otherwise                                                  = NotStatic
 
-{-
 ************************************************************************
 *                                                                      *
 \subsection{Operations over OccInfo}
@@ -3120,8 +3080,7 @@ asStaticArg v arg
 markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo
 
 markMany IAmDead = IAmDead
-markMany occ     = ManyOccs { occ_tail = occ_tail occ
-                            , occ_static_args = occ_static_args occ }
+markMany occ     = ManyOccs { occ_tail = occ_tail occ }
 
 markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }
 markInsideLam occ             = occ
@@ -3133,36 +3092,29 @@ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
 
 addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
                     ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`
-                                          tailCallInfo a2
-                             , occ_static_args = staticArgsInfo a1 `andStaticArgs`
-                                                 staticArgsInfo a2}
+                                          tailCallInfo a2 }
                                 -- Both branches are at least One
                                 -- (Argument is never IAmDead)
 
 -- (orOccInfo orig new) is used
 -- when combining occurrence info from branches of a case
 
-orOccInfo (OneOcc { occ_in_lam      = in_lam1
-                  , occ_n_br        = nbr1
-                  , occ_int_cxt     = int_cxt1
-                  , occ_tail        = tail1
-                  , occ_static_args = static_args1 })
-          (OneOcc { occ_in_lam      = in_lam2
-                  , occ_n_br        = nbr2
-                  , occ_int_cxt     = int_cxt2
-                  , occ_tail        = tail2
-                  , occ_static_args = static_args2 })
-  = OneOcc { occ_n_br        = nbr1 + nbr2
-           , occ_in_lam      = in_lam1 `mappend` in_lam2
-           , occ_int_cxt     = int_cxt1 `mappend` int_cxt2
-           , occ_tail        = tail1 `andTailCallInfo` tail2
-           , occ_static_args = static_args1 `andStaticArgs` static_args2 }
+orOccInfo (OneOcc { occ_in_lam  = in_lam1
+                  , occ_n_br    = nbr1
+                  , occ_int_cxt = int_cxt1
+                  , occ_tail    = tail1 })
+          (OneOcc { occ_in_lam  = in_lam2
+                  , occ_n_br    = nbr2
+                  , occ_int_cxt = int_cxt2
+                  , occ_tail    = tail2 })
+  = OneOcc { occ_n_br    = nbr1 + nbr2
+           , occ_in_lam  = in_lam1 `mappend` in_lam2
+           , occ_int_cxt = int_cxt1 `mappend` int_cxt2
+           , occ_tail    = tail1 `andTailCallInfo` tail2 }
 
 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
                   ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`
-                                        tailCallInfo a2
-                           , occ_static_args = staticArgsInfo a1 `andStaticArgs`
-                                               staticArgsInfo a2 }
+                                        tailCallInfo a2 }
 
 andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo
 andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index abddab3e45..7d1897782f 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -37,7 +37,7 @@ import GHC.Core.Opt.Monad
 import GHC.Core.Opt.FloatIn      ( floatInwards )
 import GHC.Core.Opt.FloatOut     ( floatOutwards )
 import GHC.Core.Opt.LiberateCase ( liberateCase )
-import GHC.Core.Opt.StaticArgs   ( doStaticArgs )
+import GHC.Core.Opt.StaticArgs   ( doStaticArgs, satAnalProgram )
 import GHC.Core.Opt.Specialise   ( specProgram)
 import GHC.Core.Opt.SpecConstr   ( specConstrProgram)
 import GHC.Core.Opt.DmdAnal
@@ -749,9 +749,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
       , () <- sz `seq` ()     -- Force it
       = do {
                 -- Occurrence analysis
-           let { tagged_binds = {-# SCC "OccAnal" #-}
+           let { tagged_binds0 = {-# SCC "OccAnal" #-}
                      occurAnalysePgm this_mod active_unf active_rule rules
                                      binds
+               ; tagged_binds  = {-# SCC "SAT" #-}
+                     satAnalProgram tagged_binds0
                } ;
            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                      FormatCore
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 22d0bb47c0..34c80c8839 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -21,6 +21,7 @@ import GHC.Core.Opt.Simplify.Monad
 import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
 import GHC.Core.Opt.Simplify.Env
 import GHC.Core.Opt.Simplify.Utils
+import GHC.Core.Opt.StaticArgs ( saTransform )
 import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
 import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326
 import GHC.Types.SourceText
@@ -3786,9 +3787,23 @@ simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf
   = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf
   | isExitJoinId id
   = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify
+  | Just static_args <- isStrongLoopBreakerWithStaticArgs id
+  , (lam_bndrs, lam_body) <- collectBinders new_rhs
+  = do  { unf_rhs <- saTransform id static_args lam_bndrs lam_body
+        ; pprTraceM "simplLetUnfolding" (ppr id $$ ppr static_args $$ ppr unf_rhs)
+        ; mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id unf_rhs }
   | otherwise
   = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs
 
+isStrongLoopBreakerWithStaticArgs :: Id -> Maybe [Staticness ()]
+isStrongLoopBreakerWithStaticArgs id
+  | isStrongLoopBreaker $ idOccInfo id
+  , static_args <- getStaticArgs $ idStaticArgs id
+  , notNull static_args
+  = Just static_args
+  | otherwise
+  = Nothing
+
 -------------------
 mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
                -> InId -> OutExpr -> SimplM Unfolding
@@ -3797,10 +3812,13 @@ mkLetUnfolding uf_opts top_lvl src id new_rhs
     return (mkUnfolding uf_opts src is_top_lvl is_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 GHC.Iface.Tidy 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.
+            --         (b) They might have static arguments, in which case we
+            --             provide a non-rec unfolding that specialises for those
+            --         (c) And even without static arguments, in GHC.Iface.Tidy 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
     is_top_lvl   = isTopLevel top_lvl
     is_bottoming = isDeadEndId id
diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs
index 270e519389..f6d4b02988 100644
--- a/compiler/GHC/Core/Opt/StaticArgs.hs
+++ b/compiler/GHC/Core/Opt/StaticArgs.hs
@@ -50,10 +50,11 @@ The previous patch, to fix polymorphic floatout demand signatures, is
 essential to make this work well!
 -}
 
-module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where
+module GHC.Core.Opt.StaticArgs ( satAnalProgram, doStaticArgs, saTransform ) where
 
 import GHC.Prelude
 
+import GHC.Builtin.Names ( unboundKey )
 import GHC.Types.Var
 import GHC.Core
 import GHC.Core.Utils
@@ -64,19 +65,161 @@ import GHC.Types.Name
 import GHC.Types.Var.Env
 import GHC.Types.Unique.Supply
 import GHC.Utils.Misc
-import GHC.Types.Basic (Staticness(..))
+import GHC.Types.Basic ( Staticness(..), StaticArgs, mkStaticArgs, noStaticArgs, andStaticArgs )
 import GHC.Types.Unique.FM
 import GHC.Types.Var.Set
-import GHC.Types.Unique
 import GHC.Types.Unique.Set
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
+import GHC.Data.FastString
+import GHC.Data.Maybe
 
 import Data.List (mapAccumL)
-import GHC.Data.FastString
+import Data.Bifunctor (second)
 
 #include "HsVersions.h"
 
+satAnalProgram :: CoreProgram -> CoreProgram
+satAnalProgram bs = map (snd . satAnalBind initSatEnv) bs
+
+-- | Lambda binders ('TyVar's, 'CoVar's and 'Id's) of a let-bound RHS, thus
+-- parameters to a function.
+type Params = [Var]
+
+data SatEnv
+  = SE
+  { se_params_env :: !(IdEnv Params)
+  -- ^ Lambda binders of interesting Id's. If a param is static, then all
+  -- occurrences must have the 'Var' listed here in its position!
+  , se_in_scope   :: !InScopeSet
+  -- ^ Needed for handling shadowing properly. See 'addInScopeVars'.
+  }
+
+initSatEnv :: SatEnv
+initSatEnv = SE emptyVarEnv emptyInScopeSet
+
+addInterestingId :: SatEnv -> Id -> Params -> SatEnv
+addInterestingId env id params =
+  env { se_params_env = extendVarEnv (se_params_env env) id params }
+
+lookupInterestingId :: SatEnv -> Id -> Maybe Params
+lookupInterestingId env id = lookupVarEnv (se_params_env env) id
+
+addInScopeVar :: SatEnv -> Var -> SatEnv
+addInScopeVar env v = addInScopeVars env [v]
+
+addInScopeVars :: SatEnv -> [Var] -> SatEnv
+addInScopeVars se vars = se { se_in_scope = in_scope', se_params_env = env' }
+  where
+    in_scope  = se_in_scope se
+    in_scope' = extendInScopeSetList in_scope vars
+    env       = se_params_env se
+    var_set   = mkVarSet vars
+    env'
+      | any (`elemInScopeSet` in_scope) vars
+      = mapVarEnv (hideShadowedParams var_set) $ delVarEnvList env vars
+      | otherwise
+      = env
+
+hideShadowedParams :: VarSet -> Params -> Params
+hideShadowedParams shadowing_vars = map_if shadowed hide_param
+  where
+    map_if :: (a -> Bool) -> (a -> a) -> [a] -> [a]
+    map_if p f       = map (\a -> if p a then f a else a)
+    shadowed param   = param `elemVarSet` shadowing_vars
+    -- unboundKey is guaranteed not to occur anywhere in the program!
+    -- See Note [Shadowed Params] TODO
+    hide_param param = param `setVarUnique` unboundKey
+
+newtype SatOccs = SO (IdEnv StaticArgs)
+
+emptySatOccs :: SatOccs
+emptySatOccs = SO emptyVarEnv
+
+addSatOccs :: SatOccs -> Id -> StaticArgs -> SatOccs
+addSatOccs (SO env) fn static_args =
+  SO $ extendVarEnv_C andStaticArgs env fn static_args
+
+combineSatOccs :: SatOccs -> SatOccs -> SatOccs
+combineSatOccs (SO a) (SO b) = SO $ plusVarEnv_C andStaticArgs a b
+
+combineSatOccsList :: [SatOccs] -> SatOccs
+combineSatOccsList occs = foldl' combineSatOccs emptySatOccs occs
+
+peelSatOccs :: SatOccs -> Id -> (StaticArgs, SatOccs)
+peelSatOccs (SO env) fn = case delLookupVarEnv env fn of
+  (mb_sa, env') -> (mb_sa `orElse` noStaticArgs, SO env')
+
+satAnalBind :: SatEnv -> CoreBind -> (SatOccs, CoreBind)
+satAnalBind env (NonRec id rhs) = (occs, NonRec id rhs')
+  where
+    (occs, rhs') = satAnalExpr (env `addInScopeVar` id) rhs
+satAnalBind env (Rec [(fn, rhs)])
+  | notNull bndrs
+  = (occs', Rec [(fn', rhs')])
+  where
+    (bndrs, rhs_body)    = collectBinders rhs
+    env'                 = addInterestingId (env `addInScopeVars` (fn:bndrs)) fn bndrs
+    (occs, rhs_body')    = satAnalExpr env' rhs_body
+    rhs'                 = mkLams bndrs rhs_body'
+    (static_args, occs') = peelSatOccs occs fn
+    fn'                  = setIdStaticArgs fn static_args
+satAnalBind env (Rec pairs) = (combineSatOccsList occss, Rec pairs')
+  where
+    ids  = map fst pairs
+    env' = env `addInScopeVars` ids
+    (occss, rhss') = mapAndUnzip (satAnalExpr env' . snd) pairs
+    pairs' = zip ids rhss'
+
+satAnalExpr :: SatEnv -> CoreExpr -> (SatOccs, CoreExpr)
+satAnalExpr _   e@(Lit _)      = (emptySatOccs, e)
+satAnalExpr _   e@(Coercion _) = (emptySatOccs, e)
+satAnalExpr _   e@(Type _)     = (emptySatOccs, e)
+satAnalExpr _   e@(Var _)      = (emptySatOccs, e) -- boring! See the App case
+satAnalExpr env (Tick t e)     = second (Tick t)      $ satAnalExpr env e
+satAnalExpr env (Cast e c)     = second (flip Cast c) $ satAnalExpr env e
+satAnalExpr env e@App{}        = uncurry (satAnalApp env) (collectArgs e)
+satAnalExpr env e@Lam{}        = (occs, mkLams bndrs body')
+  where
+    (bndrs, body) = collectBinders e
+    (occs, body') = satAnalExpr (env `addInScopeVars` bndrs) body
+satAnalExpr env (Let bnd body) = (occs, Let bnd' body')
+  where
+    (occs_bind, bnd')  = satAnalBind env bnd'
+    (occs_body, body') = satAnalExpr (env `addInScopeVars` bindersOf bnd) body
+    !occs              = combineSatOccs occs_body occs_bind
+satAnalExpr env (Case scrut bndr ty alts) = (occs, Case scrut' bndr ty alts')
+  where
+    (occs_scrut, scrut') = satAnalExpr env scrut
+    alt_env              = env `addInScopeVar` bndr
+    (occs_alts,  alts')  = mapAndUnzip (satAnalAlt alt_env) alts
+    occs                 = combineSatOccsList (occs_scrut:occs_alts)
+
+satAnalAlt :: SatEnv -> CoreAlt -> (SatOccs, CoreAlt)
+satAnalAlt env (dc, bndrs, rhs) = (occs, (dc, bndrs, rhs'))
+  where
+    (occs, rhs') = satAnalExpr (env `addInScopeVars` bndrs) rhs
+
+satAnalApp :: SatEnv -> CoreExpr -> [CoreArg] -> (SatOccs, CoreExpr)
+satAnalApp env head args = (add_static_args_info occs, expr')
+  where
+    (occs_head, head') = satAnalExpr env head
+    (occs_args, args') = mapAndUnzip (satAnalExpr env) args
+    occs               = combineSatOccsList (occs_head:occs_args)
+    expr'              = mkApps head' args'
+    add_static_args_info occs
+      | Var fn <- head, Just params <- lookupInterestingId env fn
+      = addSatOccs occs fn (mkStaticArgs $ zipWith asStaticArg params args)
+      | otherwise
+      = occs
+
+asStaticArg :: Var -> CoreArg -> Staticness ()
+asStaticArg v arg
+  | isId v,         Var id <- arg, v == id                     = Static ()
+  | isTyVar v,      Type t <- arg, mkTyVarTy v `eqType` t      = Static ()
+  | isCoVar v, Coercion co <- arg, mkCoVarCo v `eqCoercion` co = Static ()
+  | otherwise                                                  = NotStatic
+
 doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
 doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
   where
@@ -261,9 +404,6 @@ type SatM result = UniqSM result
 runSAT :: UniqSupply -> SatM a -> a
 runSAT = initUs_
 
-newUnique :: SatM Unique
-newUnique = getUniqueM
-
 {-
 ************************************************************************
 
@@ -371,7 +511,8 @@ saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
 saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body
   | Just arg_staticness <- maybe_arg_staticness
   , should_transform arg_staticness
-  = saTransform binder arg_staticness rhs_binders rhs_body
+  = do  { new_rhs <- saTransform binder arg_staticness rhs_binders rhs_body
+        ; return (NonRec binder new_rhs) }
   | otherwise
   = return (Rec [(binder, mkLams rhs_binders rhs_body)])
   where
@@ -379,11 +520,12 @@ saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body
       where
         n_static_args = count isStaticValue staticness
 
-saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
+saTransform :: MonadUnique m => Id -> [Staticness a] -> [Id] -> CoreExpr -> m CoreExpr
 saTransform binder arg_staticness rhs_binders rhs_body
-  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness
-        ; uniq             <- newUnique
-        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }
+  = do  { MASSERT( arg_staticness `leLength` rhs_binders )
+        ; shadow_lam_bndrs <- mapM clone binders_w_staticness
+        ; uniq             <- getUniqueM
+        ; return (mk_new_rhs uniq shadow_lam_bndrs) }
   where
     -- Running example: foldr
     -- foldr \alpha \beta c n xs = e, for some e
@@ -400,7 +542,7 @@ saTransform binder arg_staticness rhs_binders rhs_body
     non_static_args = [v | (v, NotStatic) <- binders_w_staticness]
 
     clone (bndr, NotStatic) = return bndr
-    clone (bndr, _        ) = do { uniq <- newUnique
+    clone (bndr, _        ) = do { uniq <- getUniqueM
                                  ; return (setVarUnique bndr uniq) }
 
     -- new_rhs = \alpha beta c n xs ->
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index 37e5afc963..2a02f59641 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -464,6 +464,7 @@ instance Outputable IdInfo where
   ppr info = showAttributes
     [ (has_prag,         text "InlPrag=" <> pprInlineDebug prag_info)
     , (has_occ,          text "Occ=" <> ppr occ_info)
+    , (has_static_args,  text "SA=" <> ppr static_args)
     , (has_dmd,          text "Dmd=" <> ppr dmd_info)
     , (has_lbv ,         text "OS=" <> ppr lbv_info)
     , (has_arity,        text "Arity=" <> int arity)
@@ -480,6 +481,9 @@ instance Outputable IdInfo where
       occ_info  = occInfo info
       has_occ   = not (isManyOccs occ_info)
 
+      static_args = staticArgsInfo info
+      has_static_args = static_args /= noStaticArgs
+
       dmd_info  = demandInfo info
       has_dmd   = not $ isTopDmd dmd_info
 
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index ac063b4af4..c5e6ff37c6 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -51,7 +51,7 @@ import GHC.Core.DataCon
 import GHC.Types.Literal
 import GHC.Builtin.PrimOps
 import GHC.Types.Id.Info
-import GHC.Types.Basic  ( Arity, InlineSpec(..), inlinePragmaSpec, staticArgsInfo, noStaticArgs )
+import GHC.Types.Basic  ( Arity, InlineSpec(..), inlinePragmaSpec, noStaticArgs )
 import GHC.Core.Type
 import GHC.Builtin.Names
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
@@ -1096,7 +1096,7 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
         DFunUnfolding {} -> Nothing     -- Never unfold a DFun
   where
     b ==> t = not b || t
-    has_static_args id = staticArgsInfo (idOccInfo id) /= noStaticArgs
+    has_static_args id = idStaticArgs id /= noStaticArgs
 
 -- | Report the inlining of an identifier's RHS to the user, if requested.
 traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 4398ec1567..19ae589c2f 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -69,8 +69,7 @@ module GHC.Types.Basic (
         isAlwaysTailCalled,
 
         Staticness(..),
-        StaticArgs, staticArgsInfo,
-        mkStaticArgs, noStaticArgs, getStaticArgs, andStaticArgs,
+        StaticArgs, mkStaticArgs, noStaticArgs, getStaticArgs, andStaticArgs,
 
         EP(..),
 
@@ -116,6 +115,7 @@ import GHC.Utils.Misc
 import GHC.Types.SourceText
 import Data.Data
 import Data.Bits
+import Data.List ( dropWhileEnd )
 import qualified Data.Semigroup as Semi
 
 {-
@@ -919,8 +919,7 @@ OccInfo here, safely at the bottom
 
 -- | identifier Occurrence Information
 data OccInfo
-  = ManyOccs        { occ_tail        :: !TailCallInfo
-                    , occ_static_args :: {-# UNPACK #-} !StaticArgs }
+  = ManyOccs        { occ_tail        :: !TailCallInfo }
                         -- ^ There are many occurrences, or unknown occurrences
 
   | IAmDead             -- ^ Marks unused variables.  Sometimes useful for
@@ -929,15 +928,13 @@ data OccInfo
   | OneOcc          { occ_in_lam  :: !InsideLam
                     , occ_n_br    :: {-# UNPACK #-} !BranchCount
                     , occ_int_cxt :: !InterestingCxt
-                    , occ_tail    :: !TailCallInfo
-                    , occ_static_args :: {-# UNPACK #-} !StaticArgs }
+                    , occ_tail    :: !TailCallInfo }
                         -- ^ Occurs exactly once (per branch), not inside a rule
 
   -- | This identifier breaks a loop of mutually recursive functions. The field
   -- marks whether it is only a loop breaker due to a reference in a rule
   | IAmALoopBreaker { occ_rules_only  :: !RulesOnly
-                    , occ_tail        :: !TailCallInfo
-                    , occ_static_args :: {-# UNPACK #-} !StaticArgs }
+                    , occ_tail        :: !TailCallInfo }
                         -- Note [LoopBreaker OccInfo]
   deriving (Eq)
 
@@ -962,14 +959,6 @@ newtype StaticArgs = StaticArgs { unwrapStaticArgs :: Word }
 noStaticArgs :: StaticArgs
 noStaticArgs = StaticArgs zeroBits
 
--- | All one bit vector; all arguments are static
-allStaticArgs :: StaticArgs
-allStaticArgs = StaticArgs (complement zeroBits)
-
-staticArgsInfo :: OccInfo -> StaticArgs
-staticArgsInfo IAmDead = allStaticArgs -- should be a neutral element to @andStaticArgs@
-staticArgsInfo occ     = occ_static_args occ
-
 -- | The maximum number of static arguments we can express
 mAX_STATIC_ARGS :: Int
 mAX_STATIC_ARGS = 32 `min` finiteBitSize (unwrapStaticArgs noStaticArgs)
@@ -980,7 +969,12 @@ mkStaticArgs = StaticArgs
              . take mAX_STATIC_ARGS
 
 getStaticArgs :: StaticArgs -> [Staticness ()]
-getStaticArgs (StaticArgs n) = map (to_static . testBit n) [0..finiteBitSize n - 1]
+getStaticArgs sa@(StaticArgs n)
+  | sa == noStaticArgs
+  = []
+  | otherwise
+  = dropWhileEnd (== NotStatic) -- trim trailing @NotStatic@s
+  $ map (to_static . testBit n) [0..finiteBitSize n - 1]
   where
     to_static True  = Static ()
     to_static False = NotStatic
@@ -988,6 +982,19 @@ getStaticArgs (StaticArgs n) = map (to_static . testBit n) [0..finiteBitSize n -
 andStaticArgs :: StaticArgs -> StaticArgs -> StaticArgs
 andStaticArgs (StaticArgs sa1) (StaticArgs sa2) = StaticArgs $ sa1 .&. sa2
 
+instance Outputable StaticArgs where
+  ppr = hcat . map pp_bit . getStaticArgs
+    where
+      pp_bit NotStatic = char '.'
+      pp_bit Static{}  = char 'S'
+
+_pprShortStaticArgs :: StaticArgs -> SDoc
+_pprShortStaticArgs static_args
+  | static_args == noStaticArgs = empty
+  | otherwise                   = char 'S' <> brackets (int n_static_args)
+  where
+    n_static_args = count isStatic (getStaticArgs static_args)
+
 {-
 Note [LoopBreaker OccInfo]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1001,12 +1008,10 @@ See OccurAnal Note [Weak loop breakers]
 -}
 
 noOccInfo :: OccInfo
-noOccInfo = ManyOccs { occ_tail = NoTailCallInfo, occ_static_args = noStaticArgs }
+noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }
 
 isNoOccInfo :: OccInfo -> Bool
-isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo
-                     , occ_static_args = static_args }
-  = static_args == noStaticArgs
+isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo } = True
 isNoOccInfo _ = False
 
 isManyOccs :: OccInfo -> Bool
@@ -1079,8 +1084,8 @@ instance Outputable TailCallInfo where
 
 -----------------
 strongLoopBreaker, weakLoopBreaker :: OccInfo
-strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo noStaticArgs
-weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo noStaticArgs
+strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo
+weakLoopBreaker   = IAmALoopBreaker True  NoTailCallInfo
 
 isWeakLoopBreaker :: OccInfo -> Bool
 isWeakLoopBreaker (IAmALoopBreaker{}) = True
@@ -1106,36 +1111,27 @@ zapFragileOcc occ         = zapOccTailCallInfo occ
 
 instance Outputable OccInfo where
   -- only used for debugging; never parsed.  KSW 1999-07
-  ppr (ManyOccs tails static_args)     = pprShortTailCallInfo tails <> pprShortStaticArgs static_args
+  ppr (ManyOccs tails)     = pprShortTailCallInfo tails
   ppr IAmDead              = text "Dead"
-  ppr (IAmALoopBreaker rule_only tails static_args)
-        = text "LoopBreaker" <> pp_ro <> pp_tail <> pp_sas
+  ppr (IAmALoopBreaker rule_only tails)
+        = text "LoopBreaker" <> pp_ro <> pp_tail
         where
           pp_ro | rule_only = char '!'
                 | otherwise = empty
           pp_tail           = pprShortTailCallInfo tails
-          pp_sas            = pprShortStaticArgs static_args
-  ppr (OneOcc inside_lam one_branch int_cxt tail_info static_args)
-        = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail <> pp_sas
+  ppr (OneOcc inside_lam one_branch int_cxt tail_info)
+        = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail
         where
           pp_lam IsInsideLam     = char 'L'
           pp_lam NotInsideLam    = empty
           pp_args IsInteresting  = char '!'
           pp_args NotInteresting = empty
           pp_tail                = pprShortTailCallInfo tail_info
-          pp_sas                 = pprShortStaticArgs static_args
 
 pprShortTailCallInfo :: TailCallInfo -> SDoc
 pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar)
 pprShortTailCallInfo NoTailCallInfo        = empty
 
-pprShortStaticArgs :: StaticArgs -> SDoc
-pprShortStaticArgs static_args
-  | static_args == noStaticArgs = empty
-  | otherwise                   = char 'S' <> brackets (int n_static_args)
-  where
-    n_static_args = count isStatic (getStaticArgs static_args)
-
 data Staticness a
   = Static a
   | NotStatic
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index b0c83ce8b2..fe9ff8ea67 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -55,7 +55,7 @@ module GHC.Types.Id (
         globaliseId, localiseId,
         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
         zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
-        zapIdUsedOnceInfo, zapIdTailCallInfo,
+        zapIdUsedOnceInfo, zapIdTailCallInfo, zapIdStaticArgs,
         zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,
         transferPolyIdInfo, scaleIdBy, scaleVarBy,
 
@@ -98,6 +98,7 @@ module GHC.Types.Id (
         idCafInfo, idLFInfo_maybe,
         idOneShotInfo, idStateHackOneShotInfo,
         idOccInfo,
+        idStaticArgs,
         isNeverLevPolyId,
 
         -- ** Writing 'IdInfo' fields
@@ -108,6 +109,7 @@ module GHC.Types.Id (
         setIdSpecialisation,
         setIdCafInfo,
         setIdOccInfo, zapIdOccInfo,
+        setIdStaticArgs,
         setIdLFInfo,
 
         setIdDemandInfo,
@@ -784,6 +786,15 @@ setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
 zapIdOccInfo :: Id -> Id
 zapIdOccInfo b = b `setIdOccInfo` noOccInfo
 
+idStaticArgs :: Id -> StaticArgs
+idStaticArgs id = staticArgsInfo (idInfo id)
+
+setIdStaticArgs :: Id -> StaticArgs -> Id
+setIdStaticArgs id static_args = modifyIdInfo (`setStaticArgsInfo` static_args) id
+
+zapIdStaticArgs :: Id -> Id
+zapIdStaticArgs b = b `setIdStaticArgs` noStaticArgs
+
 {-
         ---------------------------------
         -- INLINING
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 6620e23cad..8b2fbf6846 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -75,6 +75,9 @@ module GHC.Types.Id.Info (
         ppCafInfo, mayHaveCafRefs,
         cafInfo, setCafInfo,
 
+        -- ** Static arguments
+        StaticArgs, staticArgsInfo, setStaticArgsInfo,
+
         -- ** The LambdaFormInfo type
         LambdaFormInfo(..),
         lfInfo, setLFInfo,
@@ -128,6 +131,7 @@ infixl  1 `setRuleInfo`,
           `setStrictnessInfo`,
           `setCprInfo`,
           `setDemandInfo`,
+          `setStaticArgsInfo`,
           `setNeverLevPoly`,
           `setLevityInfoWithType`
 
@@ -278,6 +282,7 @@ data IdInfo
         -- 4% in some programs. See #17497 and associated MR.
         --
         -- See documentation of the getters for what these packed fields mean.
+        staticArgsInfo  :: {-# UNPACK #-} !StaticArgs,
         lfInfo          :: !(Maybe LambdaFormInfo)
     }
 
@@ -415,6 +420,9 @@ setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }
 setCprInfo :: IdInfo -> CprSig -> IdInfo
 setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }
 
+setStaticArgsInfo :: IdInfo -> StaticArgs -> IdInfo
+setStaticArgsInfo info sa = info { staticArgsInfo = sa }
+
 -- | Basic 'IdInfo' that carries no useful information whatsoever
 vanillaIdInfo :: IdInfo
 vanillaIdInfo
@@ -432,6 +440,7 @@ vanillaIdInfo
                                   bitfieldSetOneShotInfo NoOneShotInfo $
                                   bitfieldSetLevityInfo NoLevityInfo $
                                   emptyBitField,
+            staticArgsInfo      = noStaticArgs,
             lfInfo              = Nothing
            }
 
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
index 6d13436169..0c2fc6e115 100644
--- a/compiler/GHC/Types/Unique/FM.hs
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -70,6 +70,7 @@ module GHC.Types.Unique.FM (
         isNullUFM,
         lookupUFM, lookupUFM_Directly,
         lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
+        delLookupUFM,
         nonDetEltsUFM, eltsUFM, nonDetKeysUFM,
         ufmToSet_Directly,
         nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM,
@@ -338,6 +339,11 @@ lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
 lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt
 lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
 
+delLookupUFM :: Uniquable key => UniqFM key elt -> key -> (Maybe elt, UniqFM key elt)
+delLookupUFM (UFM m) k = (mb_v, UFM m')
+  where
+    (mb_v, m') = M.updateLookupWithKey (\_key _elt -> Nothing) (getKey $ getUnique k) m
+
 eltsUFM :: UniqFM key elt -> [elt]
 eltsUFM (UFM m) = M.elems m
 
diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs
index ed58c413f4..110b4fde60 100644
--- a/compiler/GHC/Types/Var/Env.hs
+++ b/compiler/GHC/Types/Var/Env.hs
@@ -16,7 +16,7 @@ module GHC.Types.Var.Env (
         plusVarEnvList, alterVarEnv,
         delVarEnvList, delVarEnv,
         minusVarEnv,
-        lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
+        lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, delLookupVarEnv,
         mapVarEnv, zipVarEnv,
         modifyVarEnv, modifyVarEnv_Directly,
         isEmptyVarEnv,
@@ -488,6 +488,7 @@ lookupVarEnv      :: VarEnv a -> Var -> Maybe a
 filterVarEnv      :: (a -> Bool) -> VarEnv a -> VarEnv a
 lookupVarEnv_NF   :: VarEnv a -> Var -> a
 lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
+delLookupVarEnv   :: VarEnv a -> Var -> (Maybe a, VarEnv a)
 elemVarEnv        :: Var -> VarEnv a -> Bool
 elemVarEnvByKey   :: Unique -> VarEnv a -> Bool
 disjointVarEnv    :: VarEnv a -> VarEnv a -> Bool
@@ -509,6 +510,7 @@ minusVarEnv      = minusUFM
 plusVarEnv       = plusUFM
 plusVarEnvList   = plusUFMList
 lookupVarEnv     = lookupUFM
+delLookupVarEnv  = delLookupUFM
 filterVarEnv     = filterUFM
 lookupWithDefaultVarEnv = lookupWithDefaultUFM
 mapVarEnv        = mapUFM