Rip out global state hack flagwip/state-hack-nonglobal

13 files changed, 216 insertions, 165 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 7a2fee6d0f..7e0f7ccbae 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -81,7 +81,6 @@ import GHC.Data.FastString
 import GHC.Data.Graph.UnVar
 import GHC.Data.Pair
 
-import GHC.Utils.GlobalVars( unsafeHasNoStateHack )
 import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -138,13 +137,14 @@ joinRhsArity _         = 0
 
 
 ---------------
-exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig)
+exprBotStrictness_maybe :: StateHackFlag -> CoreExpr -> Maybe (Arity, DmdSig, CprSig)
 -- A cheap and cheerful function that identifies bottoming functions
 -- and gives them a suitable strictness and CPR signatures.
 -- It's used during float-out
-exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e)
+exprBotStrictness_maybe st_hack e =
+  arityTypeBotSigs_maybe (cheapArityType st_hack e)
 
-arityTypeBotSigs_maybe :: ArityType ->  Maybe (Arity, DmdSig, CprSig)
+arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig)
 -- Arity of a divergent function
 arityTypeBotSigs_maybe (AT lams div)
   | isDeadEndDiv div = Just ( arity
@@ -203,11 +203,12 @@ typeArity ty0 =
       | otherwise
       = acc
 
-typeOneShots :: Type -> [OneShotInfo]
+
+typeOneShots :: StateHackFlag -> Type -> [OneShotInfo]
 -- How many value arrows are visible in the type?
 -- We look through foralls, and newtypes
 -- See Note [Arity invariants for bindings]
-typeOneShots ty
+typeOneShots st_hack ty
   = go initRecTc ty
   where
     go rec_nts ty
@@ -215,7 +216,7 @@ typeOneShots ty
       = go rec_nts ty'
 
       | Just (_,_,arg,res) <- splitFunTy_maybe ty
-      = typeOneShot arg : go rec_nts res
+      = typeOneShot st_hack arg : go rec_nts res
 
       | Just (tc,tys) <- splitTyConApp_maybe ty
       , Just (ty', _) <- instNewTyCon_maybe tc tys
@@ -235,17 +236,17 @@ typeOneShots ty
       | otherwise
       = []
 
-typeOneShot :: Type -> OneShotInfo
-typeOneShot ty
-   | isStateHackType ty = OneShotLam
-   | otherwise          = NoOneShotInfo
+typeOneShot :: StateHackFlag -> Type -> OneShotInfo
+typeOneShot st_hack ty
+   | isStateHackType st_hack ty = OneShotLam
+   | otherwise                  = NoOneShotInfo
 
 -- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account
 -- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity"
-idStateHackOneShotInfo :: Id -> OneShotInfo
-idStateHackOneShotInfo id
-    | isStateHackType (idType id) = OneShotLam
-    | otherwise                   = idOneShotInfo id
+idStateHackOneShotInfo :: StateHackFlag -> Id -> OneShotInfo
+idStateHackOneShotInfo st_hack id
+    | isStateHackType st_hack (idType id) = OneShotLam
+    | otherwise                           = idOneShotInfo id
 
 -- | Returns whether the lambda associated with the 'Id' is
 --   certainly applied at most once
@@ -253,15 +254,15 @@ idStateHackOneShotInfo id
 -- It works on type variables as well as Ids, returning True
 -- Its main purpose is to encapsulate the Horrible State Hack
 -- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity"
-isOneShotBndr :: Var -> Bool
-isOneShotBndr var
-  | isTyVar var                              = True
-  | OneShotLam <- idStateHackOneShotInfo var = True
-  | otherwise                                = False
-
-isStateHackType :: Type -> Bool
-isStateHackType ty
-  | unsafeHasNoStateHack   -- Switch off with -fno-state-hack
+isOneShotBndr :: StateHackFlag -> Var -> Bool
+isOneShotBndr st_hack var
+  | isTyVar var                                      = True
+  | OneShotLam <- idStateHackOneShotInfo st_hack var = True
+  | otherwise                                        = False
+
+isStateHackType :: StateHackFlag -> Type -> Bool
+isStateHackType st_hack ty
+  | not (stateHackEnabled st_hack)  -- Switch off with -fno-state-hack
   = False
   | otherwise
   = case tyConAppTyCon_maybe ty of
@@ -419,17 +420,17 @@ The test simplCore/should_compile/T3722 is an excellent example.
 *                                                                      *
 ********************************************************************* -}
 
-zapLamBndrs :: FullArgCount -> [Var] -> [Var]
+zapLamBndrs :: StateHackFlag -> FullArgCount -> [Var] -> [Var]
 -- If (\xyz. t) appears under-applied to only two arguments,
 -- we must zap the occ-info on x,y, because they appear (in 't') under the \z.
 -- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal
 --
 -- NB: both `arg_count` and `bndrs` include both type and value args/bndrs
-zapLamBndrs arg_count bndrs
+zapLamBndrs st_hack arg_count bndrs
   | no_need_to_zap = bndrs
   | otherwise      = zap_em arg_count bndrs
   where
-    no_need_to_zap = all isOneShotBndr (drop arg_count bndrs)
+    no_need_to_zap = all (isOneShotBndr st_hack) (drop arg_count bndrs)
 
     zap_em :: FullArgCount -> [Var] -> [Var]
     zap_em 0 bs = bs
@@ -864,6 +865,7 @@ trimArityType max_arity at@(AT lams _)
 data ArityOpts = ArityOpts
   { ao_ped_bot :: !Bool -- See Note [Dealing with bottom]
   , ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries]
+  , ao_state_hack :: !StateHackFlag
   }
 
 -- | The Arity returned is the number of value args the
@@ -917,6 +919,8 @@ findRhsArity opts is_rec bndr rhs
     init_env :: ArityEnv
     init_env = findRhsArityEnv opts (isJoinId bndr)
 
+    st_hack = ao_state_hack opts
+
     -- Non-join-points only
     non_join_arity_type = case is_rec of
                              Recursive    -> go 0 botArityType
@@ -928,7 +932,7 @@ findRhsArity opts is_rec bndr rhs
     -- and Note [Arity for recursive join bindings]
     join_arity_type = case is_rec of
                          Recursive    -> go 0 botArityType
-                         NonRecursive -> trimArityType ty_arity (cheapArityType rhs)
+                         NonRecursive -> trimArityType ty_arity (cheapArityType st_hack rhs)
 
     ty_arity     = typeArity (idType bndr)
     id_one_shots = idDemandOneShots bndr
