DmdAnal: Implement Boxity Analysis (#19871)

This patch fixes some abundant reboxing of `DynFlags` in
`GHC.HsToCore.Match.Literal.warnAboutOverflowedLit` (which was the topic
of #19407) by introducing a Boxity analysis to GHC, done as part of demand
analysis. This allows to accurately capture ad-hoc unboxing decisions previously
made in worker/wrapper in demand analysis now, where the boxity info can
propagate through demand signatures.

See the new `Note [Boxity analysis]`. The actual fix for #19407 is described in
`Note [No lazy, Unboxed demand in demand signature]`, but
`Note [Finalising boxity for demand signature]` is probably a better entry-point.

To support the fix for #19407, I had to change (what was)
`Note [Add demands for strict constructors]` a bit
(now `Note [Unboxing evaluated arguments]`). In particular, we now take care of
it in `finaliseBoxity` (which is only called from demand analaysis) instead of
`wantToUnboxArg`.

I also had to resurrect `Note [Product demands for function body]` and rename
it to `Note [Unboxed demand on function bodies returning small products]` to
avoid huge regressions in `join004` and `join007`, thereby fixing #4267 again.
See the updated Note for details.

A nice side-effect is that the worker/wrapper transformation no longer needs to
look at strictness info and other bits such as `InsideInlineableFun` flags
(needed for `Note [Do not unbox class dictionaries]`) at all. It simply collects
boxity info from argument demands and interprets them with a severely simplified
`wantToUnboxArg`. All the smartness is in `finaliseBoxity`, which could be moved
to DmdAnal completely, if it wasn't for the call to `dubiousDataConInstArgTys`
which would be awkward to export.

I spent some time figuring out the reason for why `T16197` failed prior to my
amendments to `Note [Unboxing evaluated arguments]`. After having it figured
out, I minimised it a bit and added `T16197b`, which simply compares computed
strictness signatures and thus should be far simpler to eyeball.

The 12% ghc/alloc regression in T11545 is because of the additional `Boxity`
field in `Poly` and `Prod` that results in more allocation during `lubSubDmd`
and `plusSubDmd`. I made sure in the ticky profiles that the number of calls
to those functions stayed the same. We can bear such an increase here, as we
recently improved it by -68% (in b760c1f).
T18698* regress slightly because there is more unboxing of dictionaries
happening and that causes Lint (mostly) to allocate more.

Fixes #19871, #19407, #4267, #16859, #18907 and #13331.

Metric Increase:
    T11545
    T18698a
    T18698b

Metric Decrease:
    T12425
    T16577
    T18223
    T18282
    T4267
    T9961

5 files changed, 22 insertions, 28 deletions

diff --git a/testsuite/tests/cpranal/should_compile/T18109.hs b/testsuite/tests/cpranal/should_compile/T18109.hs
index 5c52a187c9..fb79c749a3 100644
--- a/testsuite/tests/cpranal/should_compile/T18109.hs
+++ b/testsuite/tests/cpranal/should_compile/T18109.hs
@@ -14,8 +14,8 @@ f n = F (+n)
 
 data T = T (Int, Int)
 
-g :: T -> T
-g t@(T p) = p `seq` t
+g :: (Int, Int) -> T
+g p = p `seq` T p
 {-# NOINLINE g #-}
 
 data U = U ![Int]
diff --git a/testsuite/tests/cpranal/should_compile/T18109.stderr b/testsuite/tests/cpranal/should_compile/T18109.stderr
index ad92bdda17..f547ac62d7 100644
--- a/testsuite/tests/cpranal/should_compile/T18109.stderr
+++ b/testsuite/tests/cpranal/should_compile/T18109.stderr
@@ -1,51 +1,51 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 78, types: 81, coercions: 0, joins: 0/1}
+Result size of Tidy Core = {terms: 75, types: 81, coercions: 0, joins: 0/1}
 
 -- RHS size: {terms: 6, types: 4, coercions: 0, joins: 0/0}
 T18109.$WU :: [Int] %1 -> U
-T18109.$WU = \ (dt_aDr :: [Int]) -> case dt_aDr of dt_X0 { __DEFAULT -> T18109.U dt_X0 }
+T18109.$WU = \ (conrep_aDI :: [Int]) -> case conrep_aDI of conrep_X0 { __DEFAULT -> T18109.U conrep_X0 }
 
 -- RHS size: {terms: 6, types: 12, coercions: 0, joins: 0/0}
 T18109.$wg :: (Int, Int) -> (# (Int, Int) #)
-T18109.$wg = \ (ww_sKr :: (Int, Int)) -> case ww_sKr of p_X2 { (ipv_sIU, ipv1_sIV) -> (# p_X2 #) }
+T18109.$wg = \ (p_sL1 :: (Int, Int)) -> case p_sL1 of p1_X0 { (ipv_sJr, ipv1_sJs) -> (# p1_X0 #) }
 
--- RHS size: {terms: 10, types: 13, coercions: 0, joins: 0/0}
-g :: T -> T
-g = \ (w_sKp :: T) -> case w_sKp of { T ww_sKr -> case T18109.$wg ww_sKr of { (# ww1_sKJ #) -> T18109.T ww1_sKJ } }
+-- RHS size: {terms: 7, types: 11, coercions: 0, joins: 0/0}
+g :: (Int, Int) -> T
+g = \ (p_sL1 :: (Int, Int)) -> case T18109.$wg p_sL1 of { (# ww_sLl #) -> T18109.T ww_sLl }
 
 -- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0}
 T18109.$wf :: Int -> (# Int -> Int #)
-T18109.$wf = \ (w_sKw :: Int) -> (# \ (v_B2 :: Int) -> GHC.Num.$fNumInt_$c+ v_B2 w_sKw #)
+T18109.$wf = \ (n_sL6 :: Int) -> (# \ (v_B2 :: Int) -> GHC.Num.$fNumInt_$c+ v_B2 n_sL6 #)
 
 -- RHS size: {terms: 7, types: 7, coercions: 0, joins: 0/0}
 f :: Int -> F
-f = \ (w_sKw :: Int) -> case T18109.$wf w_sKw of { (# ww_sKL #) -> T18109.F ww_sKL }
+f = \ (n_sL6 :: Int) -> case T18109.$wf n_sL6 of { (# ww_sLn #) -> T18109.F ww_sLn }
 
 -- RHS size: {terms: 26, types: 10, coercions: 0, joins: 0/1}
 T18109.$wh :: GHC.Prim.Int# -> [Int]
 T18109.$wh
-  = \ (ww_sKE :: GHC.Prim.Int#) ->
-      case GHC.Prim.># 0# ww_sKE of {
+  = \ (ww_sLg :: GHC.Prim.Int#) ->
+      case GHC.Prim.># 0# ww_sLg of {
         __DEFAULT ->
           letrec {
-            go3_aKm :: GHC.Prim.Int# -> [Int]
-            go3_aKm
-              = \ (x_aKn :: GHC.Prim.Int#) ->
+            go3_aKV :: GHC.Prim.Int# -> [Int]
+            go3_aKV
+              = \ (x_aKW :: GHC.Prim.Int#) ->
                   GHC.Types.:
                     @Int
-                    (GHC.Types.I# x_aKn)
-                    (case GHC.Prim.==# x_aKn ww_sKE of {
-                       __DEFAULT -> go3_aKm (GHC.Prim.+# x_aKn 1#);
+                    (GHC.Types.I# x_aKW)
+                    (case GHC.Prim.==# x_aKW ww_sLg of {
+                       __DEFAULT -> go3_aKV (GHC.Prim.+# x_aKW 1#);
                        1# -> GHC.Types.[] @Int
                      }); } in
-          go3_aKm 0#;
+          go3_aKV 0#;
         1# -> GHC.Types.[] @Int
       }
 
 -- RHS size: {terms: 10, types: 5, coercions: 0, joins: 0/0}
 h :: Int -> U
-h = \ (w_sKC :: Int) -> case w_sKC of { GHC.Types.I# ww_sKE -> case T18109.$wh ww_sKE of ww1_sKN { __DEFAULT -> T18109.U ww1_sKN } }
+h = \ (n_sLe :: Int) -> case n_sLe of { GHC.Types.I# ww_sLg -> case T18109.$wh ww_sLg of ww1_sLp { __DEFAULT -> T18109.U ww1_sLp } }
 
 
 
diff --git a/testsuite/tests/cpranal/sigs/T19398.hs b/testsuite/tests/cpranal/sigs/T19398.hs
index e0347fd502..d4d8f295d8 100644
--- a/testsuite/tests/cpranal/sigs/T19398.hs
+++ b/testsuite/tests/cpranal/sigs/T19398.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -fdmd-unbox-width=0 #-} -- otherwise we'll optimistically unbox the arg to c
 
 module T19398 where
 
@@ -24,9 +25,3 @@ a n
 -- 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
index faa335d399..d734b84c4b 100644
--- a/testsuite/tests/cpranal/sigs/T19398.stderr
+++ b/testsuite/tests/cpranal/sigs/T19398.stderr
@@ -3,6 +3,5 @@
 T19398.a:
 T19398.c:
 T19398.f: 1
-T19398.g: 1(1, 1)
 
 
diff --git a/testsuite/tests/cpranal/sigs/T19822.stderr b/testsuite/tests/cpranal/sigs/T19822.stderr
index 607e806e8c..8e4636d322 100644
--- a/testsuite/tests/cpranal/sigs/T19822.stderr
+++ b/testsuite/tests/cpranal/sigs/T19822.stderr
@@ -1,5 +1,5 @@
 
 ==================== Cpr signatures ====================
-T19822.singleton: 1(, 1)
+T19822.singleton: 1