DmdAnal: Don't unbox recursive data types (#11545)wip/dmdanal-rec-datacon

As `Note [Demand analysis for recursive data constructors]` describes, we now
refrain from unboxing recursive data type arguments, for two reasons:

 1. Relating to run/alloc perf: Similar to
    `Note [CPR for recursive data constructors]`, it seldomly improves run/alloc
    performance if we just unbox a finite number of layers of a potentially huge
    data structure.
 2. Relating to ghc/alloc perf: Inductive definitions on single-product
    recursive data types like the one in T11545 will (diverge, and) have very
    deep demand signatures before any other abortion mechanism in Demand
    analysis is triggered. That leads to great and unnecessary churn on Demand
    analysis when ultimately we will never make use of any nested strictness
    information anyway.

Conclusion: Discard nested demand and boxity information on such recursive types
with the help of `Note [Detecting recursive data constructors]`.

I also implemented `GHC.Types.Unique.MemoFun.memoiseUniqueFun` in order to avoid
the overhead of repeated calls to `GHC.Core.Opt.WorkWrap.Utils.isRecDataCon`.
It's nice and simple and guards against some smaller regressions in T9233 and
T16577.

ghc/alloc performance-wise, this patch is a very clear win:

                               Test    Metric          value      New value Change
---------------------------------------------------------------------------------------
                LargeRecord(normal) ghc/alloc  6,141,071,720  6,099,871,216  -0.7%
MultiLayerModulesTH_OneShot(normal) ghc/alloc  2,740,973,040  2,705,146,640  -1.3%
                     T11545(normal) ghc/alloc    945,475,492     85,768,928 -90.9% GOOD
                     T13056(optasm) ghc/alloc    370,245,880    326,980,632 -11.7% GOOD
                     T18304(normal) ghc/alloc     90,933,944     76,998,064 -15.3% GOOD
                     T9872a(normal) ghc/alloc  1,800,576,840  1,792,348,760  -0.5%
                     T9872b(normal) ghc/alloc  2,086,492,432  2,073,991,848  -0.6%
                     T9872c(normal) ghc/alloc  1,750,491,240  1,737,797,832  -0.7%
       TcPlugin_RewritePerf(normal) ghc/alloc  2,286,813,400  2,270,957,896  -0.7%

                          geo. mean                                          -2.9%

No noteworthy change in run/alloc either.

NoFib results show slight wins, too:

--------------------------------------------------------------------------------
        Program         Allocs    Instrs
--------------------------------------------------------------------------------
    constraints          -1.9%     -1.4%
          fasta          -3.6%     -2.7%
reverse-complem          -0.3%     -0.9%
       treejoin          -0.0%     -0.3%
--------------------------------------------------------------------------------
            Min          -3.6%     -2.7%
            Max          +0.1%     +0.1%
 Geometric Mean          -0.1%     -0.1%

Metric Decrease:
    T11545
    T13056
    T18304

7 files changed, 108 insertions, 44 deletions

diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index 64551f9498..97cd36d15a 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -20,6 +20,7 @@ import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Demand
 import GHC.Types.Cpr
+import GHC.Types.Unique.MemoFun
 
 import GHC.Core.FamInstEnv
 import GHC.Core.DataCon
@@ -343,7 +344,7 @@ cprTransform env id args
   = fst $ cprAnalApp env rhs args
   -- DataCon worker
   | Just con <- isDataConWorkId_maybe id
-  = cprTransformDataConWork (ae_fam_envs env) con args
+  = cprTransformDataConWork env con args
   -- Imported function
   | otherwise
   = applyCprTy (getCprSig (idCprSig id)) (length args)
@@ -361,20 +362,17 @@ cprTransformBespoke id args
 -- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker,
 -- given a saturated number of 'CprType's for its field expressions.
 -- Implements the Nested part of Note [Nested CPR].
-cprTransformDataConWork :: FamInstEnvs -> DataCon -> [(CprType, CoreArg)] -> CprType
-cprTransformDataConWork fam_envs con args
+cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType
+cprTransformDataConWork env con args
   | null (dataConExTyCoVars con)  -- No existentials
   , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]
   , args `lengthIs` wkr_arity
-  , isRecDataCon fam_envs fuel con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]
+  , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]
   -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True
   = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))
   | otherwise
   = topCprType
   where
-    fuel = 3 -- If we can unbox more than 3 constructors to find a
-             -- recursive occurrence, then we can just as well unbox it
-             -- See Note [CPR for recursive data constructors], point (4)
     wkr_arity = dataConRepArity con
     wkr_str_marks = dataConRepStrictness con
     -- See Note [Nested CPR]
@@ -563,6 +561,8 @@ data AnalEnv
   -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal"
   , ae_fam_envs :: FamInstEnvs
   -- ^ Needed when expanding type families and synonyms of product types.