@@ -1235,12 +1239,12 @@ in the main arityType function.)
 *                                                                      *
 ********************************************************************* -}
 
-arityLam :: Id -> ArityType -> ArityType
-arityLam id (AT oss div)
+arityLam :: StateHackFlag -> Id -> ArityType -> ArityType
+arityLam st_hack id (AT oss div)
   = AT ((IsCheap, one_shot) : oss) div
   where
     one_shot | isDeadEndDiv div = OneShotLam
-             | otherwise        = idStateHackOneShotInfo id
+             | otherwise        = idStateHackOneShotInfo st_hack id
     -- If the body diverges, treat it as one-shot: no point
     -- in floating out, and no penalty for floating in
     -- See Wrinkle [Bottoming functions] in Note [ArityType]
@@ -1513,17 +1517,18 @@ arityType env (Var v)
   = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $
     -- All join-point should be in the ae_sigs
     -- See Note [No free join points in arityType]
-    idArityType v
+    idArityType (ao_state_hack $ am_opts env) v
 
 arityType env (Cast e _)
   = arityType env e
 
         -- Lambdas; increase arity
 arityType env (Lam x e)
-  | isId x    = arityLam x (arityType env' e)
+  | isId x    = arityLam st_hack x (arityType env' e)
   | otherwise = arityType env' e
   where
     env' = delInScope env x
+    st_hack = ao_state_hack (am_opts env)
 
         -- Applications; decrease arity, except for types
 arityType env (App fun (Type _))
@@ -1573,9 +1578,10 @@ arityType env (Let (Rec prs) e)
   where
     bind_cost (b,e) = exprCost env' e (Just (idType b))
     env'            = foldl extend_rec env prs
+    st_hack         = ao_state_hack (am_opts env)
     extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv
     extend_rec env (b,_) = extendSigEnv env b  $
-                           idArityType b
+                           idArityType st_hack b
       -- See Note [arityType for recursive let-bindings]
 
 arityType env (Tick t e)
@@ -1584,8 +1590,8 @@ arityType env (Tick t e)
 arityType _ _ = topArityType
 
 --------------------
-idArityType :: Id -> ArityType
-idArityType v
+idArityType :: StateHackFlag -> Id -> ArityType
+idArityType st_hack v
   | strict_sig <- idDmdSig v
   , (ds, div) <- splitDmdSig strict_sig
   , isDeadEndDiv div
@@ -1600,10 +1606,11 @@ idArityType v
     id_ty = idType v
 
     one_shots :: [(Cost,OneShotInfo)]  -- One-shot-ness derived from the type
-    one_shots = repeat IsCheap `zip` typeOneShots id_ty
+    one_shots = repeat IsCheap `zip` typeOneShots st_hack id_ty
 
 --------------------
-cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType
+cheapArityType :: HasDebugCallStack
+               => StateHackFlag -> CoreExpr -> ArityType
 -- A fast and cheap version of arityType.
 -- Returns an ArityType with IsCheap everywhere
 -- c.f. GHC.Core.Utils.exprIsDeadEnd
@@ -1614,11 +1621,11 @@ cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType
 --
 -- Returns ArityType, not SafeArityType.  The caller must do
 -- trimArityType if necessary.
-cheapArityType e = go e
+cheapArityType st_hack e = go e
   where
-    go (Var v)                  = idArityType v
+    go (Var v)                  = idArityType st_hack v
     go (Cast e _)               = go e
-    go (Lam x e)  | isId x      = arityLam x (go e)
+    go (Lam x e)  | isId x      = arityLam st_hack x (go e)
                   | otherwise   = go e
     go (App e a)  | isTypeArg a = go e
                   | otherwise   = arity_app a (go e)
diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs
index cf3ca726e4..ab664822d8 100644
--- a/compiler/GHC/Core/Opt/FloatIn.hs
+++ b/compiler/GHC/Core/Opt/FloatIn.hs
@@ -28,7 +28,7 @@ import GHC.Core.Utils
 import GHC.Core.FVs
 import GHC.Core.Type
 
-import GHC.Types.Basic      ( RecFlag(..), isRec, Levity(Unlifted) )
+import GHC.Types.Basic      ( RecFlag(..), isRec, Levity(Unlifted), StateHackFlag )
 import GHC.Types.Id         ( idType, isJoinId, isJoinId_maybe )
 import GHC.Types.Tickish
 import GHC.Types.Var
@@ -43,13 +43,13 @@ Top-level interface function, @floatInwards@.  Note that we do not
 actually float any bindings downwards from the top-level.
 -}
 
-floatInwards :: Platform -> CoreProgram -> CoreProgram
-floatInwards platform binds = map (fi_top_bind platform) binds
+floatInwards :: Platform -> StateHackFlag -> CoreProgram -> CoreProgram
+floatInwards platform st_hack binds = map (fi_top_bind platform) binds
   where
     fi_top_bind platform (NonRec binder rhs)
-      = NonRec binder (fiExpr platform [] (freeVars rhs))
+      = NonRec binder (fiExpr platform st_hack [] (freeVars rhs))
     fi_top_bind platform (Rec pairs)
-      = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ]
+      = Rec [ (b, fiExpr platform st_hack [] (freeVars rhs)) | (b, rhs) <- pairs ]
 
 
 {-
@@ -136,19 +136,20 @@ type FloatInBinds = [FloatInBind]
         -- In reverse dependency order (innermost binder first)
 
 fiExpr :: Platform
+       -> StateHackFlag
        -> FloatInBinds      -- Binds we're trying to drop
                             -- as far "inwards" as possible
        -> CoreExprWithFVs   -- Input expr
        -> CoreExpr          -- Result
 
-fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)
+fiExpr _ _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)
                                        -- See Note [Dead bindings]
-fiExpr _ to_drop (_, AnnType ty)     = assert (null to_drop) $ Type ty
-fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)
-fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
-fiExpr platform to_drop (_, AnnCast expr (co_ann, co))
+fiExpr _ _ to_drop (_, AnnType ty)     = assert (null to_drop) $ Type ty
+fiExpr _ _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)
+fiExpr _ _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
+fiExpr platform st_hack to_drop (_, AnnCast expr (co_ann, co))
   = wrapFloats (drop_here ++ co_drop) $
-    Cast (fiExpr platform e_drop expr) co
+    Cast (fiExpr platform st_hack e_drop expr) co
   where
     [drop_here, e_drop, co_drop]
       = sepBindsByDropPoint platform False
