Flags to disable local let-floating; -flocal-float-out, -flocal-float-out-top-level CLI flags

These flags affect the behaviour of local let floating.

If `-flocal-float-out` is disabled (the default) then we disable all
local floating.

```
…(let x = let y = e in (a,b) in body)...
===>
…(let y = e; x = (a,b) in body)...

```

Further to this, top-level local floating can be disabled on it's own by
passing -fno-local-float-out-top-level.

```
x = let y = e in (a,b)
===>
y = e; x = (a,b)
```

Note that this is only about local floating, ie, floating two adjacent
lets past each other and doesn't say anything about the global floating
pass which is controlled by `-fno-float`.

Fixes #13663

11 files changed, 226 insertions, 8 deletions

diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 4753555221..11b1d2c7c2 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -13,6 +13,8 @@ module GHC.Core.Opt.Monad (
     CoreToDo(..), runWhen, runMaybe,
     SimplMode(..),
     FloatOutSwitches(..),
+    FloatEnable(..),
+    floatEnable,
     pprPassDetails,
 
     -- * Plugins
@@ -171,6 +173,49 @@ pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
                                             , ppr md ]
 pprPassDetails _ = Outputable.empty
 
+
+data FloatEnable  -- Controls local let-floating
+  = FloatDisabled      -- Do no local let-floating
+  | FloatNestedOnly    -- Local let-floating for nested (NotTopLevel) bindings only
+  | FloatEnabled       -- Do local let-floating on all bindings
+
+floatEnable :: DynFlags -> FloatEnable
+floatEnable dflags =
+  case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of
+    (True, True) -> FloatEnabled
+    (True, False)-> FloatNestedOnly
+    (False, _)   -> FloatDisabled
+
+{-
+Note [Local floating]
+~~~~~~~~~~~~~~~~~~~~~
+The Simplifier can perform local let-floating: it floats let-bindings
+out of the RHS of let-bindings.  See
+  Let-floating: moving bindings to give faster programs (ICFP'96)
+  https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/
+
+Here's an example
+   x = let y = v+1 in (y,true)
+
+The RHS of x is a thunk.  Much better to float that y-binding out to give
+   y = v+1
+   x = (y,true)
+
+Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in
+the scope of the x-binding can now be simplified.
+
+This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding,
+controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs.
+
+The `FloatEnable` data type controls where local let-floating takes place;
+it allows you to specify that it should be done only for nested bindings;
+or for top-level bindings as well; or not at all.
+
+Note that all of this is quite separate from the global FloatOut pass;
+see GHC.Core.Opt.FloatOut.
+
+-}
+
 data SimplMode             -- See comments in GHC.Core.Opt.Simplify.Monad
   = SimplMode
         { sm_names        :: [String]       -- ^ Name(s) of the phase
@@ -182,6 +227,7 @@ data SimplMode             -- See comments in GHC.Core.Opt.Simplify.Monad
         , sm_eta_expand   :: !Bool          -- ^ Whether eta-expansion is enabled
         , sm_cast_swizzle :: !Bool          -- ^ Do we swizzle casts past lambdas?
         , sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled
+        , sm_float_enable :: !FloatEnable   -- ^ Whether to enable floating out
         , sm_logger       :: !Logger
         , sm_dflags       :: DynFlags
             -- Just for convenient non-monadic access; we don't override these.
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 589441bffe..40b9536583 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -136,6 +136,7 @@ getCoreToDo logger dflags
     phases        = simplPhases        dflags
     max_iter      = maxSimplIterations dflags
     rule_check    = ruleCheck          dflags
+    float_enable  = floatEnable        dflags
     const_fold    = gopt Opt_CoreConstantFolding          dflags
     call_arity    = gopt Opt_CallArity                    dflags
     exitification = gopt Opt_Exitification                dflags
@@ -177,6 +178,7 @@ getCoreToDo logger dflags
                           , sm_inline       = True
                           , sm_case_case    = True
                           , sm_pre_inline   = pre_inline_on
+                          , sm_float_enable = float_enable
                           }
 
     simpl_phase phase name iter
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index b5dac4d385..1523394be9 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -722,7 +722,7 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs
 
        -- Finally, decide whether or not to float
        ; let all_floats = rhs_floats1 `addLetFloats` anf_floats
-       ; if doFloatFromRhs top_lvl is_rec strict_bind all_floats rhs2
+       ; if doFloatFromRhs (sm_float_enable $ seMode env) top_lvl is_rec strict_bind all_floats rhs2
          then -- Float!
               do { tick LetFloatFromLet
                  ; return (all_floats, rhs2) }
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 30afb9aac2..47927d5d7f 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -36,7 +36,7 @@ module GHC.Core.Opt.Simplify.Env (
         doFloatFromRhs, getTopFloatBinds,
 
         -- * LetFloats
-        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
+        LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,
         addLetFlts,  mapLetFloats,
 
         -- * JoinFloats
@@ -47,7 +47,7 @@ module GHC.Core.Opt.Simplify.Env (
 import GHC.Prelude
 
 import GHC.Core.Opt.Simplify.Monad
-import GHC.Core.Opt.Monad        ( SimplMode(..) )
+import GHC.Core.Opt.Monad        ( SimplMode(..), FloatEnable (..) )
 import GHC.Core
 import GHC.Core.Utils
 import GHC.Core.Multiplicity     ( scaleScaled )
@@ -506,10 +506,14 @@ andFF FltOkSpec  FltCareful = FltCareful
 andFF FltOkSpec  _          = FltOkSpec
 andFF FltLifted  flt        = flt
 
-doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
--- If you change this function look also at FloatIn.noFloatFromRhs
-doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
-  =  not (isNilOL fs) && want_to_float && can_float
+
+doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
+-- If you change this function look also at FloatIn.noFloatIntoRhs
+doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
+  = floatEnabled lvl fe
+      && not (isNilOL fs)
+      && want_to_float
+      && can_float
   where
      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
                      -- See Note [Float when cheap or expandable]
@@ -518,6 +522,12 @@ doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff
                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
                    FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind
 
+     -- Whether any floating is allowed by flags.
+     floatEnabled :: TopLevelFlag -> FloatEnable -> Bool
+     floatEnabled _ FloatDisabled = False
+     floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl)
+     floatEnabled _ FloatEnabled = True
+
 {-
 Note [Float when cheap or expandable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index f209713de7..3197b8024b 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -48,7 +48,7 @@ import GHC.Driver.Session
 import GHC.Core
 import GHC.Types.Literal ( isLitRubbish )
 import GHC.Core.Opt.Simplify.Env
-import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) )
+import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..), floatEnable )
 import qualified GHC.Core.Subst
 import GHC.Core.Ppr
 import GHC.Core.TyCo.Ppr ( pprParendType )