+  , ae_rec_dc :: DataCon -> IsRecDataConResult
+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
   }
 
 instance Outputable AnalEnv where
@@ -594,7 +594,11 @@ emptyAnalEnv fam_envs
   { ae_sigs = SE emptyUnVarSet emptyVarEnv
   , ae_virgin = True
   , ae_fam_envs = fam_envs
-  }
+  , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs fuel)
+  } where
+    fuel = 3 -- If we can unbox more than 3 constructors to find a
+             -- recursive occurrence, then we can just as well unbox it
+             -- See Note [CPR for recursive data constructors], point (4)
 
 modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
 modifySigEnv f env = env { ae_sigs = f (ae_sigs env) }
@@ -1022,6 +1026,7 @@ constructor's type constructor. A few perhaps surprising points:
      as when we run out of fuel. If there is ever a recursion through an
      abstract TyCon, then it's not part of the same function we are looking at,
      so we can treat it as if it wasn't recursive.
+     We handle stuck type and data families much the same.
 
 Here are a few examples of data constructors or data types with a single data
 con and the answers of our function:
@@ -1046,10 +1051,10 @@ con and the answers of our function:
       E Char = Blub
     data Blah = Blah (E (Int, (Int, Int)))     NonRec  (see point (5))
     data Blub = Blub (E (Char, Int))           Rec
-    data Blub2 = Blub2 (E (Bool, Int))     }   Rec, because stuck
+    data Blub2 = Blub2 (E (Bool, Int))     }   Unsure, because stuck (see point (7))
 
   { data T1 = T1 T2; data T2 = T2 T3;
-    ... data T5 = T5 T1                    }   Nothing (out of fuel)  (see point (4))
+    ... data T5 = T5 T1                    }   Unsure (out of fuel)  (see point (4))
 
   { module A where -- A.hs-boot
       data T
@@ -1057,7 +1062,7 @@ con and the answers of our function:
       import {-# SOURCE #-} A
       data U = MkU T
       f :: T -> U
-      f t = MkU t                              Nothing (T is abstract)  (see point (7))
+      f t = MkU t                              Unsure (T is abstract)  (see point (7))
     module A where -- A.hs
       import B
       data T = MkT U }
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 2dafaf8e0b..95d1954dfe 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -40,10 +40,11 @@ import GHC.Core.Opt.Arity ( typeArity )
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
-import GHC.Data.Maybe         ( isJust, orElse )
+import GHC.Data.Maybe
 import GHC.Builtin.PrimOps
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
 import GHC.Types.Unique.Set
+import GHC.Types.Unique.MemoFun
 
 import GHC.Utils.Trace
 _ = pprTrace -- Tired of commenting out the import all the time
@@ -428,8 +429,9 @@ dmdAnal' env dmd (Lam var body)
 
 dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
   -- Only one alternative.
-  -- If it's a DataAlt, it should be the only constructor of the type.
-  | is_single_data_alt alt
+  -- If it's a DataAlt, it should be the only constructor of the type and we
+  -- can consider its field demands when analysing the scrutinee.
+  | want_precise_field_dmds alt
   = let
         WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs
         WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs
@@ -454,10 +456,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
           -- __DEFAULT and literal alts. Simply add demands and discard the
           -- evaluation cardinality, as we evaluate the scrutinee exactly once.
           = assert (null bndrs) (bndrs, case_bndr_sd)
-        fam_envs                 = ae_fam_envs env
         alt_ty3
           -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
-          | exprMayThrowPreciseException fam_envs scrut
+          | exprMayThrowPreciseException (ae_fam_envs env) scrut
           = deferAfterPreciseException alt_ty2
           | otherwise
           = alt_ty2
@@ -474,8 +475,12 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])
 --                                   , text "res_ty" <+> ppr res_ty ]) $
     WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])
     where
-      is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc
-      is_single_data_alt _            = True
+      want_precise_field_dmds alt = case alt of
+        (DataAlt dc)
+          | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False
+          | DefinitelyRecursive <- ae_rec_dc env dc                  -> False
+              -- See Note [Demand analysis for recursive data constructors]
+        _                                                            -> True
 
 
 
@@ -689,12 +694,29 @@ to the Divergence lattice, but in practice it turned out to be hard to untaint
 from 'topDiv' to 'conDiv', leading to bugs, performance regressions and
 complexity that didn't justify the single fixed testcase T13380c.
 