@@ -161,11 +162,11 @@ need to get at all the arguments.  The next simplifier run will
 pull out any silly ones.
 -}
 
-fiExpr platform to_drop ann_expr@(_,AnnApp {})
+fiExpr platform st_hack to_drop ann_expr@(_,AnnApp {})
   = wrapFloats drop_here $ wrapFloats extra_drop $
     mkTicks ticks $
-    mkApps (fiExpr platform fun_drop ann_fun)
-           (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)
+    mkApps (fiExpr platform st_hack fun_drop ann_fun)
+           (zipWithEqual "fiExpr" (fiExpr platform st_hack) arg_drops ann_args)
            -- use zipWithEqual, we should have
            -- length ann_args = length arg_fvs = length arg_drops
   where
@@ -196,7 +197,7 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {})
     add_arg (fun_ty, extra_fvs) (_, AnnType ty)
       = (piResultTy fun_ty ty, extra_fvs)
     add_arg (fun_ty, extra_fvs) (arg_fvs, arg)
-      | noFloatIntoArg arg
+      | noFloatIntoArg st_hack arg
       = (funResultTy fun_ty, extra_fvs `unionDVarSet` arg_fvs)
       | otherwise
       = (funResultTy fun_ty, extra_fvs)
@@ -294,13 +295,13 @@ be dropped right away.
 
 -}
 
-fiExpr platform to_drop lam@(_, AnnLam _ _)
-  | noFloatIntoLam bndrs       -- Dump it all here
+fiExpr platform st_hack to_drop lam@(_, AnnLam _ _)
+  | noFloatIntoLam st_hack bndrs       -- Dump it all here
      -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088
-  = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))
+  = wrapFloats to_drop (mkLams bndrs (fiExpr platform st_hack [] body))
 
   | otherwise           -- Float inside
-  = mkLams bndrs (fiExpr platform to_drop body)
+  = mkLams bndrs (fiExpr platform st_hack to_drop body)
 
   where
     (bndrs, body) = collectAnnBndrs lam
@@ -312,12 +313,12 @@ We don't float lets inwards past an SCC.
         cc, change current cc to the new one and float binds into expr.
 -}
 
-fiExpr platform to_drop (_, AnnTick tickish expr)
+fiExpr platform st_hack to_drop (_, AnnTick tickish expr)
   | tickish `tickishScopesLike` SoftScope
-  = Tick tickish (fiExpr platform to_drop expr)
+  = Tick tickish (fiExpr platform st_hack to_drop expr)
 
   | otherwise -- Wimp out for now - we could push values in
-  = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr))
+  = wrapFloats to_drop (Tick tickish (fiExpr platform st_hack [] expr))
 
 {-
 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
@@ -370,11 +371,11 @@ idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
 idFreeVars.
 -}
 
-fiExpr platform to_drop (_,AnnLet bind body)
-  = fiExpr platform (after ++ new_float : before) body
+fiExpr platform st_hack to_drop (_,AnnLet bind body)
+  = fiExpr platform st_hack (after ++ new_float : before) body
            -- to_drop is in reverse dependency order
   where
-    (before, new_float, after) = fiBind platform to_drop bind body_fvs
+    (before, new_float, after) = fiBind platform st_hack to_drop bind body_fvs
     body_fvs    = freeVarsOf body
 
 {- Note [Floating primops]
@@ -435,17 +436,17 @@ bindings are:
 
 -}
 
-fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])
+fiExpr platform st_hack to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])
   | isUnliftedType (idType case_bndr)
      -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType
   , exprOkForSideEffects (deAnnotate scrut)
       -- See Note [Floating primops]
   = wrapFloats shared_binds $
-    fiExpr platform (case_float : rhs_binds) rhs
+    fiExpr platform st_hack (case_float : rhs_binds) rhs
   where
     case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
                     (FloatCase scrut' case_bndr con alt_bndrs)
-    scrut'     = fiExpr platform scrut_binds scrut
+    scrut'     = fiExpr platform st_hack scrut_binds scrut
     rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
     scrut_fvs  = freeVarsOf scrut
 
@@ -454,10 +455,10 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]
            [scrut_fvs, rhs_fvs]
            to_drop
 
-fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
+fiExpr platform st_hack to_drop (_, AnnCase scrut case_bndr ty alts)
   = wrapFloats drop_here1 $
     wrapFloats drop_here2 $
-    Case (fiExpr platform scrut_drops scrut) case_bndr ty
+    Case (fiExpr platform st_hack scrut_drops scrut) case_bndr ty
          (zipWithEqual "fiExpr" fi_alt alts_drops_s alts)
          -- use zipWithEqual, we should have length alts_drops_s = length alts
   where
@@ -480,10 +481,11 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
            -- Delete case_bndr and args from free vars of rhs
            -- to get free vars of alt
 
-    fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)
+    fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform st_hack to_drop rhs)
 
 ------------------
 fiBind :: Platform
+       -> StateHackFlag
        -> FloatInBinds      -- Binds we're trying to drop
                             -- as far "inwards" as possible
        -> CoreBindWithFVs   -- Input binding
@@ -492,7 +494,7 @@ fiBind :: Platform
           , FloatInBind     -- The binding itself
           , FloatInBinds)   -- Land these after
 
-fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
+fiBind platform st_hack to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
   = ( extra_binds ++ shared_binds          -- Land these before
                                            -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]
     , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself
@@ -503,7 +505,7 @@ fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
     body_fvs2 = body_fvs `delDVarSet` id
 
     rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2)]
-    extra_fvs | noFloatIntoRhs NonRecursive id rhs
+    extra_fvs | noFloatIntoRhs st_hack NonRecursive id rhs
               = rule_fvs `unionDVarSet` rhs_fvs
               | otherwise
               = rule_fvs
@@ -518,11 +520,11 @@ fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
             to_drop
 
         -- Push rhs_binds into the right hand side of the binding
-    rhs'     = fiRhs platform rhs_binds id ann_rhs
+    rhs'     = fiRhs platform st_hack rhs_binds id ann_rhs
     rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs
                         -- Don't forget the rule_fvs; the binding mentions them!
 
-fiBind platform to_drop (AnnRec bindings) body_fvs
+fiBind platform st_hack to_drop (AnnRec bindings) body_fvs
   = ( extra_binds ++ shared_binds
     , FB (mkDVarSet ids) rhs_fvs'
          (FloatLet (Rec (fi_bind rhss_binds bindings)))
@@ -535,7 +537,7 @@ fiBind platform to_drop (AnnRec bindings) body_fvs
     rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
     extra_fvs = rule_fvs `unionDVarSet`
                 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
-                              , noFloatIntoRhs Recursive bndr rhs ]
+                              , noFloatIntoRhs st_hack Recursive bndr rhs ]
 
     (shared_binds:extra_binds:body_binds:rhss_binds)
         = sepBindsByDropPoint platform False
