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

3 files changed, 89 insertions, 0 deletions

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'])