[Git][ghc/ghc][wip/refactor-demand] 2 commits: Accept more tests
Sebastian Graf
gitlab at gitlab.haskell.org
Fri Oct 30 14:45:33 UTC 2020
Sebastian Graf pushed to branch wip/refactor-demand at Glasgow Haskell Compiler / GHC
Commits:
6ae44ca2 by Sebastian Graf at 2020-10-30T15:39:53+01:00
Accept more tests
- - - - -
3d33a3e0 by Sebastian Graf at 2020-10-30T15:45:27+01:00
Smart constructor for product demands
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Types/Demand.hs
- testsuite/tests/simplCore/should_compile/EvalTest.stdout
- testsuite/tests/simplCore/should_compile/T13543.stderr
- testsuite/tests/simplCore/should_compile/T4908.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
- testsuite/tests/stranal/sigs/T5075.stderr
- testsuite/tests/stranal/sigs/UnsatFun.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -244,7 +244,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
-- Compute demand on the scrutinee
-- See Note [Demand on scrutinee of a product case]
- scrut_dmd = Prod id_dmds
+ scrut_dmd = mkProd id_dmds
(scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
res_ty = alt_ty3 `plusDmdType` toBothDmdArg scrut_ty
case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -12,7 +12,7 @@
-}
module GHC.Types.Demand (
- Card(..), Demand(..), CleanDemand(Prod), viewProd,
+ Card(..), Demand(..), CleanDemand(Prod), mkProd, viewProd,
oneifyDmd, oneifyCard,
absDmd, topDmd, botDmd, seqDmd,
lubCard, lubDmd, lubCleanDmd,
@@ -369,7 +369,7 @@ instance Show Card where
show C_01 = "1"
show C_0N = "U"
show C_11 = "S"
- show C_1N = "S"
+ show C_1N = "S*"
show C_10 = "B"
_botCard, topCard :: Card
@@ -480,7 +480,7 @@ data CleanDemand
deriving ( Eq, Show )
poly00, poly01, poly0N, poly11, poly1N, poly10 :: CleanDemand
-topCleanDmd, _botCleanDmd, seqCleanDmd :: CleanDemand
+topCleanDmd, botCleanDmd, seqCleanDmd :: CleanDemand
poly00 = Poly C_00
poly01 = Poly C_01
poly0N = Poly C_0N
@@ -488,7 +488,7 @@ poly11 = Poly C_11
poly1N = Poly C_1N
poly10 = Poly C_10
topCleanDmd = poly0N
-_botCleanDmd = poly10
+botCleanDmd = poly10
seqCleanDmd = poly00
polyDmd :: Card -> Demand
@@ -512,6 +512,16 @@ lazyApply1Dmd = C_01 :* Call C_01 topCleanDmd
-- but is lazy (might not be called at all)
lazyApply2Dmd = C_01 :* Call C_01 (Call C_01 topCleanDmd)
+-- | A smart constructor for 'Prod', applying rewrite rules along the semantic
+-- equalities @Prod [polyDmd n, ...] === polyDmd n@, simplifying to polymorphic
+-- demands when possible. Note that this degrades boxity information! E.g. a
+-- polymorphic demand will never unbox.
+mkProd :: [Demand] -> CleanDemand
+mkProd [] = botCleanDmd
+mkProd ds@(n:*cd : _)
+ | all (== polyDmd n) ds = cd
+ | otherwise = Prod ds
+
viewProd :: Arity -> CleanDemand -> Maybe [Demand]
viewProd n (Prod ds) | ds `lengthIs` n = Just ds
viewProd n (Poly card) = Just (replicate n (polyDmd card))
=====================================
testsuite/tests/simplCore/should_compile/EvalTest.stdout
=====================================
@@ -1 +1 @@
-rght [Dmd=<S,U>] :: AList a
+rght [Dmd=S*U] :: AList a
=====================================
testsuite/tests/simplCore/should_compile/T13543.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Strictness signatures ====================
Foo.$trModule:
-Foo.f: <S(SU)><U(U)><U(U)>
+Foo.f: <S(SU)><S(U)><S(U)>
Foo.g: <S(S(U),S(U))>
=====================================
testsuite/tests/simplCore/should_compile/T4908.stderr
=====================================
@@ -42,7 +42,7 @@ T4908.$trModule
Rec {
-- RHS size: {terms: 19, types: 5, coercions: 0, joins: 0/0}
T4908.f_$s$wf [Occ=LoopBreaker] :: Int -> Int# -> Int# -> Bool
-[GblId, Arity=3, Str=<L,A><L,1*U><S,1*U>, Unf=OtherCon []]
+[GblId, Arity=3, Str=<A><1U><SU>, Unf=OtherCon []]
T4908.f_$s$wf
= \ (sc :: Int) (sc1 :: Int#) (sc2 :: Int#) ->
case sc2 of ds {
@@ -59,7 +59,7 @@ end Rec }
T4908.$wf [InlPrag=[2]] :: Int# -> (Int, Int) -> Bool
[GblId,
Arity=2,
- Str=<S,1*U><L,1*U(A,1*U(1*U))>,
+ Str=<SU><1(A,1(1U))>,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}]
T4908.$wf
@@ -81,7 +81,7 @@ T4908.$wf
f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool
[GblId,
Arity=2,
- Str=<S(S),1*U(1*U)><L,1*U(A,1*U(1*U))>,
+ Str=<S(SU)><1(A,1(1U))>,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
=====================================
testsuite/tests/simplCore/should_compile/T7360.stderr
=====================================
@@ -8,7 +8,7 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
[GblId[DataConWrapper],
Arity=1,
Caf=NoCafRefs,
- Str=<SU>,
+ Str=<S*U>,
Cpr=m3,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
@@ -35,7 +35,7 @@ T7360.fun4 = fun1 T7360.Foo1
fun2 :: forall {a}. [a] -> ((), Int)
[GblId,
Arity=1,
- Str=<U>,
+ Str=<1U>,
Cpr=m1,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
=====================================
testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
=====================================
@@ -1,8 +1,8 @@
==================== Strictness signatures ====================
BottomFromInnerLambda.$trModule:
-BottomFromInnerLambda.expensive: <S(SU)>
-BottomFromInnerLambda.f: <S(SU)>
+BottomFromInnerLambda.expensive: <S(S*U)>
+BottomFromInnerLambda.f: <S(S*U)>
=====================================
testsuite/tests/stranal/sigs/T5075.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Strictness signatures ====================
T5075.$trModule:
-T5075.loop: <S(LLC(C(S))LLLLL),U(A,A,C(C1(U)),A,A,A,A,A)><L,U(A,A,C(C1(U)),A,A,A,C(U))><L,U>
+T5075.loop: <S*(A,A,S*CS*(C1(U)),A,A,A,A,A)><U(A,A,UCU(C1(U)),A,A,A,UCU(U))><U>
@@ -13,6 +13,6 @@ T5075.loop:
==================== Strictness signatures ====================
T5075.$trModule:
-T5075.loop: <S(LLC(C(S))LLLLL),1*U(A,A,C(C1(U)),A,A,A,A,A)><L,U(A,A,C(C1(U)),A,A,A,C(U))><L,U>
+T5075.loop: <S(A,A,S*CS*(C1(U)),A,A,A,A,A)><U(A,A,UCU(C1(U)),A,A,A,UCU(U))><U>
=====================================
testsuite/tests/stranal/sigs/UnsatFun.stderr
=====================================
@@ -1,13 +1,13 @@
==================== Strictness signatures ====================
UnsatFun.$trModule:
-UnsatFun.f: <B,1*U(U)><B,A>b
-UnsatFun.g: <B,1*U(U)>b
-UnsatFun.g': <L,1*U(U)>
-UnsatFun.g3: <L,U(U)>
-UnsatFun.h: <C(S),1*C1(U)>
-UnsatFun.h2: <S,1*U><L,1*C1(U)>
-UnsatFun.h3: <C(S),1*C1(U)>
+UnsatFun.f: <S(S*)><B>b
+UnsatFun.g: <S(S*)>b
+UnsatFun.g': <1(U)>
+UnsatFun.g3: <U(U)>
+UnsatFun.h: <SCS(U)>
+UnsatFun.h2: <SU><1C1(U)>
+UnsatFun.h3: <SCS(U)>
@@ -25,12 +25,12 @@ UnsatFun.h3: m1
==================== Strictness signatures ====================
UnsatFun.$trModule:
-UnsatFun.f: <B,1*U(U)><B,A>b
-UnsatFun.g: <B,1*U(U)>b
-UnsatFun.g': <L,1*U(U)>
-UnsatFun.g3: <L,U(U)>
-UnsatFun.h: <C(S),1*C1(U)>
-UnsatFun.h2: <S,1*U><L,1*C1(U)>
-UnsatFun.h3: <C(S),1*C1(U)>
+UnsatFun.f: <S(S*)><B>b
+UnsatFun.g: <S(S*)>b
+UnsatFun.g': <1(U)>
+UnsatFun.g3: <U(U)>
+UnsatFun.h: <SCS(U)>
+UnsatFun.h2: <SU><1C1(U)>
+UnsatFun.h3: <SCS(U)>
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c26e25e6e1cecdc636993bd2e33a9d36b966d936...3d33a3e02e2a22bd2c4d7d62cd41254ba1de2820
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c26e25e6e1cecdc636993bd2e33a9d36b966d936...3d33a3e02e2a22bd2c4d7d62cd41254ba1de2820
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201030/18fec693/attachment-0001.html>
More information about the ghc-commits
mailing list