summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/Opt/DmdAnal.hs6
-rw-r--r--compiler/GHC/Types/Demand.hs62
-rw-r--r--testsuite/tests/arityanal/should_compile/Arity11.stderr4
-rw-r--r--testsuite/tests/arityanal/should_compile/Arity16.stderr2
-rw-r--r--testsuite/tests/stranal/should_compile/T18894.stderr4
-rw-r--r--testsuite/tests/stranal/sigs/T5075.stderr4
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>
View Lorry Controller Status