@@ -552,28 +554,28 @@ fiBind platform to_drop (AnnRec bindings) body_fvs
             -> [(Id, CoreExpr)]
 
     fi_bind to_drops pairs
-      = [ (binder, fiRhs platform to_drop binder rhs)
+      = [ (binder, fiRhs platform st_hack to_drop binder rhs)
         | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
 
 ------------------
-fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
-fiRhs platform to_drop bndr rhs
+fiRhs :: Platform -> StateHackFlag -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
+fiRhs platform st_hack to_drop bndr rhs
   | Just join_arity <- isJoinId_maybe bndr
   , let (bndrs, body) = collectNAnnBndrs join_arity rhs
-  = mkLams bndrs (fiExpr platform to_drop body)
+  = mkLams bndrs (fiExpr platform st_hack to_drop body)
   | otherwise
-  = fiExpr platform to_drop rhs
+  = fiExpr platform st_hack to_drop rhs
 
 ------------------
-noFloatIntoLam :: [Var] -> Bool
-noFloatIntoLam bndrs = any bad bndrs
+noFloatIntoLam :: StateHackFlag -> [Var] -> Bool
+noFloatIntoLam st_hack bndrs = any bad bndrs
   where
-    bad b = isId b && not (isOneShotBndr b)
+    bad b = isId b && not (isOneShotBndr st_hack b)
     -- Don't float inside a non-one-shot lambda
 
-noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
+noFloatIntoRhs :: StateHackFlag -> RecFlag -> Id -> CoreExprWithFVs' -> Bool
 -- ^ True if it's a bad idea to float bindings into this RHS
-noFloatIntoRhs is_rec bndr rhs
+noFloatIntoRhs st_hack is_rec bndr rhs
   | isJoinId bndr
   = isRec is_rec -- Joins are one-shot iff non-recursive
 
@@ -581,13 +583,13 @@ noFloatIntoRhs is_rec bndr rhs
   = True  -- Preserve let-can-float invariant, see Note [noFloatInto considerations]
 
   | otherwise
-  = noFloatIntoArg rhs
+  = noFloatIntoArg st_hack rhs
 
-noFloatIntoArg :: CoreExprWithFVs' -> Bool
-noFloatIntoArg expr
+noFloatIntoArg :: StateHackFlag -> CoreExprWithFVs' -> Bool
+noFloatIntoArg st_hack expr
    | AnnLam bndr e <- expr
    , (bndrs, _) <- collectAnnBndrs e
-   =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)
+   =  noFloatIntoLam st_hack (bndr:bndrs)  -- Wrinkle 1 (a)
    || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)
       -- See Note [noFloatInto considerations] wrinkle 2
 
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index 0c6f4d5413..841aa94883 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -73,17 +73,18 @@ Here's the externally-callable interface:
 -}
 
 -- | Do occurrence analysis, and discard occurrence info returned
-occurAnalyseExpr :: CoreExpr -> CoreExpr
-occurAnalyseExpr expr = expr'
+occurAnalyseExpr :: StateHackFlag -> CoreExpr -> CoreExpr
+occurAnalyseExpr st_hack expr = expr'
   where
-    (WithUsageDetails _ expr') = occAnal initOccEnv expr
+    (WithUsageDetails _ expr') = occAnal (initOccEnv st_hack) expr
 
-occurAnalysePgm :: Module         -- Used only in debug output
+occurAnalysePgm :: StateHackFlag
+                -> Module         -- Used only in debug output
                 -> (Id -> Bool)         -- Active unfoldings
                 -> (Activation -> Bool) -- Active rules
                 -> [CoreRule]           -- Local rules for imported Ids
                 -> CoreProgram -> CoreProgram
-occurAnalysePgm this_mod active_unf active_rule imp_rules binds
+occurAnalysePgm st_hack this_mod active_unf active_rule imp_rules binds
   | isEmptyDetails final_usage
   = occ_anald_binds
 
@@ -91,8 +92,8 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
   = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))
     occ_anald_glommed_binds
   where
-    init_env = initOccEnv { occ_rule_act = active_rule
-                          , occ_unf_act  = active_unf }
+    init_env = (initOccEnv st_hack) { occ_rule_act = active_rule
+                                    , occ_unf_act  = active_unf }
 
     (WithUsageDetails final_usage occ_anald_binds) = go init_env binds
     (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel
@@ -840,8 +841,9 @@ occAnalRec :: OccEnv -> TopLevelFlag
            -> WithUsageDetails [CoreBind]
 
         -- The NonRec case is just like a Let (NonRec ...) above
-occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
-                                  , nd_uds = rhs_uds }))
+occAnalRec !env lvl
+           (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
+                           , nd_uds = rhs_uds }))
            (WithUsageDetails body_uds binds)
   | not (bndr `usedIn` body_uds)
   = WithUsageDetails body_uds binds -- See Note [Dead code]
