diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-07-23 23:57:01 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-05-30 13:44:14 -0400 |
| commit | 6656f0165a30fc2a22208532ba384fc8e2f11b46 (patch) | |
| tree | ab6d5ec67947168dd86cf0b86b088fd7d91741e4 /testsuite/tests/simplCore | |
| parent | 0079171bae7271dc44f81c3bf26505941ee92d7e (diff) | |
| download | haskell-6656f0165a30fc2a22208532ba384fc8e2f11b46.tar.gz | |
A bunch of changes related to eta reduction
This is a large collection of changes all relating to eta
reduction, originally triggered by #18993, but there followed
a long saga.
Specifics:
* Move state-hack stuff from GHC.Types.Id (where it never belonged)
to GHC.Core.Opt.Arity (which seems much more appropriate).
* Add a crucial mkCast in the Cast case of
GHC.Core.Opt.Arity.eta_expand; helps with T18223
* Add clarifying notes about eta-reducing to PAPs.
See Note [Do not eta reduce PAPs]
* I moved tryEtaReduce from GHC.Core.Utils to GHC.Core.Opt.Arity,
where it properly belongs. See Note [Eta reduce PAPs]
* In GHC.Core.Opt.Simplify.Utils.tryEtaExpandRhs, pull out the code for
when eta-expansion is wanted, to make wantEtaExpansion, and all that
same function in GHC.Core.Opt.Simplify.simplStableUnfolding. It was
previously inconsistent, but it's doing the same thing.
* I did a substantial refactor of ArityType; see Note [ArityType].
This allowed me to do away with the somewhat mysterious takeOneShots;
more generally it allows arityType to describe the function, leaving
its clients to decide how to use that information.
I made ArityType abstract, so that clients have to use functions
to access it.
* Make GHC.Core.Opt.Simplify.Utils.rebuildLam (was stupidly called
mkLam before) aware of the floats that the simplifier builds up, so
that it can still do eta-reduction even if there are some floats.
(Previously that would not happen.) That means passing the floats
to rebuildLam, and an extra check when eta-reducting (etaFloatOk).
* In GHC.Core.Opt.Simplify.Utils.tryEtaExpandRhs, make use of call-info
in the idDemandInfo of the binder, as well as the CallArity info. The
occurrence analyser did this but we were failing to take advantage here.
In the end I moved the heavy lifting to GHC.Core.Opt.Arity.findRhsArity;
see Note [Combining arityType with demand info], and functions
idDemandOneShots and combineWithDemandOneShots.
(These changes partly drove my refactoring of ArityType.)
* In GHC.Core.Opt.Arity.findRhsArity
* I'm now taking account of the demand on the binder to give
extra one-shot info. E.g. if the fn is always called with two
args, we can give better one-shot info on the binders
than if we just look at the RHS.
* Don't do any fixpointing in the non-recursive
case -- simple short cut.
* Trim arity inside the loop. See Note [Trim arity inside the loop]
* Make SimpleOpt respect the eta-reduction flag
(Some associated refactoring here.)
* I made the CallCtxt which the Simplifier uses distinguish between
recursive and non-recursive right-hand sides.
data CallCtxt = ... | RhsCtxt RecFlag | ...
It affects only one thing:
- We call an RHS context interesting only if it is non-recursive
see Note [RHS of lets] in GHC.Core.Unfold
* Remove eta-reduction in GHC.CoreToStg.Prep, a welcome simplification.
See Note [No eta reduction needed in rhsToBody] in GHC.CoreToStg.Prep.
Other incidental changes
* Fix a fairly long-standing outright bug in the ApplyToVal case of
GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the
tail of 'dmds' in the recursive call, which meant the demands were All
Wrong. I have no idea why this has not caused problems before now.
* Delete dead function GHC.Core.Opt.Simplify.Utils.contIsRhsOrArg
Metrics: compile_time/bytes allocated
Test Metric Baseline New value Change
---------------------------------------------------------------------------------------
MultiLayerModulesTH_OneShot(normal) ghc/alloc 2,743,297,692 2,619,762,992 -4.5% GOOD
T18223(normal) ghc/alloc 1,103,161,360 972,415,992 -11.9% GOOD
T3064(normal) ghc/alloc 201,222,500 184,085,360 -8.5% GOOD
T8095(normal) ghc/alloc 3,216,292,528 3,254,416,960 +1.2%
T9630(normal) ghc/alloc 1,514,131,032 1,557,719,312 +2.9% BAD
parsing001(normal) ghc/alloc 530,409,812 525,077,696 -1.0%
geo. mean -0.1%
Nofib:
Program Size Allocs Runtime Elapsed TotalMem
--------------------------------------------------------------------------------
banner +0.0% +0.4% -8.9% -8.7% 0.0%
exact-reals +0.0% -7.4% -36.3% -37.4% 0.0%
fannkuch-redux +0.0% -0.1% -1.0% -1.0% 0.0%
fft2 -0.1% -0.2% -17.8% -19.2% 0.0%
fluid +0.0% -1.3% -2.1% -2.1% 0.0%
gg -0.0% +2.2% -0.2% -0.1% 0.0%
spectral-norm +0.1% -0.2% 0.0% 0.0% 0.0%
tak +0.0% -0.3% -9.8% -9.8% 0.0%
x2n1 +0.0% -0.2% -3.2% -3.2% 0.0%
--------------------------------------------------------------------------------
Min -3.5% -7.4% -58.7% -59.9% 0.0%
Max +0.1% +2.2% +32.9% +32.9% 0.0%
Geometric Mean -0.0% -0.1% -14.2% -14.8% -0.0%
Metric Decrease:
MultiLayerModulesTH_OneShot
T18223
T3064
T15185
T14766
Metric Increase:
T9630
Diffstat (limited to 'testsuite/tests/simplCore')
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/Makefile | 4 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T16254.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T5327.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T7785.stderr | 603 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 11 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/T18012.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/T19569a.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 2 |
8 files changed, 299 insertions, 354 deletions
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index 02358e1746..b1ed06bf71 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -160,12 +160,12 @@ T5298: .PHONY: T5327 T5327: $(RM) -f T5327.hi T5327.o - '$(TEST_HC)' $(TEST_HC_OPTS) -c T5327.hs -O -ddump-simpl | grep -c '># 34# ' + '$(TEST_HC)' $(TEST_HC_OPTS) -c T5327.hs -O -ddump-simpl | grep -c '34#' .PHONY: T16254 T16254: $(RM) -f T16254.hi T16254.o - '$(TEST_HC)' $(TEST_HC_OPTS) -c T16254.hs -O -ddump-simpl | grep -c '># 34# ' + '$(TEST_HC)' $(TEST_HC_OPTS) -c T16254.hs -O -ddump-simpl | grep -c '34#' .PHONY: T5623 T5623: diff --git a/testsuite/tests/simplCore/should_compile/T16254.hs b/testsuite/tests/simplCore/should_compile/T16254.hs index 3c1490c17c..a877eee6ab 100644 --- a/testsuite/tests/simplCore/should_compile/T16254.hs +++ b/testsuite/tests/simplCore/should_compile/T16254.hs @@ -8,7 +8,12 @@ newtype Size a b where {-# INLINABLE val2 #-} val2 = Size 17 --- In the core, we should see a comparison against 34#, i.e. constant --- folding should have happened. We actually see it twice: Once in f's --- definition, and once in its unfolding. +-- In the core, we should see 34#, i.e. constant folding +-- should have happened. +-- +-- We actually get eta-reduction thus: +-- tmp = I# 34# +-- f = gtInt tmp +-- beucase gtInt is marked INLINE with two parameters. +-- But that's ok f n = case val2 of Size s -> s + s > n diff --git a/testsuite/tests/simplCore/should_compile/T5327.hs b/testsuite/tests/simplCore/should_compile/T5327.hs index a2d9c018ae..a533a2fe32 100644 --- a/testsuite/tests/simplCore/should_compile/T5327.hs +++ b/testsuite/tests/simplCore/should_compile/T5327.hs @@ -5,8 +5,13 @@ newtype Size = Size Int {-# INLINABLE val2 #-} val2 = Size 17 --- In the core, we should see a comparison against 34#, i.e. constant --- folding should have happened. We actually see it twice: Once in f's --- definition, and once in its unfolding. +-- In the core, we should see 34#, i.e. constant folding +-- should have happened. +-- +-- We actually get eta-reduction thus: +-- tmp = I# 34# +-- f = gtInt tmp +-- beucase gtInt is marked INLINE with two parameters. +-- But that's ok f n = case val2 of Size s -> s + s > n diff --git a/testsuite/tests/simplCore/should_compile/T7785.stderr b/testsuite/tests/simplCore/should_compile/T7785.stderr index f2f819f89a..504fdc1677 100644 --- a/testsuite/tests/simplCore/should_compile/T7785.stderr +++ b/testsuite/tests/simplCore/should_compile/T7785.stderr @@ -1,408 +1,331 @@ - -==================== Specialise ==================== -Result size of Specialise - = {terms: 293, types: 99, coercions: 11, joins: 0/2} +==================== Common sub-expression ==================== +Result size of Common sub-expression + = {terms: 181, types: 89, coercions: 5, joins: 0/1} -- RHS size: {terms: 5, types: 10, coercions: 0, joins: 0/0} -$cmyfmap_aG0 +$cmyfmap_aG7 :: forall a b. (Domain [] a, Domain [] b) => (a -> b) -> [a] -> [b] [LclId, Arity=4, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + Str=<A><A><U><SU>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True)}] -$cmyfmap_aG0 - = \ (@a_aG3) (@b_aG4) _ [Occ=Dead] _ [Occ=Dead] -> - map @a_aG3 @b_aG4 + Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) + Tmpl= \ (@a_aGa) + (@b_aGb) + _ [Occ=Dead] + _ [Occ=Dead] + (eta_B0 [Occ=Once1, OS=OneShot] :: a_aGa -> b_aGb) + (eta_B1 [Occ=Once1, OS=OneShot] :: [a_aGa]) -> + GHC.Base.build + @b_aGb + (\ (@b1_aHe) + (c_aHf [Occ=Once1, OS=OneShot] :: b_aGb -> b1_aHe -> b1_aHe) + (n_aHg [Occ=Once1, OS=OneShot] :: b1_aHe) -> + GHC.Base.foldr + @a_aGa + @b1_aHe + (GHC.Base.mapFB @b_aGb @b1_aHe @a_aGa c_aHf eta_B0) + n_aHg + eta_B1)}] +$cmyfmap_aG7 + = \ (@a_aGa) + (@b_aGb) + _ [Occ=Dead, Dmd=A] + _ [Occ=Dead, Dmd=A, OS=OneShot] -> + map @a_aGa @b_aGb -- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} -Foo.$fMyFunctor[] [InlPrag=CONLIKE] :: MyFunctor [] +Foo.$fMyFunctor[] [InlPrag=INLINE (sat-args=0)] :: MyFunctor [] [LclIdX[DFunId(nt)], Arity=4, - Unf=DFun: \ -> Foo.C:MyFunctor TYPE: [] $cmyfmap_aG0] + Str=<A><A><U><SU>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=True) + Tmpl= $cmyfmap_aG7 + `cast` (Sym (Foo.N:MyFunctor[0] <[]>_N) + :: (forall a b. + (Domain [] a, Domain [] b) => + (a -> b) -> [a] -> [b]) + ~R# MyFunctor [])}] Foo.$fMyFunctor[] - = $cmyfmap_aG0 + = $cmyfmap_aG7 `cast` (Sym (Foo.N:MyFunctor[0] <[]>_N) :: (forall a b. (Domain [] a, Domain [] b) => (a -> b) -> [a] -> [b]) ~R# MyFunctor []) --- RHS size: {terms: 114, types: 12, coercions: 0, joins: 0/1} -$sshared_sHu :: Domain [] Int => [Int] -> [Int] -[LclId, Arity=1] -$sshared_sHu - = \ (irred_azD :: Domain [] Int) -> - let { - f_sHt :: [Int] -> [Int] - [LclId] - f_sHt - = myfmap - @[] - Foo.$fMyFunctor[] - @Int - @Int - irred_azD - irred_azD - GHC.Num.$fNumInt_$cnegate } in - \ (x_X4N :: [Int]) -> - f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - (f_sHt - x_X4N)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) +-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} +$sshared_sHD :: [Int] -> [Int] +[LclId, + Arity=1, + Str=<SU>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False) + Tmpl= map @Int @Int GHC.Num.$fNumInt_$cnegate}] +$sshared_sHD = map @Int @Int GHC.Num.$fNumInt_$cnegate --- RHS size: {terms: 116, types: 16, coercions: 0, joins: 0/1} +-- RHS size: {terms: 115, types: 15, coercions: 2, joins: 0/1} shared :: forall (f :: * -> *). (MyFunctor f, Domain f Int) => f Int -> f Int [LclIdX, Arity=2, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=NEVER}, + Str=<UC1(CS(CS(U)))><U>, RULES: "SPEC shared @[]" - forall ($dMyFunctor_sHr :: MyFunctor []). - shared @[] $dMyFunctor_sHr - = $sshared_sHu] + forall ($dMyFunctor_sHz :: MyFunctor []) + (irred_sHA :: Domain [] Int). + shared @[] $dMyFunctor_sHz irred_sHA + = $sshared_sHD] shared - = \ (@(f_azB :: * -> *)) - ($dMyFunctor_azC :: MyFunctor f_azB) - (irred_azD :: Domain f_azB Int) -> + = \ (@(f_ayh :: * -> *)) + ($dMyFunctor_ayi [Dmd=UC1(CS(CS(U)))] :: MyFunctor f_ayh) + (irred_ayj :: Domain f_ayh Int) -> let { - f_sHq :: f_azB Int -> f_azB Int + f_sHy :: f_ayh Int -> f_ayh Int [LclId] - f_sHq - = myfmap - @f_azB - $dMyFunctor_azC - @Int - @Int - irred_azD - irred_azD - GHC.Num.$fNumInt_$cnegate } in - \ (x_X4N :: f_azB Int) -> - f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq - (f_sHq + f_sHy + = ($dMyFunctor_ayi + `cast` (Foo.N:MyFunctor[0] <f_ayh>_N + :: MyFunctor f_ayh + ~R# (forall a b. + (Domain f_ayh a, Domain f_ayh b) => + (a -> b) -> f_ayh a -> f_ayh b))) + @Int @Int irred_ayj irred_ayj GHC.Num.$fNumInt_$cnegate } in + \ (x_X4N :: f_ayh Int) -> + f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy + (f_sHy x_X4N)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) --- RHS size: {terms: 8, types: 4, coercions: 4, joins: 0/0} +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl_sHI :: Int +[LclId] +lvl_sHI = GHC.Types.I# 0# + +-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0} foo :: [Int] -> [Int] [LclIdX, Arity=1, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 60 0}] + Str=<U>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (xs_awV [Occ=Once1] :: [Int]) -> + GHC.Base.build + @Int + (\ (@b1_aHe) + (c_aHf [Occ=Once1, OS=OneShot] :: Int -> b1_aHe -> b1_aHe) + (n_aHg [Occ=Once1, OS=OneShot] :: b1_aHe) -> + GHC.Base.foldr + @Int + @b1_aHe + (GHC.Base.mapFB @Int @b1_aHe @Int c_aHf GHC.Num.$fNumInt_$cnegate) + n_aHg + (GHC.Types.: @Int lvl_sHI xs_awV))}] foo - = \ (xs_axd :: [Int]) -> - shared - @[] - Foo.$fMyFunctor[] - (GHC.Classes.(%%) - `cast` (Sub (Sym (Foo.D:R:Domain[]a[0] <Int>_N)) - :: (() :: Constraint) ~R# Domain [] Int)) - (GHC.Types.: @Int (GHC.Types.I# 0#) xs_axd) + = \ (xs_awV :: [Int]) -> + map + @Int + @Int + GHC.Num.$fNumInt_$cnegate + (GHC.Types.: @Int lvl_sHI xs_awV) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +lvl_sHJ :: Int +[LclId] +lvl_sHJ = lvl_sHI --- RHS size: {terms: 8, types: 4, coercions: 4, joins: 0/0} +-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0} bar :: [Int] -> [Int] [LclIdX, Arity=1, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 60 10}] + Str=<1U>, + Cpr=m2, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (xs_awW [Occ=Once1] :: [Int]) -> + GHC.Types.: + @Int + lvl_sHI + (GHC.Base.build + @Int + (\ (@b1_aHe) + (c_aHf [Occ=Once1, OS=OneShot] :: Int -> b1_aHe -> b1_aHe) + (n_aHg [Occ=Once1, OS=OneShot] :: b1_aHe) -> + GHC.Base.foldr + @Int + @b1_aHe + (GHC.Base.mapFB @Int @b1_aHe @Int c_aHf GHC.Num.$fNumInt_$cnegate) + n_aHg + xs_awW))}] bar - = \ (xs_axe :: [Int]) -> + = \ (xs_awW :: [Int]) -> GHC.Types.: - @Int - (GHC.Types.I# 0#) - (shared - @[] - Foo.$fMyFunctor[] - (GHC.Classes.(%%) - `cast` (Sub (Sym (Foo.D:R:Domain[]a[0] <Int>_N)) - :: (() :: Constraint) ~R# Domain [] Int)) - xs_axe) + @Int lvl_sHI (map @Int @Int GHC.Num.$fNumInt_$cnegate xs_awW) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$trModule_sHj :: GHC.Prim.Addr# -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] -$trModule_sHj = "main"# +$trModule_sHr :: GHC.Prim.Addr# +[LclId] +$trModule_sHr = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$trModule_sHk :: GHC.Types.TrName -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -$trModule_sHk = GHC.Types.TrNameS $trModule_sHj +$trModule_sHs :: GHC.Types.TrName +[LclId] +$trModule_sHs = GHC.Types.TrNameS $trModule_sHr -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$trModule_sHl :: GHC.Prim.Addr# -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] -$trModule_sHl = "Foo"# +$trModule_sHt :: GHC.Prim.Addr# +[LclId] +$trModule_sHt = "Foo"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$trModule_sHm :: GHC.Types.TrName -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -$trModule_sHm = GHC.Types.TrNameS $trModule_sHl +$trModule_sHu :: GHC.Types.TrName +[LclId] +$trModule_sHu = GHC.Types.TrNameS $trModule_sHt -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Foo.$trModule :: GHC.Types.Module -[LclIdX, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -Foo.$trModule = GHC.Types.Module $trModule_sHk $trModule_sHm +[LclIdX] +Foo.$trModule = GHC.Types.Module $trModule_sHs $trModule_sHu -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} -$krep_aGA [InlPrag=[~]] :: GHC.Types.KindRep -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -$krep_aGA +$krep_aGF [InlPrag=[~]] :: GHC.Types.KindRep +[LclId] +$krep_aGF = GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint (GHC.Types.[] @GHC.Types.KindRep) -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep_aGz [InlPrag=[~]] :: GHC.Types.KindRep -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -$krep_aGz = GHC.Types.KindRepFun GHC.Types.krep$*Arr* $krep_aGA +$krep_aGE [InlPrag=[~]] :: GHC.Types.KindRep +[LclId] +$krep_aGE = GHC.Types.KindRepFun GHC.Types.krep$*Arr* $krep_aGF -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$tcMyFunctor_sHn :: GHC.Prim.Addr# -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 0}] -$tcMyFunctor_sHn = "MyFunctor"# +$tcMyFunctor_sHv :: GHC.Prim.Addr# +[LclId] +$tcMyFunctor_sHv = "MyFunctor"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$tcMyFunctor_sHo :: GHC.Types.TrName -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -$tcMyFunctor_sHo = GHC.Types.TrNameS $tcMyFunctor_sHn +$tcMyFunctor_sHw :: GHC.Types.TrName +[LclId] +$tcMyFunctor_sHw = GHC.Types.TrNameS $tcMyFunctor_sHv -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} Foo.$tcMyFunctor :: GHC.Types.TyCon -[LclIdX, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +[LclIdX] Foo.$tcMyFunctor = GHC.Types.TyCon - 12837160846121910345##64 - 787075802864859973##64 + 12837160846121910345## + 787075802864859973## Foo.$trModule - $tcMyFunctor_sHo + $tcMyFunctor_sHw 0# - $krep_aGz - - - + $krep_aGE diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index b92f24cd5b..5a018cdb2d 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -136,9 +136,14 @@ test('T5366', test('T7796', [], makefile_test, ['T7796']) test('T5550', omit_ways(prof_ways), compile, ['']) test('T7865', normal, makefile_test, ['T7865']) -# T7785: Check that we generate the specialising RULE. Might not be listed in -# -ddump-rules because of Note [Trimming auto-rules], hence grep -test('T7785', [ only_ways(['optasm']), grep_errmsg(r'RULE') ], compile, ['-ddump-spec']) + +# T7785: we want to check that we specialise 'shared'. But Tidy discards the +# rule (see Note [Trimming auto-rules] in GHC.Iface.Tidy) +# So, rather arbitrarily, we dump the output of CSE and grep for SPEC +test('T7785', [ only_ways(['optasm']), + grep_errmsg(r'SPEC') ], + compile, ['-ddump-cse']) + test('T7702', [extra_files(['T7702plugin']), pre_cmd('$MAKE -s --no-print-directory -C T7702plugin package.T7702 TOP={top}'), diff --git a/testsuite/tests/simplCore/should_run/T18012.hs b/testsuite/tests/simplCore/should_run/T18012.hs index 9118b75ff4..9ce1f1fb9d 100644 --- a/testsuite/tests/simplCore/should_run/T18012.hs +++ b/testsuite/tests/simplCore/should_run/T18012.hs @@ -32,10 +32,10 @@ notRule x = x {-# INLINE [0] notRule #-} {-# RULES "notRule/False" [~0] notRule False = True #-} -f :: T -> () -> Bool -f (D a) () = notRule a +f :: () -> T -> Bool +f () (D a) = notRule a {-# INLINE [100] f #-} -- so it isn’t inlined before FloatOut g :: () -> Bool -g x = f (D False) x +g x = f x (D False) {-# NOINLINE g #-} diff --git a/testsuite/tests/simplCore/should_run/T19569a.hs b/testsuite/tests/simplCore/should_run/T19569a.hs index bffef2c6df..a732e1f81f 100644 --- a/testsuite/tests/simplCore/should_run/T19569a.hs +++ b/testsuite/tests/simplCore/should_run/T19569a.hs @@ -3,6 +3,11 @@ -- so I added it to testsuite to catch such regressions in the future. -- It might be acceptable for this test to fail if you make changes to the simplifier. But generally such a failure shouldn't be accepted without good reason. +-- +-- For example, one of the numerical instabilities was/is caused by a rewrite rule +-- in GHC.Real which rewrites powers with small exponents. See !8082, changes in the +-- simplifier caused this rewrite rule to trigger (or not) which then produced different +-- results. -- The excessive whitespace is the result of running the original benchmark which was a .lhs file through unlit. diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 53bcde5169..509ae1ff57 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -97,7 +97,9 @@ test('NumConstantFolding16', normal, compile_and_run, ['']) test('NumConstantFolding32', normal, compile_and_run, ['']) test('NumConstantFolding', normal, compile_and_run, ['']) test('T19413', normal, compile_and_run, ['']) + test('T19569a', [only_ways(['optasm']),extra_run_opts('True 1000000')], compile_and_run, ['-O2']) + test('T20203', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-typeable-binds -ddump-simpl']) test('T19313', normal, compile_and_run, ['']) test('UnliftedArgRule', normal, compile_and_run, ['']) |