Nested CPR light (#19398)

While fixing #19232, it became increasingly clear that the vestigial
hack described in `Note [Optimistic field binder CPR]` is complicated
and causes reboxing. Rather than make the hack worse, this patch
gets rid of it completely in favor of giving deeply unboxed parameters
the Nested CPR property. Example:
```hs
f :: (Int, Int) -> Int
f p = case p of
 (x, y) | x == y    = x
        | otherwise = y
```
Based on `p`'s `idDemandInfo` `1P(1P(L),1P(L))`, we can see that both
fields of `p` will be available unboxed. As a result, we give `p` the
nested CPR property `1(1,1)`. When analysing the `case`, the field
CPRs are transferred to the binders `x` and `y`, respectively, so that
we ultimately give `f` the CPR property.

I took the liberty to do a bit of refactoring:

- I renamed `CprResult` ("Constructed product result result") to plain
  `Cpr`.
- I Introduced `FlatConCpr` in addition to (now nested) `ConCpr` and
  and according pattern synonym that rewrites flat `ConCpr` to
  `FlatConCpr`s, purely for compiler perf reasons.
- Similarly for performance reasons, we now store binders with a
  Top signature in a separate `IntSet`,
  see `Note [Efficient Top sigs in SigEnv]`.
- I moved a bit of stuff around in `GHC.Core.Opt.WorkWrap.Utils` and
  introduced `UnboxingDecision` to replace the `Maybe DataConPatContext`
  type we used to return from `wantToUnbox`.
- Since the `Outputable Cpr` instance changed anyway, I removed the
  leading `m` which we used to emit for `ConCpr`. It's just noise,
  especially now that we may output nested CPRs.

Fixes #19398.

22 files changed, 70 insertions, 31 deletions

diff --git a/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
index 7f98fe0612..b837aeb8c5 100644
--- a/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
+++ b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
@@ -1,7 +1,6 @@
 
 ==================== Cpr signatures ====================
-CaseBinderCPR.$trModule:
 CaseBinderCPR.f_list_cmp:
-CaseBinderCPR.g: m1
+CaseBinderCPR.g: 1
 
 
diff --git a/testsuite/tests/cpranal/sigs/T19232.stderr b/testsuite/tests/cpranal/sigs/T19232.stderr
index 3aa701833b..59fa00d7e6 100644
--- a/testsuite/tests/cpranal/sigs/T19232.stderr
+++ b/testsuite/tests/cpranal/sigs/T19232.stderr
@@ -1,6 +1,5 @@
 
 ==================== Cpr signatures ====================
-T19232.$trModule:
 T19232.f:
 
 
diff --git a/testsuite/tests/cpranal/sigs/T19398.hs b/testsuite/tests/cpranal/sigs/T19398.hs
new file mode 100644
index 0000000000..e0347fd502
--- /dev/null
+++ b/testsuite/tests/cpranal/sigs/T19398.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE BangPatterns #-}
+
+module T19398 where
+
+data T a = MkT !a !a
+
+f :: T a -> T a
+f (MkT a b) = MkT b a
+{-# NOINLINE f #-}
+
+-- | Should *not* have the CPR property, even though the scrutinee is a
+-- variable with the CPR property. It shows how Test (A) of
+-- Historical Note [Optimistic field binder CPR] is unsound.
+a :: Int -> Int
+a n
+  | n == 0    = n
+  | even n    = case q of MkT x y -> if x == y then x else y
+  | otherwise = case q of MkT x y -> if x == y then y else x
+  where
+    q = f $ f $ f $ f $ f $ f $ f $ MkT n n
+
+-- | Should not have the CPR property, because 'x' will not be unboxed.
+-- It shows how Test (C) of Historical Note [Optimistic field binder CPR] is
+-- unsound.
+c :: (Int, Int) -> Int
+c (x,_) = x
+
+-- | An interesting artifact is that the following function has the Nested CPR
+-- property, and we could in theory exploit that:
+g :: (Int, Int) -> (Int, Int)
+g p@(!x, !y) | x == y = error "blah"
+g p                   = p
diff --git a/testsuite/tests/cpranal/sigs/T19398.stderr b/testsuite/tests/cpranal/sigs/T19398.stderr
new file mode 100644
index 0000000000..a293fdd089
--- /dev/null
+++ b/testsuite/tests/cpranal/sigs/T19398.stderr
@@ -0,0 +1,8 @@
+
+==================== Cpr signatures ====================
+T19398.a:
+T19398.c:
+T19398.f: 1
+T19398.g: 1
+
+
diff --git a/testsuite/tests/cpranal/sigs/all.T b/testsuite/tests/cpranal/sigs/all.T
index f5ac233a8c..0647c8a611 100644
--- a/testsuite/tests/cpranal/sigs/all.T
+++ b/testsuite/tests/cpranal/sigs/all.T
@@ -3,7 +3,8 @@
 setTestOpts(only_ways(['optasm']))
 # This directory contains tests where we annotate functions with expected
 # CPR signatures, and verify that these are actually those found by the compiler
-setTestOpts(extra_hc_opts('-ddump-cpr-signatures'))
+setTestOpts(extra_hc_opts('-dno-typeable-binds -ddump-cpr-signatures'))
 
 test('CaseBinderCPR', normal, compile, [''])
 test('T19232', normal, compile, [''])
+test('T19398', normal, compile, [''])
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 69f40310b4..8b3f8a53b6 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -7,7 +7,7 @@ Result size of Tidy Core
 T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a
 [GblId[DataConWrapper],
  Caf=NoCafRefs,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 889b8f48f8..ad3878e35a 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -44,7 +44,7 @@ dr :: Double -> Double
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -61,7 +61,7 @@ dl :: Double -> Double
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
@@ -72,7 +72,7 @@ fr :: Float -> Float
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -91,7 +91,7 @@ fl :: Float -> Float
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr
index ec423d7b4a..86094fe7d9 100644
--- a/testsuite/tests/simplCore/should_compile/T13143.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13143.stderr
@@ -90,7 +90,7 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int
 [GblId,
  Arity=3,
  Str=<1L><1L><1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/T13543.stderr b/testsuite/tests/simplCore/should_compile/T13543.stderr
index 32e34ea559..90bda9792f 100644
--- a/testsuite/tests/simplCore/should_compile/T13543.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13543.stderr
@@ -8,8 +8,8 @@ Foo.g: <1P(1P(L),1P(L))>
 
 ==================== Cpr signatures ====================
 Foo.$trModule:
-Foo.f: m1
-Foo.g: m1
+Foo.f: 1
+Foo.g: 1
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index 69b1766a84..f33b8ec401 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -57,7 +57,7 @@ foo [InlPrag=[2]] :: Int -> Int
 [GblId,
  Arity=1,
  Str=<1P(1L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 04e065f51c..66d257897e 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -57,7 +57,7 @@ foo [InlPrag=[2]] :: Int -> Int
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 0b45e8a390..fe869c7c40 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -9,7 +9,7 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
  Arity=1,
  Caf=NoCafRefs,
  Str=<SL>,
- Cpr=m3,
+ Cpr=3,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -36,7 +36,7 @@ fun2 :: forall {a}. [a] -> ((), Int)
 [GblId,
  Arity=1,
  Str=<ML>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 683ff4d6ac..319eba03cb 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -112,7 +112,7 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int
 [GblId,
  Arity=2,
  Str=<1L><1L>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
@@ -144,7 +144,7 @@ foo :: Int -> Int
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/stranal/should_compile/T10694.stderr b/testsuite/tests/stranal/should_compile/T10694.stderr
index 29b6e9e816..481c350fc2 100644
--- a/testsuite/tests/stranal/should_compile/T10694.stderr
+++ b/testsuite/tests/stranal/should_compile/T10694.stderr
@@ -30,7 +30,7 @@ pm [InlPrag=[final]] :: Int -> Int -> (Int, Int)
 [GblId,
  Arity=2,
  Str=<LP(L)><LP(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
          Tmpl= \ (w [Occ=Once1] :: Int) (w1 [Occ=Once1] :: Int) ->
diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
index 7b954564a7..c1fa7f22e6 100644
--- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
+++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
@@ -8,7 +8,7 @@ BottomFromInnerLambda.f: <1P(SL)>
 
 ==================== Cpr signatures ====================
 BottomFromInnerLambda.$trModule:
-BottomFromInnerLambda.expensive: m1
+BottomFromInnerLambda.expensive: 1
 BottomFromInnerLambda.f:
 
 
diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
index 8f70d7d5e0..4cbc565ee2 100644
--- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
+++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
@@ -20,10 +20,10 @@ DmdAnalGADTs.$tcD:
 DmdAnalGADTs.$trModule:
 DmdAnalGADTs.diverges: b
 DmdAnalGADTs.f:
-DmdAnalGADTs.f': m1
+DmdAnalGADTs.f': 1
 DmdAnalGADTs.g:
 DmdAnalGADTs.hasCPR:
-DmdAnalGADTs.hasStrSig: m1
+DmdAnalGADTs.hasStrSig: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
index e8a806e4ad..09829ae4fa 100644
--- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr
+++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
@@ -7,7 +7,7 @@ HyperStrUse.f: <1P(1P(L),A)><1L>
 
 ==================== Cpr signatures ====================
 HyperStrUse.$trModule:
-HyperStrUse.f: m1
+HyperStrUse.f: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/NewtypeArity.stderr b/testsuite/tests/stranal/sigs/NewtypeArity.stderr
index 5a73b53524..66a810f5a5 100644
--- a/testsuite/tests/stranal/sigs/NewtypeArity.stderr
+++ b/testsuite/tests/stranal/sigs/NewtypeArity.stderr
@@ -12,8 +12,8 @@ Test.t2: <1P(L)><1P(L)>
 Test.$tc'MkT:
 Test.$tcT:
 Test.$trModule:
-Test.t: m1
-Test.t2: m1
+Test.t: 1
+Test.t2: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/T12370.stderr b/testsuite/tests/stranal/sigs/T12370.stderr
index d557b437b1..ac5eb53888 100644
--- a/testsuite/tests/stranal/sigs/T12370.stderr
+++ b/testsuite/tests/stranal/sigs/T12370.stderr
@@ -8,8 +8,8 @@ T12370.foo: <1P(1P(L),1P(L))>
 
 ==================== Cpr signatures ====================
 T12370.$trModule:
-T12370.bar: m1
-T12370.foo: m1
+T12370.bar: 1
+T12370.foo: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/T18957.stderr b/testsuite/tests/stranal/sigs/T18957.stderr
index 2beea34dfb..6795bf0dab 100644
--- a/testsuite/tests/stranal/sigs/T18957.stderr
+++ b/testsuite/tests/stranal/sigs/T18957.stderr
@@ -14,7 +14,7 @@ T18957.$trModule:
 T18957.g:
 T18957.h1:
 T18957.h2:
-T18957.h3: m1
+T18957.h3: 1
 T18957.seq':
 
 
diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr
index 9f49534945..db7c97f807 100644
--- a/testsuite/tests/stranal/sigs/T8598.stderr
+++ b/testsuite/tests/stranal/sigs/T8598.stderr
@@ -7,7 +7,7 @@ T8598.fun: <1P(L)>
 
 ==================== Cpr signatures ====================
 T8598.$trModule:
-T8598.fun: m1
+T8598.fun: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr
index 691fe21c98..b3ccac6f6e 100644
--- a/testsuite/tests/stranal/sigs/UnsatFun.stderr
+++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr
@@ -16,10 +16,10 @@ UnsatFun.$trModule:
 UnsatFun.f: b
 UnsatFun.g:
 UnsatFun.g':
-UnsatFun.g3: m1
+UnsatFun.g3: 1
 UnsatFun.h:
 UnsatFun.h2:
-UnsatFun.h3: m1
+UnsatFun.h3: 1