@@ -851,8 +853,9 @@ occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
                      (NonRec tagged_bndr rhs : binds)
   where
     (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr
-    rhs_uds'      = adjustRhsUsage mb_join_arity rhs rhs_uds
+    rhs_uds'      = adjustRhsUsage st_hack mb_join_arity rhs rhs_uds
     mb_join_arity = willBeJoinId_maybe tagged_bndr
+    st_hack       = occ_state_hack env
 
         -- The Rec case is the interesting one
         -- See Note [Recursive bindings: the grand plan]
@@ -1477,7 +1480,7 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
 mkLoopBreakerNodes !env lvl body_uds details_s
   = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')
   where
-    (final_uds, bndrs') = tagRecBinders lvl body_uds details_s
+    (final_uds, bndrs') = tagRecBinders (occ_state_hack env) lvl body_uds details_s
 
     mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr
       = DigraphNode { node_payload      = new_nd
@@ -1772,20 +1775,22 @@ recognises except that the latter looks through (some) ticks.  Maybe a lambda
 group should also look through (some) ticks?
 -}
 
-isOneShotFun :: CoreExpr -> Bool
+isOneShotFun :: StateHackFlag -> CoreExpr -> Bool
 -- The top level lambdas, ignoring casts, of the expression
 -- are all one-shot.  If there aren't any lambdas at all, this is True
-isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e
-isOneShotFun (Cast e _) = isOneShotFun e
-isOneShotFun _          = True
+isOneShotFun st_hack = go
+  where
+    go (Lam b e)  = isOneShotBndr st_hack b && go e
+    go (Cast e _) = go e
+    go _          = True
 
-zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr
+zapLambdaBndrs :: StateHackFlag -> CoreExpr -> FullArgCount -> CoreExpr
 -- If (\xyz. t) appears under-applied to only two arguments,
 -- we must zap the occ-info on x,y, because they appear under the \z
 -- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal
 --
 -- NB: `arg_count` includes both type and value args
-zapLambdaBndrs fun arg_count
+zapLambdaBndrs st_hack fun arg_count
   = -- If the lambda is fully applied, leave it alone; if not
     -- zap the OccInfo on the lambdas that do have arguments,
     -- so they beta-reduce to use-many Lets rather than used-once ones.
@@ -1794,8 +1799,8 @@ zapLambdaBndrs fun arg_count
     zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr
     -- Nothing => No need to change the occ-info
     -- Just e  => Had to change
-    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot
-            | otherwise      = Just e   -- in which case no need to zap
+    zap 0 e | isOneShotFun st_hack e = Nothing  -- All remaining lambdas are one-shot
+            | otherwise              = Just e   -- in which case no need to zap
     zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }
     zap n (Lam b e)   = do { e' <- zap (n-1) e
                            ; return (Lam (zap_bndr b) e') }
@@ -1904,7 +1909,8 @@ occAnalRhs !env is_rec mb_join_arity rhs
            -- do the markAllInsideLam and markNonTailCall stuff before
            -- we've had a chance to help with join points; that comes next
         rhs2      = markJoinOneShots is_rec mb_join_arity rhs1
-        rhs_usage = adjustRhsUsage mb_join_arity rhs2 usage
+        rhs_usage = adjustRhsUsage st_hack mb_join_arity rhs2 usage
+        st_hack   = occ_state_hack env
     in WithUsageDetails rhs_usage rhs2
 
 
@@ -2209,8 +2215,9 @@ occAnal env app@(App _ _)
 
 occAnal env expr@(Lam {})
   = let (WithUsageDetails usage expr') = occAnalLam env expr
-        final_usage = markAllInsideLamIf (not (isOneShotFun expr')) $
+        final_usage = markAllInsideLamIf (not (isOneShotFun st_hack expr')) $
                       markAllNonTail usage
+        st_hack = occ_state_hack env
     in WithUsageDetails final_usage expr'
 
 occAnal env (Case scrut bndr ty alts)
@@ -2470,6 +2477,7 @@ data OccEnv
            , occ_bs_rng  :: !VarSet   -- Vars free in the range of occ_bs_env
                    -- Domain is Global and Local Ids
                    -- Range is just Local Ids
+           , occ_state_hack :: !StateHackFlag
     }
 
 
@@ -2502,8 +2510,8 @@ instance Outputable OccEncl where
 -- See Note [OneShots]
 type OneShots = [OneShotInfo]
 
-initOccEnv :: OccEnv
-initOccEnv
+initOccEnv :: StateHackFlag -> OccEnv
+initOccEnv st_hack
   = OccEnv { occ_encl      = OccVanilla
            , occ_one_shots = []
 
@@ -2513,7 +2521,9 @@ initOccEnv
            , occ_rule_act  = \_ -> True
 
            , occ_bs_env = emptyVarEnv
-           , occ_bs_rng = emptyVarSet }
+           , occ_bs_rng = emptyVarSet
+           , occ_state_hack = st_hack
+           }
 
 noBinderSwaps :: OccEnv -> Bool
 noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env
@@ -3132,17 +3142,18 @@ flattenUsageDetails ud@(UD { ud_env = env })
 
 -------------------
 -- See Note [Adjusting right-hand sides]
-adjustRhsUsage :: Maybe JoinArity
+adjustRhsUsage :: StateHackFlag
+               -> Maybe JoinArity
                -> CoreExpr       -- Rhs, AFTER occ anal
                -> UsageDetails   -- From body of lambda
                -> UsageDetails
-adjustRhsUsage mb_join_arity rhs usage
+adjustRhsUsage st_hack mb_join_arity rhs usage
   = -- c.f. occAnal (Lam {})
     markAllInsideLamIf (not one_shot) $
     markAllNonTailIf (not exact_join) $
     usage
   where
-    one_shot   = isOneShotFun rhs
+    one_shot   = isOneShotFun st_hack rhs
     exact_join = exactJoin mb_join_arity bndrs
     (bndrs,_)  = collectBinders rhs
 
@@ -3200,7 +3211,8 @@ tagNonRecBinder lvl usage binder
    in
    usage' `seq` (usage', binder')
 
-tagRecBinders :: TopLevelFlag           -- At top level?
+tagRecBinders :: StateHackFlag
+              -> TopLevelFlag           -- At top level?
               -> UsageDetails           -- Of body of let ONLY
               -> [Details]
               -> (UsageDetails,         -- Adjusted details for whole scope,
@@ -3208,7 +3220,7 @@ tagRecBinders :: TopLevelFlag           -- At top level?
                   [IdWithOccInfo])      -- Tagged binders
 -- Substantially more complicated than non-recursive case. Need to adjust RHS
 -- details *before* tagging binders (because the tags depend on the RHSes).
-tagRecBinders lvl body_uds details_s
+tagRecBinders st_hack lvl body_uds details_s
  = let
      bndrs    = map nd_bndr details_s
      rhs_udss = map nd_uds  details_s
@@ -3224,7 +3236,7 @@ tagRecBinders lvl body_uds details_s
 
      -- 2. Adjust usage details of each RHS, taking into account the
      --    join-point-hood decision
-     rhs_udss' = [ adjustRhsUsage (mb_join_arity bndr) rhs rhs_uds
+     rhs_udss' = [ adjustRhsUsage st_hack (mb_join_arity bndr) rhs rhs_uds
                  | ND { nd_bndr = bndr, nd_uds = rhs_uds
                       , nd_rhs = rhs } <- details_s ]
 
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 5638762e08..1dca48e126 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -92,14 +92,16 @@ data SimpleOpts = SimpleOpts
    { so_uf_opts :: !UnfoldingOpts   -- ^ Unfolding options
    , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
    , so_eta_red :: !Bool            -- ^ Eta reduction on?
+   , so_st_hack :: !StateHackFlag   -- ^ State hack on?
    }
 
 -- | Default options for the Simple optimiser.
-defaultSimpleOpts :: SimpleOpts
-defaultSimpleOpts = SimpleOpts
-   { so_uf_opts = defaultUnfoldingOpts
+defaultSimpleOpts :: StateHackFlag -> SimpleOpts
+defaultSimpleOpts st_hack = SimpleOpts
+   { so_uf_opts = defaultUnfoldingOpts st_hack
    , so_co_opts = OptCoercionOpts { optCoercionEnabled = False }
    , so_eta_red = False
+   , so_st_hack = st_hack
    }
 
 simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
@@ -145,9 +147,10 @@ simpleOptExpr opts expr
 simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
 -- See Note [The simple optimiser]
 simpleOptExprWith opts subst expr
-  = simple_opt_expr init_env (occurAnalyseExpr expr)
+  = simple_opt_expr init_env (occurAnalyseExpr st_hack expr)
   where
     init_env = (emptyEnv opts) { soe_subst = subst }
+    st_hack = so_st_hack opts
 
 ----------------------
 simpleOptPgm :: SimpleOpts
@@ -159,7 +162,7 @@ simpleOptPgm :: SimpleOpts
 simpleOptPgm opts this_mod binds rules =
     (reverse binds', rules', occ_anald_binds)
   where
-    occ_anald_binds  = occurAnalysePgm this_mod
+    occ_anald_binds  = occurAnalysePgm (so_st_hack opts) this_mod
                           (\_ -> True)  {- All unfoldings active -}
                           (\_ -> False) {- No rules active -}
                           rules binds
@@ -348,7 +351,7 @@ simple_app env (App e1 e2) as
   = simple_app env e1 ((env, e2) : as)
 
 simple_app env e@(Lam {}) as@(_:_)
-  = do_beta env (zapLambdaBndrs e n_args) as
+  = do_beta env (zapLambdaBndrs st_hack e n_args) as
     -- Be careful to zap the lambda binders if necessary
     -- c.f. the Lam case of simplExprF1 in GHC.Core.Opt.Simplify
     -- Lacking this zap caused #19347, when we had a redex
@@ -356,6 +359,7 @@ simple_app env e@(Lam {}) as@(_:_)
     -- where (as it happens) the eta-expanded K is produced by
     -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head
   where
+    st_hack = so_st_hack (soe_opts env)
     n_args = length as
 
     do_beta env (Lam b body) (a:as)
@@ -1421,23 +1425,23 @@ Currently, it is used in GHC.Core.Rules.match, and is required to make
 -}
 
 exprIsLambda_maybe :: HasDebugCallStack
-                   => InScopeEnv -> CoreExpr
+                   => StateHackFlag -> InScopeEnv -> CoreExpr
                    -> Maybe (Var, CoreExpr,[CoreTickish])
     -- See Note [exprIsLambda_maybe]
 
 -- The simple case: It is a lambda already
-exprIsLambda_maybe _ (Lam x e)
+exprIsLambda_maybe _ _ (Lam x e)
     = Just (x, e, [])
 
 -- Still straightforward: Ticks that we can float out of the way
-exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
+exprIsLambda_maybe st_hack (in_scope_set, id_unf) (Tick t e)
     | tickishFloatable t
-    , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
+    , Just (x, e, ts) <- exprIsLambda_maybe st_hack (in_scope_set, id_unf) e
     = Just (x, e, t:ts)
 
 -- Also possible: A casted lambda. Push the coercion inside
-exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
-    | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
+exprIsLambda_maybe st_hack (in_scope_set, id_unf) (Cast casted_e co)
+    | Just (x, e,ts) <- exprIsLambda_maybe st_hack (in_scope_set, id_unf) casted_e
     -- Only do value lambdas.
     -- this implies that x is not in scope in gamma (makes this code simpler)
     , not (isTyVar x) && not (isCoVar x)
@@ -1448,19 +1452,19 @@ exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
       res
 
 -- Another attempt: See if we find a partial unfolding
-exprIsLambda_maybe (in_scope_set, id_unf) e
+exprIsLambda_maybe st_hack (in_scope_set, id_unf) e
     | (Var f, as, ts) <- collectArgsTicks tickishFloatable e
     , idArity f > count isValArg as
     -- Make sure there is hope to get a lambda
     , Just rhs <- expandUnfolding_maybe (id_unf f)
     -- Optimize, for beta-reduction
-    , let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as)
+    , let e' = simpleOptExprWith (defaultSimpleOpts st_hack) (mkEmptySubst in_scope_set) (rhs `mkApps` as)
     -- Recurse, because of possible casts
-    , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
+    , Just (x', e'', ts') <- exprIsLambda_maybe st_hack (in_scope_set, id_unf) e'
     , let res = Just (x', e'', ts++ts')
     = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
       res
 
-exprIsLambda_maybe _ _e
+exprIsLambda_maybe _ _ _e
     = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
       Nothing
diff --git a/compiler/GHC/Core/SimpleOpt.hs-boot b/compiler/GHC/Core/SimpleOpt.hs-boot
index 4a63105475..0a37a2077f 100644
--- a/compiler/GHC/Core/SimpleOpt.hs-boot
+++ b/compiler/GHC/Core/SimpleOpt.hs-boot
@@ -3,9 +3,11 @@ module GHC.Core.SimpleOpt where
 import GHC.Core
 import {-# SOURCE #-} GHC.Core.Unfold
 import GHC.Utils.Misc (HasDebugCallStack)
+import GHC.Types.Basic (StateHackFlag)
 
 data SimpleOpts
 
 so_uf_opts :: SimpleOpts -> UnfoldingOpts
+so_st_hack :: SimpleOpts -> StateHackFlag
 
 simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 56f8251e3d..3260e83e87 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -55,6 +55,7 @@ import GHC.Data.Bag
 import GHC.Utils.Logger
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
+import GHC.Types.Basic ( StateHackFlag )
 import GHC.Types.ForeignCall
 import GHC.Types.Name
 import GHC.Types.Tickish
@@ -88,10 +89,12 @@ data UnfoldingOpts = UnfoldingOpts
 
    , unfoldingReportPrefix :: !(Maybe String)
       -- ^ Only report inlining decisions for names with this prefix
+
+   , unfoldingStateHack :: !StateHackFlag
    }
 
-defaultUnfoldingOpts :: UnfoldingOpts
-defaultUnfoldingOpts = UnfoldingOpts
+defaultUnfoldingOpts :: StateHackFlag -> UnfoldingOpts
+defaultUnfoldingOpts st_hack = UnfoldingOpts
    { unfoldingCreationThreshold = 750
       -- The unfoldingCreationThreshold threshold must be reasonably high
       -- to take account of possible discounts.
@@ -122,6 +125,8 @@ defaultUnfoldingOpts = UnfoldingOpts
 
       -- Don't filter inlining decision reports
    , unfoldingReportPrefix = Nothing
+
+   , unfoldingStateHack = st_hack
    }
 
 -- Helpers for "GHC.Driver.Session"
diff --git a/compiler/GHC/Core/Unfold.hs-boot b/compiler/GHC/Core/Unfold.hs-boot
index c62f1915c9..86bf2d5e11 100644
--- a/compiler/GHC/Core/Unfold.hs-boot
+++ b/compiler/GHC/Core/Unfold.hs-boot
@@ -1,10 +1,11 @@
 module GHC.Core.Unfold where
 
 import GHC.Prelude
+import GHC.Types.Basic ( StateHackFlag )
 
 data UnfoldingOpts
 
-defaultUnfoldingOpts :: UnfoldingOpts
+defaultUnfoldingOpts :: StateHackFlag -> UnfoldingOpts
 
 updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
 updateUseThreshold      :: Int -> UnfoldingOpts -> UnfoldingOpts
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
index adbbdec763..88cdba0f36 100644
--- a/compiler/GHC/Core/Unfold/Make.hs
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -51,12 +51,13 @@ mkFinalUnfolding opts src strict_sig expr
 
 -- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first
 mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding
-mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr)
+mkCompulsoryUnfolding' opts expr
+  = mkCompulsoryUnfolding (simpleOptExpr opts expr)
 
 -- | Used for things that absolutely must be unfolded
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
 mkCompulsoryUnfolding expr
-  = mkCoreUnfolding CompulsorySrc True
+  = mkCoreUnfolding (StateHackFlag True) CompulsorySrc True
                     expr
                     (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter
                              , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
@@ -71,17 +72,17 @@ mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
 mkSimpleUnfolding !opts rhs
   = mkUnfolding opts VanillaSrc False False rhs
 
-mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
-mkDFunUnfolding bndrs con ops
+mkDFunUnfolding :: StateHackFlag -> [Var] -> DataCon -> [CoreExpr] -> Unfolding
+mkDFunUnfolding st_hack bndrs con ops
   = DFunUnfolding { df_bndrs = bndrs
                   , df_con = con
-                  , df_args = map occurAnalyseExpr ops }
+                  , df_args = map (occurAnalyseExpr st_hack) ops }
                   -- See Note [Occurrence analysis of unfoldings]
 
-mkDataConUnfolding :: CoreExpr -> Unfolding
+mkDataConUnfolding :: StateHackFlag -> CoreExpr -> Unfolding
 -- Used for non-newtype data constructors with non-trivial wrappers
-mkDataConUnfolding expr
-  = mkCoreUnfolding StableSystemSrc True expr guide
+mkDataConUnfolding st_hack expr
+  = mkCoreUnfolding st_hack StableSystemSrc True expr guide
     -- No need to simplify the expression
   where
     guide = UnfWhen { ug_arity     = manifestArity expr
@@ -92,11 +93,13 @@ mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
 -- Make the unfolding for the wrapper in a worker/wrapper split
 -- after demand/CPR analysis
 mkWrapperUnfolding opts expr arity
-  = mkCoreUnfolding StableSystemSrc True
+  = mkCoreUnfolding st_hack StableSystemSrc True
                     (simpleOptExpr opts expr)
                     (UnfWhen { ug_arity     = arity
                              , ug_unsat_ok  = unSaturatedOk
                              , ug_boring_ok = boringCxtNotOk })
+  where
+    st_hack = so_st_hack opts
 
 mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
 -- See Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap
@@ -104,10 +107,11 @@ mkWorkerUnfolding opts work_fn
                   (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
                                  , uf_is_top = top_lvl })
   | isStableSource src
-  = mkCoreUnfolding src top_lvl new_tmpl guidance
+  = mkCoreUnfolding st_hack src top_lvl new_tmpl guidance
   where
     new_tmpl = simpleOptExpr opts (work_fn tmpl)
     guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl
+    st_hack = so_st_hack opts
 
 mkWorkerUnfolding _ _ _ = noUnfolding
 
@@ -117,7 +121,7 @@ mkWorkerUnfolding _ _ _ = noUnfolding
 -- resolve before doing any work).
 mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
 mkInlineUnfoldingNoArity opts src expr
-  = mkCoreUnfolding src
+  = mkCoreUnfolding st_hack src
                     True         -- Note [Top-level flag on inline rules]
                     expr' guide
   where
@@ -126,12 +130,13 @@ mkInlineUnfoldingNoArity opts src expr
                     , ug_unsat_ok = unSaturatedOk
                     , ug_boring_ok = boring_ok }
     boring_ok = inlineBoringOk expr'
+    st_hack = so_st_hack opts
 
 -- | Make an INLINE unfolding that will be used once the RHS has been saturated
 -- to the given arity.
 mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
 mkInlineUnfoldingWithArity opts src arity expr
-  = mkCoreUnfolding src
+  = mkCoreUnfolding st_hack src
                     True         -- Note [Top-level flag on inline rules]
                     expr' guide
   where
@@ -143,6 +148,7 @@ mkInlineUnfoldingWithArity opts src arity expr
     -- at the arity here.
     boring_ok | arity == 0 = True
               | otherwise  = inlineBoringOk expr'
+    st_hack = so_st_hack opts
 
 mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
 mkInlinableUnfolding opts src expr
@@ -163,7 +169,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args
   = assertPpr (rule_lhs_args `equalLength` old_bndrs)
               (ppr df $$ ppr rule_lhs_args) $
            -- For this ASSERT see Note [Specialising DFuns] in GHC.Core.Opt.Specialise
-    mkDFunUnfolding spec_bndrs con (map spec_arg args)
+    mkDFunUnfolding (so_st_hack opts) spec_bndrs con (map spec_arg args)
       -- For DFunUnfoldings we transform
       --       \obs. MkD <op1> ... <opn>
       -- to
@@ -180,7 +186,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args
                              , uf_guidance = old_guidance })
  | isStableSource src  -- See Note [Specialising unfoldings]
  , UnfWhen { ug_arity = old_arity } <- old_guidance
