Demand: Simplify `CU(U)` to `U` (#19005)

Both sub-demands encode the same information.
This is a trivial change and already affects a few regression tests
(e.g. `T5075`), so no separate regression test is necessary.

6 files changed, 47 insertions, 35 deletions

diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 6eb3c895e2..854d8c586e 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -390,7 +390,7 @@ dmdAnal' env dmd (App fun arg)
     -- Crucially, coercions /are/ handled here, because they are
     -- value arguments (#10288)
     let
-        call_dmd          = mkCallDmd dmd
+        call_dmd          = mkCalledOnceDmd dmd
         (fun_ty, fun')    = dmdAnal env call_dmd fun
         (arg_dmd, res_ty) = splitDmdTy fun_ty
         (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
@@ -782,9 +782,9 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
             -- 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
+            = mkCalledOnceDmds rhs_arity let_dmd
             | otherwise
-            = mkCallDmds rhs_arity topSubDmd
+            = mkCalledOnceDmds rhs_arity topSubDmd
 
     (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs
     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index 46502fe126..3587618d4d 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -34,7 +34,7 @@ module GHC.Types.Demand (
     lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
     -- ** Other @Demand@ operations
     oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand,
-    peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,
+    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,
     addCaseBndrDmd,
     -- ** Extracting one-shot information
     argOneShots, argsOneShots, saturatedByOneShots,
@@ -267,9 +267,11 @@ data SubDemand
   -- with the specified cardinality at every level.
   -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'.
   --
-  -- @Poly n@ is semantically equivalent to @nP(n,n,...)@ or @Cn(Cn(..Cn(n)))@.
-  -- So @U === UP(U,U,...)@ and @U === CU(CU(..CU(U)))@,
-  --    @S === SP(S,S,...)@ and @S === CS(CS(..CS(S)))@, and so on.
+  -- @Poly n@ is semantically equivalent to @Prod [n :* Poly n, ...]@ or
+  -- @Call n (Poly n)@. 'mkCall' and 'mkProd' do these rewrites.
+  --
+  -- In Note [Demand notation]: @U === P(U,U,...)@ and @U === CU(U)@,
+  --                            @S === P(S,S,...)@ and @S === CS(S)@, and so on.
   --
   -- We only really use 'Poly' with 'C_10' (bottom), 'C_00' (absent),
   -- 'C_0N' (top) and sometimes 'C_1N', but it's simpler to treat it uniformly
@@ -278,7 +280,8 @@ data SubDemand
   -- ^ @Call n sd@ describes the evaluation context of @n@ function
   -- applications, where every individual result is evaluated according to @sd@.
   -- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative].
-  -- Used only for values of function type.
+  -- Used only for values of function type. Use the smart constructor 'mkCall'
+  -- whenever possible!
   | Prod ![Demand]
   -- ^ @Prod ds@ describes the evaluation context of a case scrutinisation
   -- on an expression of product type, where the product components are
@@ -306,7 +309,7 @@ polyDmd C_1N = C_1N :* poly1N
 polyDmd C_10 = C_10 :* poly10
 
 -- | A smart constructor for 'Prod', applying rewrite rules along the semantic
--- equalities @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'
+-- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'
 -- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a
 -- polymorphic demand will never unbox.
 mkProd :: [Demand] -> SubDemand
@@ -335,6 +338,13 @@ viewProd _ _                             = Nothing
 {-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation
                         -- for Arity. Otherwise, #18304 bites us.
 
+-- | A smart constructor for 'Call', applying rewrite rules along the semantic
+-- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's
+-- when possible.
+mkCall :: Card -> SubDemand -> SubDemand
+mkCall n cd@(Poly m) | n == m = cd
+mkCall n cd                   = Call n cd
+
 -- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as
 -- necessary.
 viewCall :: SubDemand -> Maybe (Card, SubDemand)
@@ -356,8 +366,9 @@ lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
 -- Handle Call
 lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))
   -- See Note [Call demands are relative]
-  | isAbs n2  = Call (lubCard n1 n2) (lubSubDmd d1 botSubDmd)
-  | otherwise = Call (lubCard n1 n2) (lubSubDmd d1        d2)
+  | isAbs n1  = mkCall (lubCard n1 n2) (lubSubDmd botSubDmd d2)
+  | isAbs n2  = mkCall (lubCard n1 n2) (lubSubDmd d1 botSubDmd)
+  | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1        d2)
 -- Handle Poly
 lubSubDmd (Poly n1)  (Poly n2) = Poly (lubCard n1 n2)
 -- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -377,8 +388,9 @@ plusSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
 -- Handle Call
 plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))
   -- See Note [Call demands are relative]
-  | isAbs n2  = Call (plusCard n1 n2) (lubSubDmd d1 botSubDmd)
-  | otherwise = Call (plusCard n1 n2) (lubSubDmd d1        d2)
+  | isAbs n1  = mkCall (plusCard n1 n2) (lubSubDmd botSubDmd d2)
+  | isAbs n2  = mkCall (plusCard n1 n2) (lubSubDmd d1 botSubDmd)
+  | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1        d2)
 -- Handle Poly
 plusSubDmd (Poly n1)  (Poly n2) = Poly (plusCard n1 n2)
 -- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -407,7 +419,7 @@ multSubDmd :: Card -> SubDemand -> SubDemand
 multSubDmd n sd
   | Just sd' <- multTrivial n seqSubDmd sd = sd'
 multSubDmd n (Poly n')    = Poly (multCard n n')
