CprAnal: Activate Sum CPR for local bindingswip/T5075

We've had Sum CPR (#5075) for top-level bindings for a couple of years now.
That begs the question why we didn't also activate it for local bindings, and
the reasons for that are described in `Note [CPR for sum types]`. Only that it
didn't make sense! The Note said that Sum CPR would destroy let-no-escapes, but
that should be a non-issue since we have syntactic join points in Core now and
we don't WW for them (`Note [Don't w/w join points for CPR]`).

So I simply activated CPR for all bindings of sum type, thus fixing #5075 and
\#16570. NoFib approves:

```
--------------------------------------------------------------------------------
        Program         Allocs    Instrs
--------------------------------------------------------------------------------
  comp_lab_zift          -0.0%     +0.7%
          fluid          +1.7%     +0.7%
        reptile          +0.1%     +0.1%
--------------------------------------------------------------------------------
            Min          -0.0%     -0.2%
            Max          +1.7%     +0.7%
 Geometric Mean          +0.0%     +0.0%
```

There were quite a few metric decreases on the order of 1-4%, but T6048 seems to
regress significantly, by 26.1%. WW'ing for a `Just` constructor and the nested
data type meant additional Simplifier iterations and a 30% increase in term
sizes as well as a 200-300% in type sizes due to unboxed 9-tuples. There's not
much we can do about it, I'm afraid: We're just doing much more work there.

Metric Decrease:
    T12425
    T18698a
    T18698b
    T20049
    T9020
    WWRec
Metric Increase:
    T6048

3 files changed, 48 insertions, 74 deletions

diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index b01218d6d7..d3f6a248ce 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -25,14 +25,12 @@ import GHC.Core.DataCon
 import GHC.Core.FamInstEnv
 import GHC.Core.Multiplicity
 import GHC.Core.Opt.WorkWrap.Utils
-import GHC.Core.TyCon
 import GHC.Core.Type
-import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe )
+import GHC.Core.Utils
 import GHC.Core
 import GHC.Core.Seq
 
 import GHC.Data.Graph.UnVar -- for UnVarSet
-import GHC.Data.Maybe   ( isJust )
 
 import GHC.Utils.Outputable
 import GHC.Utils.Misc
@@ -193,12 +191,12 @@ cprAnalTopBind :: AnalEnv
 cprAnalTopBind env (NonRec id rhs)
   = (env', NonRec id' rhs')
   where
-    (id', rhs', env') = cprAnalBind TopLevel env id rhs
+    (id', rhs', env') = cprAnalBind env id rhs
 
 cprAnalTopBind env (Rec pairs)
   = (env', Rec pairs')
   where
-    (env', pairs') = cprFix TopLevel env pairs
+    (env', pairs') = cprFix env pairs
 
 --
 -- * Analysing expressions
@@ -256,13 +254,13 @@ cprAnal' env (Case scrut case_bndr ty alts)
 cprAnal' env (Let (NonRec id rhs) body)
   = (body_ty, Let (NonRec id' rhs') body')
   where
-    (id', rhs', env') = cprAnalBind NotTopLevel env id rhs
+    (id', rhs', env') = cprAnalBind env id rhs
     (body_ty, body')  = cprAnal env' body
 
 cprAnal' env (Let (Rec pairs) body)
   = body_ty `seq` (body_ty, Let (Rec pairs') body')
   where
-    (env', pairs')   = cprFix NotTopLevel env pairs
+    (env', pairs')   = cprFix env pairs
     (body_ty, body') = cprAnal env' body
 
 cprAnalAlt
@@ -395,11 +393,10 @@ mAX_CPR_SIZE = 10
 --
 
 -- Recursive bindings
-cprFix :: TopLevelFlag
-       -> AnalEnv                    -- Does not include bindings for this binding
+cprFix :: AnalEnv                    -- Does not include bindings for this binding
        -> [(Id,CoreExpr)]
        -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info
-cprFix top_lvl orig_env orig_pairs
+cprFix orig_env orig_pairs
   = loop 1 init_env init_pairs
   where
     init_sig id
@@ -432,17 +429,16 @@ cprFix top_lvl orig_env orig_pairs
       where
         go env (id, rhs) = (env', (id', rhs'))
           where
-            (id', rhs', env') = cprAnalBind top_lvl env id rhs
+            (id', rhs', env') = cprAnalBind env id rhs
 
 -- | Process the RHS of the binding for a sensible arity, add the CPR signature
 -- to the Id, and augment the environment with the signature as well.
 cprAnalBind
-  :: TopLevelFlag
-  -> AnalEnv
+  :: AnalEnv
   -> Id
   -> CoreExpr
   -> (Id, CoreExpr, AnalEnv)
-cprAnalBind top_lvl env id rhs
+cprAnalBind env id rhs
   | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.
   = (id,  rhs,  extendSigEnv env id topCprSig)
   -- See Note [CPR for data structures]
@@ -455,10 +451,8 @@ cprAnalBind top_lvl env id rhs
     -- possibly trim thunk CPR info
     rhs_ty'
       -- See Note [CPR for thunks]
-      | stays_thunk       = trimCprTy rhs_ty
-      -- See Note [CPR for sum types]
-      | returns_local_sum = trimCprTy rhs_ty
-      | otherwise         = rhs_ty
+      | stays_thunk = trimCprTy rhs_ty
+      | otherwise   = rhs_ty
     -- See Note [Arity trimming for CPR signatures]
     sig  = mkCprSigForArity (idArity id) rhs_ty'
     id'  = setIdCprSig id sig
@@ -468,14 +462,6 @@ cprAnalBind top_lvl env id rhs
     stays_thunk = is_thunk && not_strict
     is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)
     not_strict  = not (isStrUsedDmd (idDemandInfo id))
-    -- See Note [CPR for sum types]
-    (_, ret_ty) = splitPiTys (idType id)
-    returns_product
-      | Just (tc, _, _) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty
-      = isJust (tyConSingleAlgDataCon_maybe tc)
-      | otherwise
-      = False
-    returns_local_sum = not (isTopLevel top_lvl) && not returns_product
 
 isDataStructure :: Id -> Bool
 -- See Note [CPR for data structures]
@@ -751,44 +737,6 @@ Note that
 
   * See Note [CPR examples]
 
-Note [CPR for sum types]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Aug 21: This Note is out of date. It says that the subsequent WW split after
-CPR for sum types destroys join points, but that is no longer correct; we have
-the tools to track join points today and simply don't WW join points,
-see Note [Don't w/w join points for CPR].
-Yet the issue persists. It is tracked in #5075 and the ultimate reason is a bit
-unclear. All regressions involve CPR'ing functions returning lists, which are
-recursive data structures. If we don't CPR them
-(due to Note [CPR for recursive data constructors]), we might be able to finally
-remove this hack, after doing the proper perf checks.
-
-Historic Note:
-
-At the moment we do not do CPR for let-bindings that
-   * non-top level
-   * bind a sum type
-Reason: I found that in some benchmarks we were losing let-no-escapes,
-which messed it all up.  Example
-   let j = \x. ....
-   in case y of
-        True  -> j False
-        False -> j True
-If we w/w this we get
-   let j' = \x. ....
-   in case y of
-        True  -> case j' False of { (# a #) -> Just a }
-        False -> case j' True of { (# a #) -> Just a }
-Notice that j' is not a let-no-escape any more.
-
-However this means in turn that the *enclosing* function
-may be CPR'd (via the returned Justs).  But in the case of
-sums, there may be Nothing alternatives; and that messes
-up the sum-type CPR.
-
-Conclusion: only do this for products.  It's still not
-guaranteed OK for products, but sums definitely lose sometimes.
-
 Note [CPR for thunks]
 ~~~~~~~~~~~~~~~~~~~~~
 If the rhs is a thunk, we usually forget the CPR info, because
diff --git a/testsuite/tests/stranal/sigs/T5075.hs b/testsuite/tests/stranal/sigs/T5075.hs
index c35409aa67..15b1357446 100644
--- a/testsuite/tests/stranal/sigs/T5075.hs
+++ b/testsuite/tests/stranal/sigs/T5075.hs
@@ -1,11 +1,31 @@
--- | This module currently asserts that we trim CPR for local bindings
--- returning a sum. We can hopefully give @loop@ a CPR signature some day, but
--- we first have to fix #5075/#16570.
+-- | This module currently asserts that we give functions that always return
+-- the same constructor of a sum type the CPR property.
 module T5075 where
 
 -- Omission of the type signature is deliberate, otherwise we won't get a join
 -- point (this is up to the desugarer, not sure why).
--- loop :: (Ord a, Num a) => a -> Either a b
-loop x = case x < 10 of
-  True -> Left x
-  False -> loop (x*2)
+-- f :: (Ord a, Num a) => a -> Either a b
+f x = case x < 10 of
+  True  -> Left x
+  False -> f (x*2)
+
+-- Similarly a join point. Should WW nonetheless
+g :: Int -> Int -> Maybe Int
+g x y = go x
+  where
+    go x = case x < y of
+      True  -> Just x
+      False -> go (x*2)
+
+-- Here, go is not a join point, but still should be WW'd for Just.
+-- Unfortunately, CPR can't see that (+?) returns Just, so h won't get the CPR
+-- property. It probably could by only considering the @Just@ case of the
+-- inlined (+?).
+h :: Int -> Maybe Int
+h x = go x +? go (x+1)
+  where
+    Just x +? Just y = Just (x + y)
+    _      +? _      = Nothing
+    go z
+      | z > 10    = Just (x + z)
+      | otherwise = go (z*2)
diff --git a/testsuite/tests/stranal/sigs/T5075.stderr b/testsuite/tests/stranal/sigs/T5075.stderr
index e17d5e7c5c..c9625db721 100644
--- a/testsuite/tests/stranal/sigs/T5075.stderr
+++ b/testsuite/tests/stranal/sigs/T5075.stderr
@@ -1,18 +1,24 @@
 
 ==================== Strictness signatures ====================
 T5075.$trModule:
-T5075.loop: <SP(A,A,SCS(C1(L)),A,A,A,A,A)><LP(A,A,LCL(C1(L)),A,A,A,L)><L>
+T5075.f: <SP(A,A,SCS(C1(L)),A,A,A,A,A)><LP(A,A,LCL(C1(L)),A,A,A,L)><L>
+T5075.g: <1P(L)><SP(L)>
+T5075.h: <SP(L)>
 
 
 
 ==================== Cpr signatures ====================
 T5075.$trModule:
-T5075.loop:
+T5075.f: 1
+T5075.g: 2(1)
+T5075.h:
 
 
 
 ==================== Strictness signatures ====================
 T5075.$trModule:
-T5075.loop: <1P(A,A,SCS(C1(L)),A,A,A,A,A)><LP(A,A,LCL(C1(L)),A,A,A,L)><L>
+T5075.f: <1P(A,A,SCS(C1(L)),A,A,A,A,A)><LP(A,A,LCL(C1(L)),A,A,A,L)><L>
+T5075.g: <1P(L)><SP(L)>
+T5075.h: <1P(L)>