- = mkCoreUnfolding src top_lvl new_tmpl
+ = mkCoreUnfolding st_hack src top_lvl new_tmpl
                    (old_guidance { ug_arity = old_arity - arity_decrease })
  where
    new_tmpl = simpleOptExpr opts $
@@ -188,6 +194,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args
               spec_app tmpl  -- The beta-redexes created by spec_app
                              -- will be simplified away by simplOptExpr
    arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs
+   st_hack = so_st_hack opts
 
 
 specUnfolding _ _ _ _ _ = noUnfolding
@@ -314,22 +321,23 @@ mkUnfolding :: UnfoldingOpts
 -- Calculates unfolding guidance
 -- Occurrence-analyses the expression before capturing it
 mkUnfolding opts src top_lvl is_bottoming expr
-  = mkCoreUnfolding src top_lvl expr guidance
+  = mkCoreUnfolding st_hack src top_lvl expr guidance
   where
     is_top_bottoming = top_lvl && is_bottoming
     guidance         = calcUnfoldingGuidance opts is_top_bottoming expr
         -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
         -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+    st_hack          = unfoldingStateHack opts
 
-mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
+mkCoreUnfolding :: StateHackFlag -> UnfoldingSource -> Bool -> CoreExpr
                 -> UnfoldingGuidance -> Unfolding
 -- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding src top_lvl expr guidance
