[Git][ghc/ghc][master] 2 commits: Rename test for #24725

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
9b8ddaaf by Arnaud Spiwack at 2024-06-26T21:52:23-04:00
Rename test for #24725

I must have fumbled my tabs when I copy/pasted the issue number in
8c87d4e1136ae6d28e92b8af31d78ed66224ee16.

- - - - -
b0944623 by Arnaud Spiwack at 2024-06-26T21:52:23-04:00
Add original reproducer for #24725

- - - - -


6 changed files:

- + testsuite/tests/simplCore/should_compile/T24725a.hs
- + testsuite/tests/simplCore/should_compile/T24725a.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_run/T23586.hs → testsuite/tests/simplCore/should_run/T24725.hs
- testsuite/tests/simplCore/should_run/T23586.stdout → testsuite/tests/simplCore/should_run/T24725.stdout
- testsuite/tests/simplCore/should_run/all.T


Changes:

=====================================
testsuite/tests/simplCore/should_compile/T24725a.hs
=====================================
@@ -0,0 +1,55 @@
+{-# LANGUAGE LinearTypes #-}
+
+-- This is the original reproducer for #24725. If this test fails and the
+-- shorter T24725 doesn't, then we've found a new way of failing this test.
+
+module ConcatMap where
+
+data Stream a = forall s. Stream (s -> Step s a) !s
+data Step s a = Yield a !s | Skip !s | Done
+
+data Tuple a b = a :!: b
+data Option a = None | Some !a
+
+concatMapS :: (a -> Stream b) -> Stream a -> Stream b
+concatMapS f (Stream next0 s0) = Stream next (s0 :!: None)
+  where
+    {-# INLINE next #-}
+    next (s :!: None) = case next0 s of
+      Done       -> Done
+      Skip    s' -> Skip (s' :!: None)
+      Yield x s' -> Skip (s' :!: Some (f x))
+
+    next (s :!: Some (Stream g t)) = case g t of
+      Done       -> Skip    (s :!: None)
+      Skip    t' -> Skip    (s :!: Some (Stream g t'))
+      Yield x t' -> Yield x (s :!: Some (Stream g t'))
+{-# INLINE [1] concatMapS #-}
+
+concatMapS' :: (s -> Step s b) -> (a -> s) -> Stream a -> Stream b
+concatMapS' next2 f (Stream next1 s0) = Stream next (s0 :!: None)
+  where
+    {-# INLINE next #-}
+    next (s :!: None) = case next1 s of
+      Done       -> Done
+      Skip    s' -> Skip (s' :!: None)
+      Yield x s' -> Skip (s' :!: Some (f x))
+
+    next (s :!: Some t) = case next2 t of
+      Done       -> Skip    (s :!: None)
+      Skip    t' -> Skip    (s :!: Some t')
+      Yield x t' -> Yield x (s :!: Some t')
+{-# INLINE concatMapS' #-}
+
+{-# RULES "testedRule" forall step f. concatMapS (\x -> Stream step (f x)) = concatMapS' step f #-}
+
+replicateStep1 :: Tuple Int a -> Step (Tuple Int a) a
+replicateStep1 (0 :!: _) = Done
+replicateStep1 (n :!: x) = Yield x ((n - 1) :!: x)
+
+replicateS1 :: Int -> a -> Stream a
+replicateS1 n x = Stream replicateStep1 (n :!: x)
+{-# INLINE replicateS1 #-}
+
+should_fire :: Stream Int -> Stream Int
+should_fire = concatMapS (replicateS1 2)


=====================================
testsuite/tests/simplCore/should_compile/T24725a.stderr
=====================================
@@ -0,0 +1,2 @@
+Rule fired: Class op - (BUILTIN)
+Rule fired: testedRule (ConcatMap)


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -525,3 +525,5 @@ test('T24808', [ grep_errmsg(r'myFunction') ], compile, ['-O -ddump-simpl'])
 
 # T24944 needs -O2 because it's about SpecConstr
 test('T24944', [extra_files(['T24944a.hs'])], multimod_compile, ['T24944', '-v0 -O2'])
+
+test('T24725a', [ grep_errmsg(r'testedRule')], compile, ['-O -ddump-rule-firings'])


=====================================
testsuite/tests/simplCore/should_run/T23586.hs → testsuite/tests/simplCore/should_run/T24725.hs
=====================================


=====================================
testsuite/tests/simplCore/should_run/T23586.stdout → testsuite/tests/simplCore/should_run/T24725.stdout
=====================================


=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -114,4 +114,4 @@ test('T23184', normal, compile_and_run, ['-O'])
 test('T23134', normal, compile_and_run, ['-O0 -fcatch-nonexhaustive-cases'])
 test('T23289', normal, compile_and_run, [''])
 test('T23056', [only_ways(['ghci-opt'])], ghci_script, ['T23056.script'])
-test('T23586', normal, compile_and_run, ['-O -dcore-lint'])
+test('T24725', normal, compile_and_run, ['-O -dcore-lint'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e424304c092391508fb7b0ae248f3f49fc934b7...b09446232771a1929fe2885bcf527b3d74168e3e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e424304c092391508fb7b0ae248f3f49fc934b7...b09446232771a1929fe2885bcf527b3d74168e3e
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/20240626/64e135e0/attachment-0001.html>