@@ -951,12 +951,14 @@ simplEnvForGHCi logger dflags
                            , sm_cast_swizzle = True
                            , sm_case_case  = True
                            , sm_pre_inline = pre_inline_on
+                           , sm_float_enable = float_enable
                            }
   where
     rules_on      = gopt Opt_EnableRewriteRules   dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
     pre_inline_on = gopt Opt_SimplPreInlining     dflags
     uf_opts       = unfoldingOpts                 dflags
+    float_enable  = floatEnable                   dflags
 
 updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
 updModeForStableUnfoldings unf_act current_mode
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 209e6d1776..bac257670c 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -187,6 +187,11 @@ data GeneralFlag
    | Opt_KillOneShot
    | Opt_FullLaziness
    | Opt_FloatIn
+   | Opt_LocalFloatOut -- ^ Enable floating out of let-bindings in the
+                      --   simplifier
+   | Opt_LocalFloatOutTopLevel -- ^ Enable floating out of let-bindings at the
+                               --   top level in the simplifier
+                               --   N.B. See Note [RHS Floating]
    | Opt_LateSpecialise
    | Opt_Specialise
    | Opt_SpecialiseAggressively
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 627b2c69b3..99a2c10bf6 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -733,6 +733,15 @@ data DynFlags = DynFlags {
   cfgWeights            :: Weights
 }
 