+mkCoreUnfolding st_hack src top_lvl expr guidance
   = CoreUnfolding { uf_tmpl = is_value `seq`
                               is_conlike `seq`
                               is_work_free `seq`
                               is_expandable `seq`
-                              occurAnalyseExpr expr
+                              occurAnalyseExpr st_hack expr
       -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]
       -- See #20905 for what a discussion of these 'seq's
       -- We are careful to make sure we only
@@ -371,7 +379,7 @@ certainlyWillInline opts fn_info rhs'
                | otherwise              = StableSystemSrc
 
           tmpl' | isStableSource src = uf_tmpl fn_unf
-                | otherwise          = occurAnalyseExpr rhs'
+                | otherwise          = occurAnalyseExpr st_hack rhs'
                 -- Do not overwrite stable unfoldings!
 
       DFunUnfolding {} -> Just fn_unf  -- Don't w/w DFuns; it never makes sense
@@ -381,6 +389,7 @@ certainlyWillInline opts fn_info rhs'
       _other_unf       -> Nothing
 
   where
+    st_hack  = unfoldingStateHack opts
     noinline = isNoInlinePragma (inlinePragInfo fn_info)
     fn_unf   = unfoldingInfo fn_info -- NB: loop-breakers never inline
 
diff --git a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs b/compiler/GHC/Driver/Config/Core/Opt/Arity.hs
index c1ffac1270..2f2173d0c7 100644
--- a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs
+++ b/compiler/GHC/Driver/Config/Core/Opt/Arity.hs
@@ -2,14 +2,16 @@ module GHC.Driver.Config.Core.Opt.Arity
   ( initArityOpts
   ) where
 
