diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-06-01 21:17:51 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-10 13:54:40 -0400 |
commit | 3d5cb3352c1e1c20f0d5de427f4edbc765ce06d6 (patch) | |
tree | c0f47881c34c64268b2def0aee6fe1ff63e69a0d /testsuite/tests | |
parent | 472c2bf003e9f3bb93b82265f2a0a7124f944421 (diff) | |
download | haskell-3d5cb3352c1e1c20f0d5de427f4edbc765ce06d6.tar.gz |
Fix INLINE pragmas in desugarer
In #19969 we discovered that GHC has has a bug *forever* that means it
sometimes essentially discarded INLINE pragams. This happened when you have
* Two more more mutually recursive functions
* Some of which (presumably not all!) have an INLINE pragma
* Completely monomorphic.
This hits a particular case in GHC.HsToCore.Binds.dsAbsBinds, which was
simply wrong -- it put the INLINE pragma on the wrong binder.
This patch fixes the bug, rather easily, by adjusting the
no-tyvar, no-dict case of GHC.HsToCore.Binds.dsAbsBinds.
I also discovered that the GHC.Core.Opt.Pipeline.shortOutIndirections
was not doing a good job for
{-# INLINE lcl_id #-}
lcl_id = BIG
gbl_id = lcl_id
Here we want to transfer the stable unfolding to gbl_id (we do), but
we also want to remove it from lcl_id (we were not doing that).
Otherwise both Ids have large stable unfoldings. Easily fixed.
Note [Transferring IdInfo] explains.
Diffstat (limited to 'testsuite/tests')
-rw-r--r-- | testsuite/tests/deSugar/should_compile/T19969.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_compile/T19969.stderr | 38 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_compile/all.T | 1 |
3 files changed, 54 insertions, 0 deletions
diff --git a/testsuite/tests/deSugar/should_compile/T19969.hs b/testsuite/tests/deSugar/should_compile/T19969.hs new file mode 100644 index 0000000000..ad9546c84a --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T19969.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -dno-typeable-binds -O2 -fno-worker-wrapper #-} + +module T19969 where + +-- Three mutually recursive functions +-- We want to inline g, h, keeping f as the loop breaker + +f x = reverse (g (x:: [Int])) :: [Int] + +{-# INLINE g #-} + +g x = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (h x)))))))))))) + +{-# INLINE h #-} +h x = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse (f x)))))))))))) diff --git a/testsuite/tests/deSugar/should_compile/T19969.stderr b/testsuite/tests/deSugar/should_compile/T19969.stderr new file mode 100644 index 0000000000..5e23785472 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T19969.stderr @@ -0,0 +1,38 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 12, types: 18, coercions: 0, joins: 0/0} + +Rec { +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +f [Occ=LoopBreaker] :: [Int] -> [Int] +[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []] +f = \ (x :: [Int]) -> f x +end Rec } + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int] +[GblId, + Arity=1, + Str=<B>b, + Cpr=b, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True) + Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}] +g = \ (x :: [Int]) -> f x + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int] +[GblId, + Arity=1, + Str=<B>b, + Cpr=b, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True) + Tmpl= \ (x [Occ=Once1] :: [Int]) -> f x}] +h = \ (x :: [Int]) -> f x + + + diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T index 888369b849..6e6f486b4a 100644 --- a/testsuite/tests/deSugar/should_compile/all.T +++ b/testsuite/tests/deSugar/should_compile/all.T @@ -110,3 +110,4 @@ test('T14815', [], makefile_test, ['T14815']) test('T13208', [], makefile_test, ['T13208']) test('T16615', normal, compile, ['-ddump-ds -dsuppress-uniques']) test('T18112', [grep_errmsg('cast')], compile, ['-ddump-ds']) +test('T19969', normal, compile, ['-ddump-simpl -dsuppress-uniques']) |