Trim the demand for recursive product types

Ticket #18304 showed that we need to be very careful
when exploring the demand (esp usage demand) on recursive
product types.

This patch solves the problem by trimming the demand on such types --
in effect, a form of "widening".

See the Note [Trimming a demand to a type] in DmdAnal, which explains
how I did this by piggy-backing on an existing mechansim for trimming
demands becuase of GADTs.  The significant payload of this patch is
very small indeed:

* Make GHC.Core.Opt.WorkWrap.Utils.typeShape use RecTcChecker to
  avoid looking through recursive types.

But on the way

* I found that ae_rec_tc was entirely inoperative and did nothing.
  So I removed it altogether from DmdAnal.

* I moved some code around in DmdAnal and Demand.
  (There are no actual changes in dmdFix.)

* I changed the API of DmsAnal.dmdAnalRhsLetDown to return
  a StrictSig rather than a decorated Id

* I removed the dead function peelTsFuns from Demand

Performance effects:

Nofib: 0.0% changes.  Not surprising, because they don't
       use recursive products

Perf tests

T12227:
  1% increase in compiler allocation, becuase $cto gets w/w'd.
  It did not w/w before because it takes a deeply nested
  argument, so the worker gets too many args, so we abandon w/w
  altogether (see GHC.Core.Opt.WorkWrap.Utils.isWorkerSmallEnough)

  With this patch we trim the demands.  That is not strictly
  necessary (since these Generic type constructors are like
  tuples -- they can't cause a loop) but the net result is that
  we now w/w $cto which is fine.

UniqLoop:
  16% decrease in /runtime/ allocation. The UniqSupply is a
  recursive product, so currently we abandon all strictness on
  'churn'.  With this patch 'churn' gets useful strictness, and
  we w/w it.  Hooray

Metric Decrease:
    UniqLoop

Metric Increase:
    T12227

5 files changed, 303 insertions, 213 deletions

diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index c373b5cecb..29fa61a5fc 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -62,9 +62,10 @@ dmdAnalTopBind :: AnalEnv
                -> CoreBind
                -> (AnalEnv, CoreBind)
 dmdAnalTopBind env (NonRec id rhs)
-  = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs')
+  = ( extendAnalEnv TopLevel env id sig
+    , NonRec (setIdStrictness id sig) rhs')
   where
-    ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs
+    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs
 
 dmdAnalTopBind env (Rec pairs)
   = (env', Rec pairs')
@@ -216,10 +217,8 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
   -- Only one alternative with a product constructor
   | let tycon = dataConTyCon dc
   , isJust (isDataProductTyCon_maybe tycon)
-  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
   = let
-        env_alt                  = env { ae_rec_tc = rec_tc' }
-        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs
+        (rhs_ty, rhs')           = dmdAnal env dmd rhs
         (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
         (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
         id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
@@ -299,8 +298,9 @@ dmdAnal' env dmd (Let (NonRec id rhs) body)
 dmdAnal' env dmd (Let (NonRec id rhs) body)
   = (body_ty2, Let (NonRec id2 rhs') body')
   where
-    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs
-    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
+    (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs
+    id1                  = setIdStrictness id sig
+    env1                 = extendAnalEnv NotTopLevel env id sig
     (body_ty, body')     = dmdAnal env1 dmd body
     (body_ty1, id2)      = annotateBndr env body_ty id1
     body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
@@ -509,95 +509,11 @@ dmdTransform env var dmd
   = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $
     unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
 
-{-
-************************************************************************
+{- *********************************************************************
 *                                                                      *
-\subsection{Bindings}
+                      Binding right-hand sides
 *                                                                      *
-************************************************************************
--}
-
--- Recursive bindings
-dmdFix :: TopLevelFlag
-       -> AnalEnv                            -- Does not include bindings for this binding
-       -> CleanDemand
-       -> [(Id,CoreExpr)]
-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
-
-dmdFix top_lvl env let_dmd orig_pairs
-  = loop 1 initial_pairs
-  where
-    bndrs = map fst orig_pairs
-
-    -- See Note [Initialising strictness]
-    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
-                  | otherwise     = orig_pairs
-
-    -- If fixed-point iteration does not yield a result we use this instead
-    -- See Note [Safe abortion in the fixed-point iteration]
-    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
-    abort = (env, lazy_fv', zapped_pairs)
-      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
-            -- Note [Lazy and unleashable free variables]
-            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
-            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
-            zapped_pairs = zapIdStrictness pairs'
-
-    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
-    -- annotation does not change any more.
-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
-    loop n pairs
-      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
-      | n == 10        = abort
-      | otherwise      = loop (n+1) pairs'
-      where
-        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
-        first_round       = n == 1
-        (lazy_fv, pairs') = step first_round pairs
-        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
-
-    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
-    step first_round pairs = (lazy_fv, pairs')
-      where
-        -- In all but the first iteration, delete the virgin flag
-        start_env | first_round = env
-                  | otherwise   = nonVirgin env
-
-        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
-
-        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
-                -- mapAccumL: Use the new signature to do the next pair
-                -- The occurrence analyser has arranged them in a good order
-                -- so this can significantly reduce the number of iterations needed
-
-        my_downRhs (env, lazy_fv) (id,rhs)
-          = ((env', lazy_fv'), (id', rhs'))
-          where
-            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
-            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
-            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
-
-
-    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
-    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
-
-{-
-Note [Safe abortion in the fixed-point iteration]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Fixed-point iteration may fail to terminate. But we cannot simply give up and
-return the environment and code unchanged! We still need to do one additional
-round, for two reasons:
-
- * To get information on used free variables (both lazy and strict!)
-   (see Note [Lazy and unleashable free variables])
- * To ensure that all expressions have been traversed at least once, and any left-over
-   strictness annotations have been updated.
-
-This final iteration does not add the variables to the strictness signature
-environment, which effectively assigns them 'nopSig' (see "getStrictness")
-
--}
+********************************************************************* -}
 
 -- Let bindings can be processed in two ways:
 -- Down (RHS before body) or Up (body before RHS).
@@ -615,30 +531,26 @@ dmdAnalRhsLetDown
   :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
   -> AnalEnv -> CleanDemand
   -> Id -> CoreExpr
-  -> (DmdEnv, Id, CoreExpr)
+  -> (DmdEnv, StrictSig, CoreExpr)
 -- Process the RHS of the binding, add the strictness signature
 -- to the Id, and augment the environment with the signature as well.
+-- See Note [NOINLINE and strictness]
 dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-  = (lazy_fv, id', rhs')
+  = (lazy_fv, sig, rhs')
   where
-    rhs_arity      = idArity id
-    rhs_dmd
-      -- See Note [Demand analysis for join points]
-      -- See Note [Invariants on join points] invariant 2b, in GHC.Core
-      --     rhs_arity matches the join arity of the join point
-      | isJoinId id
-      = mkCallDmds rhs_arity let_dmd
-      | otherwise
-      -- NB: rhs_arity
-      -- See Note [Demand signatures are computed for a threshold demand based on idArity]
-      = mkRhsDmd env rhs_arity rhs
-    (DmdType rhs_fv rhs_dmds rhs_div, rhs')
-                   = dmdAnal env rhs_dmd rhs
-    sig            = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
-    id'            = -- pprTrace "dmdAnalRhsLetDown" (ppr id <+> ppr sig) $
-                     setIdStrictness id sig
-        -- See Note [NOINLINE and strictness]
-
+    rhs_arity = idArity id
+    rhs_dmd -- See Note [Demand analysis for join points]
+            -- See Note [Invariants on join points] invariant 2b, in GHC.Core
+            --     rhs_arity matches the join arity of the join point
+            | isJoinId id
+            = mkCallDmds rhs_arity let_dmd
+            | otherwise
+            -- NB: rhs_arity
+            -- See Note [Demand signatures are computed for a threshold demand based on idArity]
+            = mkRhsDmd env rhs_arity rhs
+
+    (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs
+    sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
 
     -- See Note [Aggregated demand for cardinality]
     rhs_fv1 = case rec_flag of
@@ -912,14 +824,152 @@ That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where
 behaviour -- see #17932.   Happily it turns out now to be entirely
 unnecessary: we get good results with C(C(C(S))).   So I simply
 deleted the special case.
+-}
 
-************************************************************************
+{- *********************************************************************
 *                                                                      *
-\subsection{Strictness signatures and types}
+                      Fixpoints
 *                                                                      *
-************************************************************************
+********************************************************************* -}
+
+-- Recursive bindings
+dmdFix :: TopLevelFlag
+       -> AnalEnv                            -- Does not include bindings for this binding
+       -> CleanDemand
+       -> [(Id,CoreExpr)]
+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
+
+dmdFix top_lvl env let_dmd orig_pairs
+  = loop 1 initial_pairs
+  where
+    bndrs = map fst orig_pairs
+
+    -- See Note [Initialising strictness]
+    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
+                  | otherwise     = orig_pairs
+
+    -- If fixed-point iteration does not yield a result we use this instead
+    -- See Note [Safe abortion in the fixed-point iteration]
+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    abort = (env, lazy_fv', zapped_pairs)
+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
+            -- Note [Lazy and unleashable free variables]
+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
+            zapped_pairs = zapIdStrictness pairs'
+
+    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
+    -- annotation does not change any more.
+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id)
+                   --                                     | (id,_)<- pairs]) $
+                   loop' n pairs
+
+    loop' n pairs
+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
+      | n == 10        = abort
+      | otherwise      = loop (n+1) pairs'
+      where
+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
+        first_round       = n == 1
+        (lazy_fv, pairs') = step first_round pairs
+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
+
+    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
+    step first_round pairs = (lazy_fv, pairs')
+      where
+        -- In all but the first iteration, delete the virgin flag
+        start_env | first_round = env
+                  | otherwise   = nonVirgin env
+
+        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
+
+        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
+                -- mapAccumL: Use the new signature to do the next pair
+                -- The occurrence analyser has arranged them in a good order
+                -- so this can significantly reduce the number of iterations needed
+
+        my_downRhs (env, lazy_fv) (id,rhs)
+          = ((env', lazy_fv'), (id', rhs'))
+          where
+            (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            env'                  = extendAnalEnv top_lvl env id sig
+            id'                   = setIdStrictness id sig
+
+    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
+
+{- Note [Safe abortion in the fixed-point iteration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Fixed-point iteration may fail to terminate. But we cannot simply give up and
+return the environment and code unchanged! We still need to do one additional
+round, for two reasons:
+
+ * To get information on used free variables (both lazy and strict!)
+   (see Note [Lazy and unleashable free variables])
+ * To ensure that all expressions have been traversed at least once, and any left-over
+   strictness annotations have been updated.
+
+This final iteration does not add the variables to the strictness signature
+environment, which effectively assigns them 'nopSig' (see "getStrictness")
+
+Note [Trimming a demand to a type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are two reasons we sometimes trim a demand to match a type.
+  1. GADTs
+  2. Recursive products and widening
+
+More on both below.  But the botttom line is: we really don't want to
+have a binder whose demand is more deeply-nested than its type
+"allows". So in findBndrDmd we call trimToType and findTypeShape to
+trim the demand on the binder to a form that matches the type
+
+Now to the reasons. For (1) consider
+  f :: a -> Bool
+  f x = case ... of
+          A g1 -> case (x |> g1) of (p,q) -> ...
+          B    -> error "urk"
+
+where A,B are the constructors of a GADT.  We'll get a U(U,U) demand
+on x from the A branch, but that's a stupid demand for x itself, which
+has type 'a'. Indeed we get ASSERTs going off (notably in
+splitUseProdDmd, #8569).
+
+For (2) consider
+  data T = MkT Int T    -- A recursive product
+  f :: Int -> T -> Int
+  f 0 _         = 0
+  f _ (MkT n t) = f n t
+
+Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))).
+Notice that this happens becuase T is a product type, and is recrusive.
+If we are not careful, we'll fail to iterate to a fixpoint in dmdFix,
+and bale out entirely, which is inefficient and over-conservative.
+
+Worse, as we discovered in #18304, the size of the usages we compute
+can grow /exponentially/, so even 10 iterations costs far too much.
+Especially since we then discard the result.
+
+To avoid this we use the same findTypeShape function as for (1), but
+arrange that it trims the demand if it encounters the same type constructor
+twice (or three times, etc).  We use our standard RecTcChecker mechanism
+for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape.
+
+This is usually call "widening".  We could do it just in dmdFix, but
+since are doing this findTypeShape business /anyway/ because of (1),
+and it has all the right information to hand, it's extremely
+convenient to do it there.
+
 -}
 
+{- *********************************************************************
+*                                                                      *
+                 Strictness signatures and types
+*                                                                      *
+********************************************************************* -}
+
 unitDmdType :: DmdEnv -> DmdType
 unitDmdType dmd_env = DmdType dmd_env [] topDiv
 
@@ -1133,7 +1183,6 @@ data AnalEnv
        , ae_sigs   :: SigEnv
        , ae_virgin :: Bool    -- True on first iteration only
                               -- See Note [Initialising strictness]
-       , ae_rec_tc :: RecTcChecker
        , ae_fam_envs :: FamInstEnvs
  }
 
@@ -1157,7 +1206,6 @@ emptyAnalEnv dflags fam_envs
     = AE { ae_dflags = dflags
          , ae_sigs = emptySigEnv
          , ae_virgin = True
-         , ae_rec_tc = initRecTc
          , ae_fam_envs = fam_envs
          }
 
@@ -1199,7 +1247,7 @@ findBndrsDmds env dmd_ty bndrs
       | otherwise = go dmd_ty bs
 
 findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
--- See Note [Trimming a demand to a type] in GHC.Types.Demand
+-- See Note [Trimming a demand to a type]
 findBndrDmd env arg_of_dfun dmd_ty id
   = (dmd_ty', dmd')
   where
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 8be03f30c5..4c4a5ced8a 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -231,7 +231,7 @@ A simplified example is #11565#comment:6
 
 Current strategy is very simple: don't perform w/w transformation at all
 if the result produces a wrapper with arity higher than -fmax-worker-args
-and the number arguments before w/w.
+and the number arguments before w/w (see #18122).
 
 It is a bit all or nothing, consider
 
@@ -248,6 +248,7 @@ solve f. But we can get a lot of args from deeply-nested products:
 This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
 given some "fuel" saying how many arguments it could add; when we ran
 out of fuel it would stop w/wing.
+
 Still not very clever because it had a left-right bias.
 
 ************************************************************************
@@ -998,23 +999,35 @@ deepSplitCprType_maybe _ _ _ = Nothing
 findTypeShape :: FamInstEnvs -> Type -> TypeShape
 -- Uncover the arrow and product shape of a type
 -- The data type TypeShape is defined in GHC.Types.Demand
--- See Note [Trimming a demand to a type] in GHC.Types.Demand
+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
 findTypeShape fam_envs ty
-  | Just (tc, tc_args)  <- splitTyConApp_maybe ty
-  , Just con <- isDataProductTyCon_maybe tc
-  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)
-
-  | Just (_, res) <- splitFunTy_maybe ty
-  = TsFun (findTypeShape fam_envs res)
-
-  | Just (_, ty') <- splitForAllTy_maybe ty
-  = findTypeShape fam_envs ty'
-
-  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
-  = findTypeShape fam_envs ty'
-
-  | otherwise
-  = TsUnk
+  = go (setRecTcMaxBound 2 initRecTc) ty
+       -- You might think this bound of 2 is low, but actually
+       -- I think even 1 would be fine.  This only bites for recursive
+       -- product types, which are rare, and we really don't want
+       -- to look deep into such products -- see #18034
+  where
+    go rec_tc ty
+       | Just (_, res) <- splitFunTy_maybe ty
+       = TsFun (go rec_tc res)
+
+       | Just (tc, tc_args)  <- splitTyConApp_maybe ty
+       , Just con <- isDataProductTyCon_maybe tc
+       , Just rec_tc <- if isTupleTyCon tc
+                        then Just rec_tc
+                        else checkRecTc rec_tc tc
+         -- We treat tuples specially because they can't cause loops.
+         -- Maybe we should do so in checkRecTc.
+       = TsProd (map (go rec_tc) (dataConInstArgTys con tc_args))
+
+       | Just (_, ty') <- splitForAllTy_maybe ty
+       = go rec_tc ty'
+
+       | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
+       = go rec_tc ty'
+
+       | otherwise
+       = TsUnk
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index fe3c30e311..077d6d913e 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -46,7 +46,7 @@ module GHC.Types.Demand (
         splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,
         mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig,
         dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots,
-        TypeShape(..), peelTsFuns, trimToType,
+        TypeShape(..), trimToType,
 
         useCount, isUsedOnce, reuseEnv,
         zapUsageDemand, zapUsageEnvSig,
@@ -809,24 +809,34 @@ data StrictPair a b = !a :*: !b
 strictPairToTuple :: StrictPair a b -> (a, b)
 strictPairToTuple (x :*: y) = (x, y)
 
-data TypeShape = TsFun TypeShape
-               | TsProd [TypeShape]
-               | TsUnk
+splitProdDmd_maybe :: Demand -> Maybe [Demand]
+-- Split a product into its components, iff there is any
+-- useful information to be extracted thereby
+-- The demand is not necessarily strict!
+splitProdDmd_maybe (JD { sd = s, ud = u })
+  = case (s,u) of
+      (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u
+                                -> Just (mkJointDmds sx ux)
+      (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
+                                -> Just (mkJointDmds sx ux)
+      (Lazy,  Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
+      _ -> Nothing
+
+{- *********************************************************************
+*                                                                      *
+               TypeShape and demand trimming
+*                                                                      *
+********************************************************************* -}
 
-instance Outputable TypeShape where
-  ppr TsUnk        = text "TsUnk"
-  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)
-  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)
 
--- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and
--- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise.
-peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape
-peelTsFuns 0 ts         = Just ts
-peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts
-peelTsFuns _ _          = Nothing
+data TypeShape -- See Note [Trimming a demand to a type]
+               --     in GHC.Core.Opt.DmdAnal
+  = TsFun TypeShape
+  | TsProd [TypeShape]
+  | TsUnk
 
 trimToType :: Demand -> TypeShape -> Demand
--- See Note [Trimming a demand to a type]
+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
 trimToType (JD { sd = ms, ud = mu }) ts
   = JD (go_ms ms ts) (go_mu mu ts)
   where
@@ -852,72 +862,18 @@ trimToType (JD { sd = ms, ud = mu }) ts
       | equalLength mus tss      = UProd (zipWith go_mu mus tss)
     go_u _           _           = Used
 
-{-
-Note [Trimming a demand to a type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-
-  f :: a -> Bool
-  f x = case ... of
-          A g1 -> case (x |> g1) of (p,q) -> ...
-          B    -> error "urk"
-
-where A,B are the constructors of a GADT.  We'll get a U(U,U) demand
-on x from the A branch, but that's a stupid demand for x itself, which
-has type 'a'. Indeed we get ASSERTs going off (notably in
-splitUseProdDmd, #8569).
-
-Bottom line: we really don't want to have a binder whose demand is more
-deeply-nested than its type.  There are various ways to tackle this.
-When processing (x |> g1), we could "trim" the incoming demand U(U,U)
-to match x's type.  But I'm currently doing so just at the moment when
-we pin a demand on a binder, in GHC.Core.Opt.DmdAnal.findBndrDmd.
-
-
-Note [Threshold demands]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Threshold usage demand is generated to figure out if
-cardinality-instrumented demands of a binding's free variables should
-be unleashed. See also [Aggregated demand for cardinality].
-
-Note [Replicating polymorphic demands]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Some demands can be considered as polymorphic. Generally, it is
-applicable to such beasts as tops, bottoms as well as Head-Used and
-Head-stricts demands. For instance,
-
-S ~ S(L, ..., L)
-
-Also, when top or bottom is occurred as a result demand, it in fact
-can be expanded to saturate a callee's arity.
--}
+instance Outputable TypeShape where
+  ppr TsUnk        = text "TsUnk"
+  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)
+  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)
 
-splitProdDmd_maybe :: Demand -> Maybe [Demand]
--- Split a product into its components, iff there is any
--- useful information to be extracted thereby
--- The demand is not necessarily strict!
-splitProdDmd_maybe (JD { sd = s, ud = u })
-  = case (s,u) of
-      (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u
-                                -> Just (mkJointDmds sx ux)
-      (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
-                                -> Just (mkJointDmds sx ux)
-      (Lazy,  Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
-      _ -> Nothing
 
-{-
-************************************************************************
+
+{- *********************************************************************
 *                                                                      *
                    Termination
 *                                                                      *
-************************************************************************
-
-Divergence:     Dunno
-               /
-          Diverges
-
-In a fixpoint iteration, start from Diverges
--}
+********************************************************************* -}
 
 -- | Divergence lattice. Models a subset lattice of the following exhaustive
 -- set of divergence results:
diff --git a/testsuite/tests/perf/compiler/T18304.hs b/testsuite/tests/perf/compiler/T18304.hs
new file mode 100644
index 0000000000..5902f52355
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T18304.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE RecordWildCards, PatternGuards #-}
+{-# OPTIONS_GHC -Wunused-binds #-}
+
+module Text.HTML.TagSoup.Specification
+    (dat, Out(..) )
+where
+
+-- Code taken from the tagsoup library, which is BSD-3-licensed.
+
+import Data.Char (isAlpha, isAlphaNum, isDigit, toLower)
+
+data TypeTag = TypeNormal -- <foo
+             | TypeXml    -- <?foo
+             | TypeDecl   -- <!foo
+             | TypeScript -- <script
+               deriving Eq
+
+
+type Parser = S -> [Out]
+
+-- 8.2.4.1 Data state
+dat :: S -> [Out]
+dat S{..} = tagName TypeXml tl
+
+-- 8.2.4.5 Tag name state
+tagName :: TypeTag -> S -> [Out]
+tagName typ S{..} = case hd of
+    'a' -> beforeAttName typ tl
+
+-- 8.2.4.6 Before attribute name state
+beforeAttName :: TypeTag -> S -> [Out]
+beforeAttName typ S{..} = case hd of
+    _ | hd `elem` "=" -> beforeAttValue typ s -- NEIL
+
+-- 8.2.4.9 Before attribute value state
+beforeAttValue :: TypeTag -> S -> [Out]
+beforeAttValue typ S{..} = case hd of
+    'a' -> beforeAttValue typ tl
+    '&' -> attValueUnquoted typ s
+
+-- 8.2.4.12 Attribute value (unquoted) state
+attValueUnquoted :: TypeTag -> Parser
+attValueUnquoted typ S{..} = case hd of
+    '?' -> neilXmlTagClose tl
+    'a' -> beforeAttName typ tl
+    'b' -> attValueUnquoted typ tl
+
+-- seen "?", expecting ">"
+neilXmlTagClose :: S -> [Out]
+neilXmlTagClose S{..} = case hd of
+    '>' -> dat tl
+    _ -> beforeAttName TypeXml s
+
+-----
+-- Text.HTML.TagSoup.Implementation
+-----
+
+data Out = SomeOut
+
+
+data S = S
+    { s :: S
+    , tl :: S
+    ,hd :: Char
+    ,eof :: Bool
+    }
+
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 912a172c85..611d8b4390 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -358,3 +358,9 @@ test('T16190',
       ['T16190.hs', '-v0'])
 
 test('T16473', normal, makefile_test, ['T16473'])
+
+test ('T18304',
+      [ collect_compiler_stats('bytes allocated',2)
+      ],
+      compile,
+      ['-v0 -O'])