-import GHC.Prelude ()
+import GHC.Prelude (not)
 
 import GHC.Driver.Session
 
 import GHC.Core.Opt.Arity
+import GHC.Types.Basic (StateHackFlag(..))
 
 initArityOpts :: DynFlags -> ArityOpts
 initArityOpts dflags = ArityOpts
   { ao_ped_bot = gopt Opt_PedanticBottoms dflags
   , ao_dicts_cheap = gopt Opt_DictsCheap dflags
+  , ao_state_hack = StateHackFlag (not (gopt Opt_G_NoStateHack dflags))
   }
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 3e205402e9..c303e2cf40 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -247,7 +247,7 @@ import GHC.Utils.Monad
 import GHC.Types.Error (DiagnosticReason(..))
 import GHC.Types.SrcLoc
 import GHC.Types.SafeHaskell
-import GHC.Types.Basic ( IntWithInf, treatZeroAsInf )
+import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, StateHackFlag(..) )
 import GHC.Types.ProfAuto
 import qualified GHC.Types.FieldLabel as FieldLabel
 import GHC.Data.FastString
@@ -1251,7 +1251,7 @@ defaultDynFlags mySettings =
         extensions = [],
         extensionFlags = flattenExtensionFlags Nothing [],
 
-        unfoldingOpts = defaultUnfoldingOpts,
+        unfoldingOpts = defaultUnfoldingOpts (StateHackFlag True),
         maxWorkerArgs = 10,
 
         ghciHistSize = 50, -- keep a log of length 50 by default
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 88baab297c..b004d118b5 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -59,6 +59,9 @@ module GHC.Types.Basic (
         UnboxedTupleOrSum(..), unboxedTupleOrSumExtension,
         sumParens, pprAlternative,
 
+        -- ** Enabling the state hack
+        StateHackFlag(..),
+
         -- ** The OneShotInfo type
         OneShotInfo(..),
         noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
@@ -327,6 +330,8 @@ Other notes
   But the `\y` is most definitely not one-shot!
 -}
 
+newtype StateHackFlag = StateHackFlag { stateHackEnabled :: Bool }
+
 -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
 -- variable info. Sometimes we know whether the lambda binding this variable
 -- is a "one-shot" lambda; that is, whether it is applied at most once.
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 41e37b7f69..82ccf2c11f 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -488,7 +488,8 @@ mkDictSelId name clas
 
     info | new_tycon
          = base_info `setInlinePragInfo` alwaysInlinePragma
-                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity defaultSimpleOpts
+                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity
+                                           (defaultSimpleOpts (StateHackFlag True))
                                            StableSystemSrc 1
                                            (mkDictSelRhs clas val_index)
                    -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance
@@ -497,7 +498,8 @@ mkDictSelId name clas
          | otherwise
          = base_info `setRuleInfo` mkRuleInfo [rule]
                      `setInlinePragInfo` neverInlinePragma
-                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity defaultSimpleOpts
+                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity
+                                           (defaultSimpleOpts (StateHackFlag True))
                                            StableSystemSrc 1
                                            (mkDictSelRhs clas val_index)
                    -- Add a magic BuiltinRule, but no unfolding
diff --git a/hadrian/src/Settings/Flavours/Release.hs b/hadrian/src/Settings/Flavours/Release.hs
index 2f3daadae1..492f6b30d0 100644
--- a/hadrian/src/Settings/Flavours/Release.hs
+++ b/hadrian/src/Settings/Flavours/Release.hs
@@ -4,4 +4,4 @@ import Settings.Flavours.Performance
 import Flavour
 
 releaseFlavour :: Flavour
-releaseFlavour = enableHaddock performanceFlavour { name = "release" }
+releaseFlavour = splitSections $ enableHaddock performanceFlavour { name = "release" }