Denest NonRecs in SpecConstr for more specialisation (#22277)wip/T22277

See Note [Denesting non-recursive let bindings].

Fixes #22277. It is also related to #14951 and #14844 in that it
fixes a very specific case of looking through a non-recursive let binding in
SpecConstr.

4 files changed, 177 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T14951.hs b/testsuite/tests/simplCore/should_compile/T14951.hs
new file mode 100644
index 0000000000..d426b2b567
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T14951.hs
@@ -0,0 +1,24 @@
+-- {-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+-- {-# OPTIONS_GHC -O2 -fforce-recomp #-}
+-- {-# LANGUAGE PatternSynonyms #-}
+-- {-# LANGUAGE BangPatterns #-}
+-- {-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module T14844Example (topLvl) where
+
+topLvl large = (bar1, bar2, foo)
+  where
+    foo :: Integer -> (a -> b -> Bool) -> (a,b) -> Bool
+    foo 0 _ _ = False
+    foo s f t = l s' t
+       where
+         l 0 t = False
+         l 1 t = case t of (x,y) -> f x y
+         l n (x,y) = l (n-1) (x,y)
+         s' = large s
+
+    bar1 :: Integer -> (a -> b -> Bool) -> a -> b -> Bool
+    bar1 s f x y = foo s f (x,y)
+
+    bar2 :: Integer ->  (a -> b -> Bool) -> a -> b -> Bool
+    bar2 s f x y = foo (s + 1) f (x,y)
diff --git a/testsuite/tests/simplCore/should_compile/T22277.hs b/testsuite/tests/simplCore/should_compile/T22277.hs
new file mode 100644
index 0000000000..16a990b0b4
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22277.hs
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+module T22277 where
+
+entry :: Int -> Int
+entry n = case n of
+  0 -> f n (13,24)
+  _ -> f n (n,n)
+  where
+    f :: Int -> (Int,Int) -> Int
+    f m x = g m x
+      where
+        exit m = (length $ reverse $ reverse $ reverse $ reverse $ [0..m]) + n
+        g n p | even n    = exit n
+              | n > 43    = g (n-1) p
+              | otherwise = fst p
diff --git a/testsuite/tests/simplCore/should_compile/T22277.stderr b/testsuite/tests/simplCore/should_compile/T22277.stderr
new file mode 100644
index 0000000000..6cf8471de5
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22277.stderr
@@ -0,0 +1,132 @@
+[1 of 1] Compiling T22277           ( T22277.hs, T22277.o )
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 110, types: 49, coercions: 0, joins: 3/4}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T22277.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.$trModule3 = GHC.Types.TrNameS T22277.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T22277.$trModule2 = "T22277"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.$trModule1 = GHC.Types.TrNameS T22277.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.$trModule
+  = GHC.Types.Module T22277.$trModule3 T22277.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.entry2 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.entry2 = GHC.Types.I# 13#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.entry1 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.entry1 = GHC.Types.I# 24#
+
+-- RHS size: {terms: 89, types: 40, coercions: 0, joins: 3/4}
+entry :: Int -> Int
+[GblId,
+ Arity=1,
+ Str=<1P(SL)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 403 0}]
+entry
+  = \ (n :: Int) ->
+      case n of wild { GHC.Types.I# ds ->
+      join {
+        $w$sexit [InlPrag=[2], Dmd=LC(S,!P(L))] :: GHC.Prim.Int# -> Int
+        [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>]
+        $w$sexit (ww [OS=OneShot] :: GHC.Prim.Int#)
+          = join {
+              $j [Dmd=1C(1,!P(L))] :: [Int] -> Int
+              [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, Unf=OtherCon []]
+              $j (arg [OS=OneShot] :: [Int])
+                = case GHC.List.$wlenAcc
+                         @Int
+                         (GHC.List.reverse1
+                            @Int
+                            (GHC.List.reverse1
+                               @Int
+                               (GHC.List.reverse1
+                                  @Int
+                                  (GHC.List.reverse1 @Int arg (GHC.Types.[] @Int))
+                                  (GHC.Types.[] @Int))
+                               (GHC.Types.[] @Int))
+                            (GHC.Types.[] @Int))
+                         0#
+                  of ww1
+                  { __DEFAULT ->
+                  GHC.Types.I# (GHC.Prim.+# ww1 ds)
+                  } } in
+            case GHC.Prim.># 0# ww of {
+              __DEFAULT ->
+                letrec {
+                  go3 [Occ=LoopBreaker, Dmd=SC(S,L)] :: GHC.Prim.Int# -> [Int]
+                  [LclId, Arity=1, Str=<L>, Unf=OtherCon []]
+                  go3
+                    = \ (x :: GHC.Prim.Int#) ->
+                        GHC.Types.:
+                          @Int
+                          (GHC.Types.I# x)
+                          (case GHC.Prim.==# x ww of {
+                             __DEFAULT -> go3 (GHC.Prim.+# x 1#);
+                             1# -> GHC.Types.[] @Int
+                           }); } in
+                jump $j (go3 0#);
+              1# -> jump $j (GHC.Types.[] @Int)
+            } } in
+      joinrec {
+        $s$wg [Occ=LoopBreaker, Dmd=SC(S,C(1,C(1,!P(L))))]
+          :: Int -> Int -> GHC.Prim.Int# -> Int
+        [LclId[JoinId(3)(Nothing)],
+         Arity=3,
+         Str=<ML><A><L>,
+         Unf=OtherCon []]
+        $s$wg (sc :: Int) (sc1 :: Int) (sc2 :: GHC.Prim.Int#)
+          = case GHC.Prim.remInt# sc2 2# of {
+              __DEFAULT ->
+                case GHC.Prim.># sc2 43# of {
+                  __DEFAULT -> sc;
+                  1# -> jump $s$wg sc sc1 (GHC.Prim.-# sc2 1#)
+                };
+              0# -> jump $w$sexit sc2
+            }; } in
+      case ds of ds1 {
+        __DEFAULT -> jump $s$wg wild wild ds1;
+        0# -> jump $s$wg T22277.entry2 T22277.entry1 0#
+      }
+      }
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 283c6cf1b0..15cd08d52e 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -273,6 +273,9 @@ test('T14152a', [extra_files(['T14152.hs']), pre_cmd('cp T14152.hs T14152a.hs'),
                 compile, ['-fno-exitification -ddump-simpl'])
 test('T13990', normal, compile, ['-dcore-lint -O'])
 test('T14650', normal, compile, ['-O2'])
+
+# SpecConstr should specialise `l` here:
+test('T14951', [expect_broken(14591), grep_errmsg(r'\$sl') ], compile, ['-O2 -dsuppress-uniques -ddump-simpl'])
 test('T14959', normal, compile, ['-O'])
 test('T14978',
      normal,
@@ -434,3 +437,5 @@ test('T21286',  normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
 test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O -dno-typeable-binds -dsuppress-uniques'])
 # One module, T22097.hs, has OPTIONS_GHC -ddump-simpl
 test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques'])
+# SpecConstr should be able to specialise `go` for the pair
+test('T22277', [grep_errmsg(r'\$s\$wgo') ], compile, ['-O2 -ddump-simpl -dsuppress-uniques'])