From ba2f9f345d81f24e2d2ae2ca37e875a0155557cb Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Fri, 30 Jun 2023 20:19:50 +0200
Subject: [PATCH] Fix #23567, a specializer bug
Found by Simon in https://gitlab.haskell.org/ghc/ghc/-/issues/23567#note_507834
The testcase isn't ideal because it doesn't detect the bug in master,
unless doNotUnbox is removed as in
https://gitlab.haskell.org/ghc/ghc/-/issues/23567#note_507692.
But I have confirmed that with that modification, it fails before
and passes afterwards.
(cherry picked from commit bf9b9de0685e23c191722dfdb78d28b44f1cba05)
---
compiler/GHC/Core/Opt/Specialise.hs | 4 ++-
.../tests/simplCore/should_compile/T23567.hs | 10 +++++++
.../tests/simplCore/should_compile/T23567A.hs | 27 +++++++++++++++++++
.../tests/simplCore/should_compile/all.T | 1 +
4 files changed, 41 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/simplCore/should_compile/T23567.hs
create mode 100644 testsuite/tests/simplCore/should_compile/T23567A.hs
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index aec2b5ae8a2..add0a878e06 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1495,7 +1495,9 @@ specBind top_lvl env (NonRec fn rhs) do_body
-- Destroying demand info is not terrible; specialisation is
-- always followed soon by demand analysis.
- body_env2 = body_env1 `extendInScope` fn3
+ body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds
+ `extendInScope` fn3
+ -- bringFloatedDictsIntoScope: see #23567
; (body', body_uds) <- do_body body_env2
diff --git a/testsuite/tests/simplCore/should_compile/T23567.hs b/testsuite/tests/simplCore/should_compile/T23567.hs
new file mode 100644
index 00000000000..eb9110253a3
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23567.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -funfolding-use-threshold=111640 -fmax-simplifier-iterations=2 #-}
+
+module T23567 where
+
+import T23567A
+
+instance (MonadIO m) => CacheRWM2 (ReaderT (StateT m)) where
+ p = runCacheBuildM
+ {-# NOINLINE p #-}
diff --git a/testsuite/tests/simplCore/should_compile/T23567A.hs b/testsuite/tests/simplCore/should_compile/T23567A.hs
new file mode 100644
index 00000000000..084bdba64ea
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23567A.hs
@@ -0,0 +1,27 @@
+module T23567A where
+
+class Appl f where
+ pur :: f
+ ast :: f -> f
+
+class Appl f => Mona f where
+ unused :: f
+
+class Mona f => MonadIO f where
+ unused2 :: f
+
+newtype StateT m = StateT { runStateT :: m }
+ deriving (Mona, MonadIO)
+
+instance (Appl m, Appl m) => Appl (StateT m) where
+ pur = pur
+ ast x = x
+
+newtype ReaderT m = ReaderT { runReaderT :: m }
+ deriving (Appl, Mona, MonadIO)
+
+class CacheRWM2 m where
+ p :: m
+
+runCacheBuildM :: (MonadIO m) => m
+runCacheBuildM = ast pur
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 21e01bb65d1..6f01f62906d 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -490,3 +490,4 @@ test('T23491b', [extra_files(['T23491.hs']), grep_errmsg(r'Float inwards')], mul
test('T23491c', [extra_files(['T23491.hs']), grep_errmsg(r'Liberate case')], multimod_compile, ['T23491', '-fliberate-case -ddump-liberate-case'])
test('T23491d', [extra_files(['T23491.hs']), grep_errmsg(r'Static argument')], multimod_compile, ['T23491', '-fstatic-argument-transformation -ddump-static-argument-transformation'])
test('T23272', [only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -O')], ghci_script, ['T23272.script'])
+test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -v0'])
--
GitLab