-multSubDmd n (Call n' sd) = Call (multCard n n') sd -- See Note [Call demands are relative]
+multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]
 multSubDmd n (Prod ds)    = Prod (map (multDmd n) ds)
 
 multDmd :: Card -> Demand -> Demand
@@ -457,22 +469,22 @@ evalDmd = C_1N :* topSubDmd
 -- | First argument of 'GHC.Exts.maskAsyncExceptions#': @SCS(U)@.
 -- Called exactly once.
 strictOnceApply1Dmd :: Demand
-strictOnceApply1Dmd = C_11 :* Call C_11 topSubDmd
+strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd
 
 -- | First argument of 'GHC.Exts.atomically#': @MCM(U)@.
 -- Called at least once, possibly many times.
 strictManyApply1Dmd :: Demand
-strictManyApply1Dmd = C_1N :* Call C_1N topSubDmd
+strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd
 
 -- | First argument of catch#: @1C1(U)@.
 -- Evaluates its arg lazily, but then applies it exactly once to one argument.
 lazyApply1Dmd :: Demand
-lazyApply1Dmd = C_01 :* Call C_01 topSubDmd
+lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd
 
 -- | Second argument of catch#: @1C1(CS(U))@.
 -- Calls its arg lazily, but then applies it exactly once to an additional argument.
 lazyApply2Dmd :: Demand
-lazyApply2Dmd = C_01 :* Call C_01 (Call C_11 topSubDmd)
+lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)
 
 -- | Make a 'Demand' evaluated at-most-once.
 oneifyDmd :: Demand -> Demand
@@ -512,12 +524,12 @@ strictifyDictDmd ty (n :* Prod ds)
 strictifyDictDmd _  dmd = dmd
 
 -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @CS(d)@.
-mkCallDmd :: SubDemand -> SubDemand
-mkCallDmd sd = Call C_11 sd
+mkCalledOnceDmd :: SubDemand -> SubDemand
+mkCalledOnceDmd sd = mkCall C_11 sd
 
--- | @mkCallDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.
-mkCallDmds :: Arity -> SubDemand -> SubDemand
-mkCallDmds arity sd = iterate mkCallDmd sd !! arity
+-- | @mkCalledOnceDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.
+mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand
+mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity
 
 -- | Peels one call level from the sub-demand, and also returns how many
 -- times we entered the lambda body.
@@ -669,7 +681,7 @@ This is needed even for non-product types, in case the case-binder
 is used but the components of the case alternative are not.
 
 Note [Don't optimise UP(U,U,...) to U]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 These two SubDemands:
    UP(U,U) (@Prod [topDmd, topDmd]@)   and   U (@topSubDmd@)
 are semantically equivalent, but we do not turn the former into
@@ -1615,8 +1627,8 @@ kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd
 
 kill_usage_sd :: KillFlags -> SubDemand -> SubDemand
 kill_usage_sd kfs (Call n sd)
-  | kf_called_once kfs      = Call (lubCard C_1N n) (kill_usage_sd kfs sd)
-  | otherwise               = Call n                (kill_usage_sd kfs sd)
+  | kf_called_once kfs      = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)
+  | otherwise               = mkCall n                (kill_usage_sd kfs sd)
 kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds)
 kill_usage_sd _   sd        = sd
 
@@ -1640,7 +1652,7 @@ trimToType (n :* sd) ts
   where
     go (Prod ds)   (TsProd tss)
       | equalLength ds tss    = Prod (zipWith trimToType ds tss)
-    go (Call n sd) (TsFun ts) = Call n (go sd ts)
+    go (Call n sd) (TsFun ts) = mkCall n (go sd ts)
     go sd@Poly{}   _          = sd
     go _           _          = topSubDmd
 
@@ -1804,7 +1816,7 @@ instance Binary SubDemand where
     h <- getByte bh
     case h of
       0 -> Poly <$> get bh
-      1 -> Call <$> get bh <*> get bh
+      1 -> mkCall <$> get bh <*> get bh
       2 -> Prod <$> get bh
       _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))
 
diff --git a/testsuite/tests/arityanal/should_compile/Arity11.stderr b/testsuite/tests/arityanal/should_compile/Arity11.stderr
index 77c790ae7b..154baf01fb 100644
--- a/testsuite/tests/arityanal/should_compile/Arity11.stderr
+++ b/testsuite/tests/arityanal/should_compile/Arity11.stderr
@@ -35,7 +35,7 @@ end Rec }
 
 -- RHS size: {terms: 52, types: 28, coercions: 0, joins: 0/5}
 F11.$wfib [InlPrag=[2]] :: forall {a} {p}. (a -> a -> Bool) -> (Num a, Num p) => a -> p
