summaryrefslogtreecommitdiff
path: root/testsuite/tests
diff options
context:
space:
mode:
authorSebastian Graf <sebastian.graf@kit.edu>2022-02-28 14:52:36 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-03-13 18:12:48 -0400
commit76b94b726f6e21bb2a46ae04e4a1be2cba45a3dc (patch)
tree8db126a5c8718140a6cd7bdd8f3a20df257f580c /testsuite/tests
parentad83553153278947f439951d79a842527f2f0983 (diff)
downloadhaskell-76b94b726f6e21bb2a46ae04e4a1be2cba45a3dc.tar.gz
Worker/wrapper: Preserve float barriers (#21150)
Issue #21150 shows that worker/wrapper allocated a worker function for a function with multiple calls that said "called at most once" when the first argument was absent. That's bad! This patch makes it so that WW preserves at least one non-one-shot value lambda (see `Note [Preserving float barriers]`) by passing around `void#` in place of absent arguments. Fixes #21150. Since the fix is pretty similar to `Note [Protecting the last value argument]`, I put the logic in `mkWorkerArgs`. There I realised (#21204) that `-ffun-to-thunk` is basically useless with `-ffull-laziness`, so I deprecated the flag, simplified and split into `needsVoidWorkerArg`/`addVoidWorkerArg`. SpecConstr is another client of that API. Fixes #21204. Metric Decrease: T14683
Diffstat (limited to 'testsuite/tests')
-rw-r--r--testsuite/tests/simplCore/should_compile/T19794.hs6
-rw-r--r--testsuite/tests/stranal/should_compile/T21150.hs37
-rw-r--r--testsuite/tests/stranal/should_compile/T21150.stderr237
-rw-r--r--testsuite/tests/stranal/should_compile/all.T3
4 files changed, 281 insertions, 2 deletions
diff --git a/testsuite/tests/simplCore/should_compile/T19794.hs b/testsuite/tests/simplCore/should_compile/T19794.hs
index c8f6897468..2518586db6 100644
--- a/testsuite/tests/simplCore/should_compile/T19794.hs
+++ b/testsuite/tests/simplCore/should_compile/T19794.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE MagicHash #-}
-{-# OPTIONS_GHC -ffun-to-thunk #-} -- This is essential for the test
+-- -ffun-to-thunk is essential for the test, but the flag had been deprecated in
+-- 9.4 and is off by default. It doesn't hurt to keep the regression test, though,
+-- in case we accidentally drop the logic for
+-- Note [Protecting the last value argument].
+-- {-# OPTIONS_GHC -ffun-to-thunk #-}
module Foo where
import GHC.Exts
diff --git a/testsuite/tests/stranal/should_compile/T21150.hs b/testsuite/tests/stranal/should_compile/T21150.hs
new file mode 100644
index 0000000000..520b7d9d77
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T21150.hs
@@ -0,0 +1,37 @@
+-- | The idea here is that t* should never be inlined into g*.
+-- That may happen if the absent arguments of g* are dropped without care,
+-- making $wg* appear as if all its lambdas are oneShot afterwards.
+--
+-- So in these cases, we replace absent args with `Void#` instead in order
+-- to preserve lambda groups.
+module T21150 where
+
+import GHC.Exts
+
+f :: Int -> Int -> Int -> Maybe Int
+f x y z = (+) <$> g x y z <*> g x z y
+ where
+ t :: Int
+ t = sum [0..x]
+ g :: Int -> Int -> Int -> Maybe Int
+ g _ = oneShot $ \_ -> oneShot $ \z -> Just (y + z + t)
+ {-# NOINLINE g #-}
+
+f2 :: Int -> Int -> Int -> Maybe Int
+f2 x y z = (+) <$> g' y <*> g' z
+ where
+ t2 :: Int
+ t2 = sum [0..x]
+ g' = g2 x
+ g2 :: Int -> Int -> Maybe Int
+ g2 = oneShot $ \y _ -> Just (y + z + t2)
+ {-# NOINLINE g2 #-}
+
+f3 :: Int -> Int -> Int -> Maybe Int
+f3 x y z = (+) <$> g3 x y z <*> g3 x z y
+ where
+ t3 :: Int
+ t3 = sum [0..x]
+ g3 :: Int -> Int -> Int -> Maybe Int
+ g3 = oneShot $ \y z _ -> Just (y + z + t3)
+ {-# NOINLINE g3 #-}
diff --git a/testsuite/tests/stranal/should_compile/T21150.stderr b/testsuite/tests/stranal/should_compile/T21150.stderr
new file mode 100644
index 0000000000..fc70e22563
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T21150.stderr
@@ -0,0 +1,237 @@
+
+==================== Exitification transformation ====================
+Result size of Exitification transformation
+ = {terms: 242, types: 140, coercions: 0, joins: 3/9}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T21150"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T21150.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T21150.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 70, types: 37, coercions: 0, joins: 1/3}
+f3 :: Int -> Int -> Int -> Maybe Int
+[LclIdX,
+ Arity=3,
+ Str=<L><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 0 0] 279 10}]
+f3
+ = \ (x :: Int) (y :: Int) (z :: Int) ->
+ let {
+ t3 :: Int
+ [LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 77 0}]
+ t3
+ = case x of { I# y ->
+ case ># 0# y of {
+ __DEFAULT ->
+ joinrec {
+ $wgo3 [InlPrag=[2], Occ=LoopBreaker] :: Int# -> Int# -> Int
+ [LclId[JoinId(2)(Nothing)],
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 40 10}]
+ $wgo3 (x :: Int#) (ww :: Int#)
+ = case ==# x y of {
+ __DEFAULT -> jump $wgo3 (+# x 1#) (+# ww x);
+ 1# -> GHC.Types.I# (+# ww x)
+ }; } in
+ jump $wgo3 0# 0#;
+ 1# -> lvl
+ }
+ } } in
+ let {
+ $wg3 [InlPrag=NOINLINE] :: Int -> Int -> (# Int #)
+ [LclId,
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 42 10}]
+ $wg3
+ = \ (v [OS=OneShot] :: Int) (z :: Int) ->
+ (# case v of { I# x ->
+ case z of { I# y ->
+ case t3 of { I# y -> GHC.Types.I# (+# (+# x y) y) }
+ }
+ } #) } in
+ case $wg3 x y of { (# ww #) ->
+ case $wg3 x z of { (# ww #) ->
+ GHC.Maybe.Just @Int (GHC.Num.$fNumInt_$c+ ww ww)
+ }
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 69, types: 36, coercions: 0, joins: 1/3}
+$wf2 [InlPrag=[2]] :: Int -> Int -> Maybe Int
+[LclId,
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 279 10}]
+$wf2
+ = \ (x :: Int) (z :: Int) ->
+ let {
+ t2 :: Int
+ [LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 77 0}]
+ t2
+ = case x of { I# y ->
+ case ># 0# y of {
+ __DEFAULT ->
+ joinrec {
+ $wgo3 [InlPrag=[2], Occ=LoopBreaker] :: Int# -> Int# -> Int
+ [LclId[JoinId(2)(Nothing)],
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 40 10}]
+ $wgo3 (x :: Int#) (ww :: Int#)
+ = case ==# x y of {
+ __DEFAULT -> jump $wgo3 (+# x 1#) (+# ww x);
+ 1# -> GHC.Types.I# (+# ww x)
+ }; } in
+ jump $wgo3 0# 0#;
+ 1# -> lvl
+ }
+ } } in
+ let {
+ $wg2 [InlPrag=NOINLINE] :: Int -> (# #) -> (# Int #)
+ [LclId,
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 0] 42 10}]
+ $wg2
+ = \ (v [OS=OneShot] :: Int) _ [Occ=Dead] ->
+ (# case v of { I# x ->
+ case z of { I# y ->
+ case t2 of { I# y -> GHC.Types.I# (+# (+# x y) y) }
+ }
+ } #) } in
+ case $wg2 x GHC.Prim.(##) of { (# ww #) ->
+ case $wg2 x GHC.Prim.(##) of { (# ww #) ->
+ GHC.Maybe.Just @Int (GHC.Num.$fNumInt_$c+ ww ww)
+ }
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+f2 [InlPrag=[2]] :: Int -> Int -> Int -> Maybe Int
+[LclIdX,
+ Arity=3,
+ Str=<L><A><L>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=True)
+ Tmpl= \ (x [Occ=Once1] :: Int)
+ _ [Occ=Dead, Dmd=A]
+ (z [Occ=Once1] :: Int) ->
+ $wf2 x z}]
+f2 = \ (x :: Int) _ [Occ=Dead, Dmd=A] (z :: Int) -> $wf2 x z
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 70, types: 37, coercions: 0, joins: 1/3}
+f :: Int -> Int -> Int -> Maybe Int
+[LclIdX,
+ Arity=3,
+ Str=<L><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20 0] 279 10}]
+f = \ (x :: Int) (y :: Int) (z :: Int) ->
+ let {
+ t :: Int
+ [LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 77 0}]
+ t = case x of { I# y ->
+ case ># 0# y of {
+ __DEFAULT ->
+ joinrec {
+ $wgo3 [InlPrag=[2], Occ=LoopBreaker] :: Int# -> Int# -> Int
+ [LclId[JoinId(2)(Nothing)],
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 40 10}]
+ $wgo3 (x :: Int#) (ww :: Int#)
+ = case ==# x y of {
+ __DEFAULT -> jump $wgo3 (+# x 1#) (+# ww x);
+ 1# -> GHC.Types.I# (+# ww x)
+ }; } in
+ jump $wgo3 0# 0#;
+ 1# -> lvl
+ }
+ } } in
+ let {
+ $wg [InlPrag=NOINLINE] :: Int -> (# #) -> (# Int #)
+ [LclId,
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 0] 42 10}]
+ $wg
+ = \ (v [OS=OneShot] :: Int) _ [Occ=Dead] ->
+ (# case y of { I# x ->
+ case v of { I# y ->
+ case t of { I# y -> GHC.Types.I# (+# (+# x y) y) }
+ }
+ } #) } in
+ case $wg z GHC.Prim.(##) of { (# ww #) ->
+ case $wg y GHC.Prim.(##) of { (# ww #) ->
+ GHC.Maybe.Just @Int (GHC.Num.$fNumInt_$c+ ww ww)
+ }
+ }
+
+
+
diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T
index ac35fc42ce..042ee9dd44 100644
--- a/testsuite/tests/stranal/should_compile/all.T
+++ b/testsuite/tests/stranal/should_compile/all.T
@@ -80,4 +80,5 @@ test('T20510', [ grep_errmsg(r'jump \$wgo') ], compile, ['-dsuppress-uniques -dd
test('T20746', normal, compile, ['-dsuppress-uniques -ddump-simpl'])
test('T20746b', normal, compile, ['-dsuppress-uniques -ddump-simpl -dno-typeable-binds'])
test('T20817', [ grep_errmsg(r'Str') ], compile, ['-dsuppress-uniques -ddump-stranal'])
-
+# T21150: Check that t{,1,2} haven't been inlined.
+test('T21150', [ grep_errmsg(r'( t\d? :: Int)') ], compile, ['-dsuppress-uniques -ddump-exitify'])