+{- Note [RHS Floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to
+  'doFloatFromRhs'; with this we can control floating out with GHC flags.
+
+  This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and
+  allows for experminentation.
+-}
+
 class HasDynFlags m where
     getDynFlags :: m DynFlags
 
@@ -3414,6 +3423,8 @@ fFlagsDeps = [
   flagSpec "full-laziness"                    Opt_FullLaziness,
   depFlagSpec' "fun-to-thunk"                 Opt_FunToThunk
       (useInstead "-f" "full-laziness"),
+  flagSpec "local-float-out"                  Opt_LocalFloatOut,
+  flagSpec "local-float-out-top-level"        Opt_LocalFloatOutTopLevel,
   flagSpec "gen-manifest"                     Opt_GenManifest,
   flagSpec "ghci-history"                     Opt_GhciHistory,
   flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,
@@ -3799,10 +3810,15 @@ defaultFlags settings
     ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
              -- The default -O0 options
 
+    -- Default floating flags (see Note [RHS Floating])
+    ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ]
+
+
     ++ default_PIC platform
 
     ++ validHoleFitDefaults
 
+
     where platform = sTargetPlatform settings
 
 -- | These are the default settings for the display and sorting of valid hole
diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst
index ab49f08ade..02f1fd50f6 100644
--- a/docs/users_guide/using-optimisation.rst
+++ b/docs/users_guide/using-optimisation.rst
@@ -743,6 +743,54 @@ by saying ``-fno-wombat``.
 
     Sets the maximal number of iterations for the simplifier.
 
+.. ghc-flag:: -flocal-float-out
+    :shortdesc: Enable local floating definitions out of let-binds.
+    :type: dynamic
+    :reverse: -fno-local-float-out
+    :category:
+
+    :default: on
+
+    Enable local floating of bindings from the RHS of a let(rec) in the
+    simplifier. For example ::
+
+        let x = let y = rhs_y in rhs_x in blah
+        ==>
+        let y = rhs_y in let x = rhs_x in blah
+
+    See the paper "Let-floating: moving bindings to give faster programs", Partain, Santos, and Peyton Jones; ICFP 1996.
+    https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/
+
+    .. note::
+      This is distinct from the global floating pass which can be disabled with
+      :ghc-flag:`-fno-full-laziness`.
+
+.. ghc-flag:: -flocal-float-out-top-level
+    :shortdesc: Enable local floating to float top-level bindings
+    :type: dynamic
+    :reverse: -fno-local-float-out-top-level
+    :category:
+
+    :default: on
+
+    Enable local floating of top-level bindings from the RHS of a let(rec) in
+    the simplifier. For example
+
+      x = let y = e in (a,b)
+      ===>
+      y = e; x = (a,b)
+
+
+    See the paper "Let-floating: moving bindings to give faster programs", Partain, Santos, and Peyton Jones; ICFP 1996.
+    https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/
+
+    Note that if :ghc-flag:`-fno-local-float-out` is set, that will take
+    precedence.
+
+    .. note::
+      This is distinct from the global floating pass which can be disabled with
+      :ghc-flag:`-fno-full-laziness`.
+
 .. ghc-flag:: -fmax-worker-args=⟨n⟩
     :shortdesc: *default: 10.* Maximum number of value arguments for a worker.
     :type: dynamic
diff --git a/testsuite/tests/simplCore/should_compile/T20895.hs b/testsuite/tests/simplCore/should_compile/T20895.hs
new file mode 100644
index 0000000000..a35cfc4c70
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20895.hs
@@ -0,0 +1,30 @@
+module Test where
+
+import Control.Applicative
+
+topEntity :: [((),())]
+topEntity = (,) <$> outport1 <*> outport2
+  where
+    (outport1, outResp1) = gpio (decodeReq 1 req)
+    (outport2, outResp2) = gpio (decodeReq 2 req)
+    ramResp              = ram  (decodeReq 0 req)
+
+    req = core $ (<|>) <$> ramResp <*> ((<|>) <$> outResp1 <*> outResp2)
+
+core :: [Maybe ()] -> [()]
+core = fmap (maybe () id)
+{-# NOINLINE core #-}
+
+ram :: [()] -> [Maybe ()]
+ram = fmap pure
+{-# NOINLINE ram #-}
+
+decodeReq :: Integer -> [()] -> [()]
+decodeReq 0 = fmap (const ())
+decodeReq 1 = id
+decodeReq _ = fmap id
+{-# NOINLINE decodeReq #-}
+
+gpio :: [()] -> ([()],[Maybe ()])
+gpio i = (i,pure <$> i)
+{-# NOINLINE gpio #-}
diff --git a/testsuite/tests/simplCore/should_compile/T20895.stderr b/testsuite/tests/simplCore/should_compile/T20895.stderr
new file mode 100644
index 0000000000..fb44e0f576
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20895.stderr
@@ -0,0 +1,56 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 110, types: 177, coercions: 0, joins: 0/3}
+
+$trModule = Module (TrNameS "main"#) (TrNameS "Test"#)
+
+gpio
+  = \ i_amK ->
+      (i_amK, <$> $fFunctor[] (pure $fApplicativeMaybe) i_amK)
+
+decodeReq
+  = \ ds_dY6 ->
+      case == $fEqInteger ds_dY6 (IS 0#) of {
+        False ->
+          case == $fEqInteger ds_dY6 (IS 1#) of {
+            False -> fmap $fFunctor[] id;
+            True -> id
+          };
+        True -> fmap $fFunctor[] (const ())
+      }
+
+ram = fmap $fFunctor[] (pure $fApplicativeMaybe)
+
+core = fmap $fFunctor[] (maybe () id)
+
+topEntity
+  = letrec {
+      ds_dYh = gpio (decodeReq (IS 1#) req_aWD);
+      ds1_dYi = gpio (decodeReq (IS 2#) req_aWD);
+      req_aWD
+        = $ core
+            (<*>
+               $fApplicative[]
+               (<$>
+                  $fFunctor[]
+                  (<|> $fAlternativeMaybe)
+                  (ram (decodeReq (IS 0#) req_aWD)))
+               (<*>
+                  $fApplicative[]
+                  (<$>
+                     $fFunctor[]
+                     (<|> $fAlternativeMaybe)
+                     (case ds_dYh of { (outport1_aWz, outResp1_X2) -> outResp1_X2 }))
+                  (case ds1_dYi of { (outport2_aWJ, outResp2_X2) ->
+                   outResp2_X2
+                   }))); } in
+    <*>
+      $fApplicative[]
+      (<$>
+         $fFunctor[]
+         (\ ds2_dYf ds3_dYg -> (ds2_dYf, ds3_dYg))
+         (case ds_dYh of { (outport1_aWz, outResp1_X2) -> outport1_aWz }))
+      (case ds1_dYi of { (outport2_aWJ, outResp2_X2) -> outport2_aWJ })
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index b9b1956f51..2ddbef16bb 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -385,6 +385,9 @@ test('T19790',  normal, compile, ['-O -ddump-rule-firings'])
 # which (before the fix) lost crucial dependencies
 test('T20820',  normal, compile, ['-O0'])
 
+# Verify that the letrec is still there
+test('T20895', [ grep_errmsg(r'\s*=\s*letrec') ], compile, ['-O0 -ddump-simpl -dsuppress-all -fno-local-float-out-top-level'])
+
 test('OpaqueNoAbsentArgWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('OpaqueNoCastWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('OpaqueNoRebox', normal, compile, ['-O -ddump-simpl -dsuppress-uniques'])