diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2022-10-06 10:59:29 +0200 |
---|---|---|
committer | Sebastian Graf <sebastian.graf@kit.edu> | 2022-10-12 13:15:31 +0200 |
commit | f4bfd14be676e75c6b126721251097524fd83d46 (patch) | |
tree | d5e1546d858ea59d69ef4ae7e12a569f62982a48 /testsuite/tests/simplCore | |
parent | ed4b5885bdac7b986655bb40f8c9ece2f8735c98 (diff) | |
download | haskell-wip/T22277.tar.gz |
Denest NonRecs in SpecConstr for more specialisation (#22277)wip/T22277
See Note [Denesting non-recursive let bindings].
Fixes #22277. It is also related to #14951 and #14844 in that it
fixes a very specific case of looking through a non-recursive let binding in
SpecConstr.
Diffstat (limited to 'testsuite/tests/simplCore')
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T14951.hs | 24 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T22277.hs | 16 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T22277.stderr | 132 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 5 |
4 files changed, 177 insertions, 0 deletions
diff --git a/testsuite/tests/simplCore/should_compile/T14951.hs b/testsuite/tests/simplCore/should_compile/T14951.hs new file mode 100644 index 0000000000..d426b2b567 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T14951.hs @@ -0,0 +1,24 @@ +-- {-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-} +-- {-# OPTIONS_GHC -O2 -fforce-recomp #-} +-- {-# LANGUAGE PatternSynonyms #-} +-- {-# LANGUAGE BangPatterns #-} +-- {-# LANGUAGE MagicHash, UnboxedTuples #-} + +module T14844Example (topLvl) where + +topLvl large = (bar1, bar2, foo) + where + foo :: Integer -> (a -> b -> Bool) -> (a,b) -> Bool + foo 0 _ _ = False + foo s f t = l s' t + where + l 0 t = False + l 1 t = case t of (x,y) -> f x y + l n (x,y) = l (n-1) (x,y) + s' = large s + + bar1 :: Integer -> (a -> b -> Bool) -> a -> b -> Bool + bar1 s f x y = foo s f (x,y) + + bar2 :: Integer -> (a -> b -> Bool) -> a -> b -> Bool + bar2 s f x y = foo (s + 1) f (x,y) diff --git a/testsuite/tests/simplCore/should_compile/T22277.hs b/testsuite/tests/simplCore/should_compile/T22277.hs new file mode 100644 index 0000000000..16a990b0b4 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T22277.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} + +module T22277 where + +entry :: Int -> Int +entry n = case n of + 0 -> f n (13,24) + _ -> f n (n,n) + where + f :: Int -> (Int,Int) -> Int + f m x = g m x + where + exit m = (length $ reverse $ reverse $ reverse $ reverse $ [0..m]) + n + g n p | even n = exit n + | n > 43 = g (n-1) p + | otherwise = fst p diff --git a/testsuite/tests/simplCore/should_compile/T22277.stderr b/testsuite/tests/simplCore/should_compile/T22277.stderr new file mode 100644 index 0000000000..6cf8471de5 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T22277.stderr @@ -0,0 +1,132 @@ +[1 of 1] Compiling T22277 ( T22277.hs, T22277.o ) + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 110, types: 49, coercions: 0, joins: 3/4} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T22277.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T22277.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T22277.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T22277.$trModule3 = GHC.Types.TrNameS T22277.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T22277.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T22277.$trModule2 = "T22277"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T22277.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T22277.$trModule1 = GHC.Types.TrNameS T22277.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T22277.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T22277.$trModule + = GHC.Types.Module T22277.$trModule3 T22277.$trModule1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T22277.entry2 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T22277.entry2 = GHC.Types.I# 13# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T22277.entry1 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T22277.entry1 = GHC.Types.I# 24# + +-- RHS size: {terms: 89, types: 40, coercions: 0, joins: 3/4} +entry :: Int -> Int +[GblId, + Arity=1, + Str=<1P(SL)>, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 403 0}] +entry + = \ (n :: Int) -> + case n of wild { GHC.Types.I# ds -> + join { + $w$sexit [InlPrag=[2], Dmd=LC(S,!P(L))] :: GHC.Prim.Int# -> Int + [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>] + $w$sexit (ww [OS=OneShot] :: GHC.Prim.Int#) + = join { + $j [Dmd=1C(1,!P(L))] :: [Int] -> Int + [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, Unf=OtherCon []] + $j (arg [OS=OneShot] :: [Int]) + = case GHC.List.$wlenAcc + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 + @Int + (GHC.List.reverse1 @Int arg (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + (GHC.Types.[] @Int)) + 0# + of ww1 + { __DEFAULT -> + GHC.Types.I# (GHC.Prim.+# ww1 ds) + } } in + case GHC.Prim.># 0# ww of { + __DEFAULT -> + letrec { + go3 [Occ=LoopBreaker, Dmd=SC(S,L)] :: GHC.Prim.Int# -> [Int] + [LclId, Arity=1, Str=<L>, Unf=OtherCon []] + go3 + = \ (x :: GHC.Prim.Int#) -> + GHC.Types.: + @Int + (GHC.Types.I# x) + (case GHC.Prim.==# x ww of { + __DEFAULT -> go3 (GHC.Prim.+# x 1#); + 1# -> GHC.Types.[] @Int + }); } in + jump $j (go3 0#); + 1# -> jump $j (GHC.Types.[] @Int) + } } in + joinrec { + $s$wg [Occ=LoopBreaker, Dmd=SC(S,C(1,C(1,!P(L))))] + :: Int -> Int -> GHC.Prim.Int# -> Int + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<ML><A><L>, + Unf=OtherCon []] + $s$wg (sc :: Int) (sc1 :: Int) (sc2 :: GHC.Prim.Int#) + = case GHC.Prim.remInt# sc2 2# of { + __DEFAULT -> + case GHC.Prim.># sc2 43# of { + __DEFAULT -> sc; + 1# -> jump $s$wg sc sc1 (GHC.Prim.-# sc2 1#) + }; + 0# -> jump $w$sexit sc2 + }; } in + case ds of ds1 { + __DEFAULT -> jump $s$wg wild wild ds1; + 0# -> jump $s$wg T22277.entry2 T22277.entry1 0# + } + } + + + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 283c6cf1b0..15cd08d52e 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -273,6 +273,9 @@ test('T14152a', [extra_files(['T14152.hs']), pre_cmd('cp T14152.hs T14152a.hs'), compile, ['-fno-exitification -ddump-simpl']) test('T13990', normal, compile, ['-dcore-lint -O']) test('T14650', normal, compile, ['-O2']) + +# SpecConstr should specialise `l` here: +test('T14951', [expect_broken(14591), grep_errmsg(r'\$sl') ], compile, ['-O2 -dsuppress-uniques -ddump-simpl']) test('T14959', normal, compile, ['-O']) test('T14978', normal, @@ -434,3 +437,5 @@ test('T21286', normal, multimod_compile, ['T21286', '-O -ddump-rule-firings']) test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O -dno-typeable-binds -dsuppress-uniques']) # One module, T22097.hs, has OPTIONS_GHC -ddump-simpl test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques']) +# SpecConstr should be able to specialise `go` for the pair +test('T22277', [grep_errmsg(r'\$s\$wgo') ], compile, ['-O2 -ddump-simpl -dsuppress-uniques']) |