summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2023-03-29 11:08:06 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-03-31 21:28:28 -0400
commit0077cb225bde18ee6c7ff49d6486eb20fc6c011a (patch)
treeefbac698822d21be8606fdb8c47b49e80ed2601f
parentea853ff066afb4d4f2271b24be898693e2a3e18d (diff)
downloadhaskell-0077cb225bde18ee6c7ff49d6486eb20fc6c011a.tar.gz
Add test for T23184
There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj@microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 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: ...lots of lines omitted... 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. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes.
-rw-r--r--testsuite/tests/simplCore/should_run/T23184.hs18
-rw-r--r--testsuite/tests/simplCore/should_run/T23184.stdout1
-rw-r--r--testsuite/tests/simplCore/should_run/all.T1
3 files changed, 20 insertions, 0 deletions
diff --git a/testsuite/tests/simplCore/should_run/T23184.hs b/testsuite/tests/simplCore/should_run/T23184.hs
new file mode 100644
index 0000000000..ea98bb313f
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T23184.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import GHC.Magic
+
+main :: IO ()
+main = print $ noinline (\x -> sum $ tardisManual [0..x]) 0
+
+tardisManual :: [Int] -> [Int]
+tardisManual xs =
+ let
+ go [] !acc _ = ([], 0)
+ go (_:xs) !acc l =
+ let (xs', _) = go xs acc l
+ in (l:xs', 0)
+ (r, l) = go xs True l
+ in r
+{-# INLINE tardisManual #-}
diff --git a/testsuite/tests/simplCore/should_run/T23184.stdout b/testsuite/tests/simplCore/should_run/T23184.stdout
new file mode 100644
index 0000000000..573541ac97
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T23184.stdout
@@ -0,0 +1 @@
+0
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 928bf89df9..fc3d605ac7 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -109,4 +109,5 @@ test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O'])
test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836
test('T22448', normal, compile_and_run, ['-O1'])
test('T22998', normal, compile_and_run, ['-O0 -fspecialise -dcore-lint'])
+test('T23184', normal, compile_and_run, ['-O'])