From 6abf36483a41e50579afcea1497f502875693913 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Mon, 22 May 2023 20:34:07 +0100
Subject: [PATCH] Avoid an assertion failure in abstractFloats
The function GHC.Core.Opt.Simplify.Utils.abstractFloats
was carelessly calling lookupIdSubst_maybe on a CoVar;
but a precondition of the latter is being given an Id.
In fact it's harmless to call it on a CoVar, but still, the
precondition on lookupIdSubst_maybe makes sense, so I added
a test for CoVars.
This avoids a crash in a DEBUG compiler, but otherwise has
no effect. Fixes #23426.
---
compiler/GHC/Core/Opt/Simplify/Utils.hs | 3 +++
testsuite/tests/simplCore/should_compile/T23426.hs | 8 ++++++++
testsuite/tests/simplCore/should_compile/all.T | 2 +-
3 files changed, 12 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/simplCore/should_compile/T23426.hs
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 7eb4692231cb..c56d86d6ceff 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -2143,6 +2143,9 @@ abstractFloats uf_opts top_lvl main_tvs floats body
get_tvs var free_tvs
| isTyVar var -- CoVars have been substituted away
= extendVarSet free_tvs var
+ | isCoVar var -- CoVars can be free in the RHS, but they are never let-bound;
+ = free_tvs -- Do not call lookupIdSubst_maybe, though (#23426)
+ -- because it has a non-CoVar precondition
| Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var
= -- 'var' is like 'x' in (AB4)
exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs
diff --git a/testsuite/tests/simplCore/should_compile/T23426.hs b/testsuite/tests/simplCore/should_compile/T23426.hs
new file mode 100644
index 000000000000..17651c8c4a63
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23426.hs
@@ -0,0 +1,8 @@
+module T23426 where
+
+class (Char ~ a) => ListLike a where
+ mnull :: a -> b
+
+indent :: forall a. (ListLike a) => a -> Bool
+indent x = let doText y = const (mnull y) doText
+ in const (doText x) doText
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index b1ec7473ffec..3c5eddeb688d 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -483,4 +483,4 @@ test('T23307', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress
test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
test('T23307b', normal, compile, ['-O'])
test('T23307c', normal, compile, ['-O'])
-
+test('T23426', normal, compile, ['-O'])
--
GitLab