-[GblId, Arity=4, Str=<MCM(CS(U))><UP(A,UCU(CS(U)),A,A,A,A,UCU(U))><UP(UCU(CS(U)),A,A,A,A,A,1C1(U))><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}]
+[GblId, Arity=4, Str=<MCM(CS(U))><UP(A,UCU(CS(U)),A,A,A,A,U)><UP(UCU(CS(U)),A,A,A,A,A,1C1(U))><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}]
 F11.$wfib
   = \ (@a) (@p) (ww :: a -> a -> Bool) (w :: Num a) (w1 :: Num p) (w2 :: a) ->
       let {
@@ -73,7 +73,7 @@ F11.$wfib
 fib [InlPrag=[2]] :: forall {a} {p}. (Eq a, Num a, Num p) => a -> p
 [GblId,
  Arity=4,
- Str=<SP(MCM(CS(U)),A)><UP(A,UCU(CS(U)),A,A,A,A,UCU(U))><UP(UCU(CS(U)),A,A,A,A,A,UCU(U))><U>,
+ Str=<SP(MCM(CS(U)),A)><UP(A,UCU(CS(U)),A,A,A,A,U)><UP(UCU(CS(U)),A,A,A,A,A,U)><U>,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False)
          Tmpl= \ (@a) (@p) (w [Occ=Once1!] :: Eq a) (w1 [Occ=Once1] :: Num a) (w2 [Occ=Once1] :: Num p) (w3 [Occ=Once1] :: a) -> case w of { GHC.Classes.C:Eq ww1 [Occ=Once1] _ [Occ=Dead] -> F11.$wfib @a @p ww1 w1 w2 w3 }}]
 fib = \ (@a) (@p) (w :: Eq a) (w1 :: Num a) (w2 :: Num p) (w3 :: a) -> case w of { GHC.Classes.C:Eq ww1 ww2 -> F11.$wfib @a @p ww1 w1 w2 w3 }
diff --git a/testsuite/tests/arityanal/should_compile/Arity16.stderr b/testsuite/tests/arityanal/should_compile/Arity16.stderr
index 3f5b3462c6..5d3c83f9df 100644
--- a/testsuite/tests/arityanal/should_compile/Arity16.stderr
+++ b/testsuite/tests/arityanal/should_compile/Arity16.stderr
@@ -5,7 +5,7 @@ Result size of Tidy Core = {terms: 52, types: 87, coercions: 0, joins: 0/0}
 Rec {
 -- RHS size: {terms: 15, types: 17, coercions: 0, joins: 0/0}
 map2 [Occ=LoopBreaker] :: forall {t} {a}. (t -> a) -> [t] -> [a]
-[GblId, Arity=2, Str=<UCU(U)><SU>, Unf=OtherCon []]
+[GblId, Arity=2, Str=<U><SU>, Unf=OtherCon []]
 map2
   = \ (@t) (@a) (f :: t -> a) (ds :: [t]) ->
       case ds of {
diff --git a/testsuite/tests/stranal/should_compile/T18894.stderr b/testsuite/tests/stranal/should_compile/T18894.stderr
index e0efbe9272..ee2df2f667 100644
--- a/testsuite/tests/stranal/should_compile/T18894.stderr
+++ b/testsuite/tests/stranal/should_compile/T18894.stderr
@@ -288,7 +288,7 @@ lvl :: Int
 lvl = GHC.Types.I# 2#
 
 -- RHS size: {terms: 34, types: 21, coercions: 0, joins: 0/0}
-$wh2 [InlPrag=[2], Dmd=UCU(U)] :: GHC.Prim.Int# -> Int
+$wh2 [InlPrag=[2]] :: GHC.Prim.Int# -> Int
 [LclId,
  Arity=1,
  Str=<SU>,
@@ -367,7 +367,7 @@ lvl :: (Int, Int)
 lvl = case $wg1 2# of { (# ww, ww #) -> (ww, ww) }
 
 -- RHS size: {terms: 25, types: 18, coercions: 0, joins: 0/0}
-$wh1 [InlPrag=[2], Dmd=UCU(U)] :: GHC.Prim.Int# -> Int
+$wh1 [InlPrag=[2]] :: GHC.Prim.Int# -> Int
 [LclId,
  Arity=1,
  Str=<SU>,
diff --git a/testsuite/tests/stranal/sigs/T5075.stderr b/testsuite/tests/stranal/sigs/T5075.stderr
index 64a78d05ec..a918028c82 100644
--- a/testsuite/tests/stranal/sigs/T5075.stderr
+++ b/testsuite/tests/stranal/sigs/T5075.stderr
@@ -1,7 +1,7 @@
 
 ==================== Strictness signatures ====================
 T5075.$trModule:
-T5075.loop: <MP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,UCU(U))><U>
+T5075.loop: <MP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U>
 
 
 
@@ -13,6 +13,6 @@ T5075.loop:
 
 ==================== Strictness signatures ====================
 T5075.$trModule:
-T5075.loop: <SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,UCU(U))><U>
+T5075.loop: <SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U>