+Note [Demand analysis for recursive data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+T11545 features a single-product, recursive data type
+  data A = A A A ... A
+    deriving Eq
+Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That
+leads to very large (exponential in the depth) demand signatures and fruitless
+churn in boxity analysis, demand analysis and worker/wrapper.
+So we detect `A` as a recursive data constructor
+(see Note [Detecting recursive data constructors]) analysing `case x of A ...`
+and simply assume L for the demand on field binders, which is the same code
+path as we take for sum types.
+Combined with the B demand on the case binder, we get the very small demand
+signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545
+tenfold! See also Note [CPR for recursive data constructors] which describes the
+sibling mechanism in CPR analysis.
+
 Note [Demand on the scrutinee of a product case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When figuring out the demand on the scrutinee of a product case,
 we use the demands of the case alternative, i.e. id_dmds.
 But note that these include the demand on the case binder;
-see Note [Demand on case-alternative binders] in GHC.Types.Demand.
+see Note [Demand on case-alternative binders].
 This is crucial. Example:
    f x = case x of y { (a,b) -> k y a }
 If we just take scrut_demand = 1P(L,A), then we won't pass x to the
@@ -1484,6 +1506,9 @@ finaliseArgBoxities env fn arity rhs
                      -- isStrict: see Note [No lazy, Unboxed demands in demand signature]
                      -- isMarkedStrict: see Note [Unboxing evaluated arguments]
                   , positiveTopBudget bg_inner'
+                  , NonRecursiveOrUnsure <- ae_rec_dc env dc
+                     -- See Note [Which types are unboxed?]
+                     -- and Note [Demand analysis for recursive data constructors]
                   = (bg_inner', dmd')
                   | otherwise
                   = (bg_inner, trimBoxity dmd)
@@ -1817,12 +1842,15 @@ demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
 
 
 data AnalEnv = AE
-   { ae_opts      :: !DmdAnalOpts -- ^ Analysis options
-   , ae_sigs      :: !SigEnv
-   , ae_virgin    :: !Bool -- ^ True on first iteration only
-                           -- See Note [Initialising strictness]
-   , ae_fam_envs  :: !FamInstEnvs
-   }
+  { ae_opts      :: !DmdAnalOpts
+  -- ^ Analysis options
+  , ae_sigs      :: !SigEnv
+  , ae_virgin    :: !Bool
+  -- ^ True on first iteration only. See Note [Initialising strictness]
+  , ae_fam_envs  :: !FamInstEnvs
+  , ae_rec_dc    :: DataCon -> IsRecDataConResult
+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
+  }
 
         -- We use the se_env to tell us whether to
         -- record info about a variable in the DmdEnv
@@ -1845,6 +1873,7 @@ emptyAnalEnv opts fam_envs
          , ae_sigs         = emptySigEnv
          , ae_virgin       = True
          , ae_fam_envs     = fam_envs
+         , ae_rec_dc       = memoiseUniqueFun (isRecDataCon fam_envs 3)
          }
 
 emptySigEnv :: SigEnv
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index c62ba572de..75e8c9e3c2 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -676,6 +676,7 @@ Worker/wrapper will unbox
 
   1. A strict data type argument, that
        * is an algebraic data type (not a newtype)
+       * is not recursive (as per 'isRecDataCon')
        * has a single constructor (thus is a "product")
        * that may bind existentials
      We can transform
@@ -687,6 +688,7 @@ Worker/wrapper will unbox
 
   2. The constructed result of a function, if
        * its type is an algebraic data type (not a newtype)
+       * is not recursive (as per 'isRecDataCon')
        * (might have multiple constructors, in contrast to (1))
        * the applied data constructor *does not* bind existentials
      We can transform
@@ -1244,15 +1246,17 @@ combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure
 
 -- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns
 --
---   * @Just Recursive@ if the analysis found that @tc@ is reachable through one
---     of @dc@'s fields
---   * @Just NonRecursive@ if the analysis found that @tc@ is not reachable
---     through one of @dc@'s fields
---   * @Nothing@ is returned in two cases. The first is when @fuel /= Infinity@
---     and @f@ expansions of nested data TyCons were not enough to prove
+--   * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable
+--     through one of @dc@'s @arg_tys@.
+--   * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable
+--     through one of @dc@'s fields (so surely non-recursive).
+--   * @NonRecursiveOrUnsure@ when @fuel /= Infinity@
+--     and @fuel@ expansions of nested data TyCons were not enough to prove
 --     non-recursivenss, nor arrive at an occurrence of @tc@ thus proving
---     recursiveness. The other is when we hit an abstract TyCon (one without
+--     recursiveness. (So not sure if non-recursive.)
+--   * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without
 --     visible DataCons), such as those imported from .hs-boot files.
+--     Similarly for stuck type and data families.
 --
 -- If @fuel = 'Infinity'@ and there are no boot files involved, then the result
 -- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int'
@@ -1266,16 +1270,16 @@ isRecDataCon fam_envs fuel dc
   | isTupleDataCon dc || isUnboxedSumDataCon dc
   = NonRecursiveOrUnsure
   | otherwise
-  = -- pprTrace "isRecDataCon" (ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer)
-    answer
+  = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $
+    go_dc fuel (setRecTcMaxBound 1 initRecTc) dc
   where
-    answer = go_dc fuel (setRecTcMaxBound 1 initRecTc) dc
+    _pp_dc_ty = ppr dc
     (<||>) = combineIRDCR
 
     go_dc :: IntWithInf -> RecTcChecker -> DataCon -> IsRecDataConResult
     go_dc fuel rec_tc dc =
-      combineIRDCRs [ go_arg_ty fuel rec_tc (scaledThing arg_ty)
-                    | arg_ty <- dataConRepArgTys dc ]
+      combineIRDCRs [ go_arg_ty fuel rec_tc arg_ty
+                    | arg_ty <- map scaledThing (dataConRepArgTys dc) ]
 
     go_arg_ty :: IntWithInf -> RecTcChecker -> Type -> IsRecDataConResult
     go_arg_ty fuel rec_tc ty
@@ -1304,9 +1308,6 @@ isRecDataCon fam_envs fuel dc
     go_tc_app fuel rec_tc tc tc_args
       --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined
 
-      | tc == dataConTyCon dc
-      = DefinitelyRecursive -- loop found!
-
       | isPrimTyCon tc
       = NonRecursiveOrUnsure
 
@@ -1320,8 +1321,14 @@ isRecDataCon fam_envs fuel dc
       -- This is the only place where we look at tc_args
       -- See Note [Detecting recursive data constructors], point (5)
       = case topReduceTyFamApp_maybe fam_envs tc tc_args of
-          Just (HetReduction (Reduction _ rhs) _) -> go_arg_ty fuel rec_tc rhs
-          Nothing                                 -> DefinitelyRecursive -- we hit this case for 'Any'
+          Just (HetReduction (Reduction _ rhs) _) ->
+            go_arg_ty fuel rec_tc rhs
+          Nothing ->
+            NonRecursiveOrUnsure -- NB: We simply give up here. Better return
+                                 -- Unsure, as for abstract TyCons, point (7)
+
+      | tc == dataConTyCon dc
+      = DefinitelyRecursive -- loop found!
 
       | otherwise
       = assertPpr (isAlgTyCon tc) (ppr tc <+> ppr dc) $
diff --git a/compiler/GHC/Types/Unique/MemoFun.hs b/compiler/GHC/Types/Unique/MemoFun.hs
new file mode 100644
index 0000000000..7ba912f415
--- /dev/null
+++ b/compiler/GHC/Types/Unique/MemoFun.hs
@@ -0,0 +1,21 @@
+module GHC.Types.Unique.MemoFun (memoiseUniqueFun) where
+
+import GHC.Prelude
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+
+import Data.IORef
+import System.IO.Unsafe
+
+memoiseUniqueFun :: Uniquable k => (k -> a) -> k -> a
+memoiseUniqueFun fun = unsafePerformIO $ do
+  ref <- newIORef emptyUFM
+  return $ \k -> unsafePerformIO $ do
+    m <- readIORef ref
+    case lookupUFM m k of
+      Just a  -> return a
+      Nothing -> do
+        let !a  = fun k
+            !m' = addToUFM m k a
+        writeIORef ref m'
+        return a
diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs
index c8b0bba3e5..cc5c69abb7 100644
--- a/compiler/GHC/Utils/Trace.hs
+++ b/compiler/GHC/Utils/Trace.hs
@@ -4,6 +4,7 @@ module GHC.Utils.Trace
   , pprTraceM
   , pprTraceDebug
   , pprTraceIt
+  , pprTraceWith
   , pprSTrace
   , pprTraceException
   , warnPprTrace
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 4ff65c4e61..3aff044b78 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -24,7 +24,7 @@ Category: Development
 Build-Type: Custom
 
 extra-source-files:
-    GHC/Builtin/primops.txt.pp 
+    GHC/Builtin/primops.txt.pp
     GHC/Builtin/bytearray-ops.txt.pp
     Unique.h
     CodeGen.Platform.h
@@ -707,6 +707,7 @@ Library
         GHC.Types.Unique.DSet
         GHC.Types.Unique.FM
         GHC.Types.Unique.Map
+        GHC.Types.Unique.MemoFun
         GHC.Types.Unique.SDFM
         GHC.Types.Unique.Set
         GHC.Types.Unique.Supply
diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr b/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr
index b330c78da0..9ec2ce7fb8 100644
--- a/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr
+++ b/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr
@@ -2,7 +2,7 @@
 ==================== Cpr signatures ====================
 RecDataConCPR.blah: 1(1(, 1))
 RecDataConCPR.blub:
-RecDataConCPR.blub2:
+RecDataConCPR.blub2: 1(1)
 RecDataConCPR.bootNonRec: 1
 RecDataConCPR.bootRec: 1
 RecDataConCPR.f: 1