From 996065bc5b02c8739400b363676e71e9837b3f87 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 9 Nov 2021 13:49:56 +0000
Subject: Get the in-scope set right in simplArg

This was a simple (but long standing) error in simplArg,
revealed by #20639
---
 compiler/GHC/Core/Opt/Simplify.hs                  |  7 ++++--
 testsuite/tests/simplCore/should_compile/T20639.hs | 27 ++++++++++++++++++++++
 testsuite/tests/simplCore/should_compile/all.T     |  1 +
 3 files changed, 33 insertions(+), 2 deletions(-)
 create mode 100644 testsuite/tests/simplCore/should_compile/T20639.hs

diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 407f84a6c5..8ce2eb857a 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -1584,8 +1584,11 @@ simplArg env dup_flag arg_env arg
   | isSimplified dup_flag
   = return (dup_flag, arg_env, arg)
   | otherwise
-  = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg
-       ; return (Simplified, zapSubstEnv arg_env, arg') }
+  = do { let arg_env' = arg_env `setInScopeFromE` env
+       ; arg' <- simplExpr arg_env'  arg
+       ; return (Simplified, zapSubstEnv arg_env', arg') }
+         -- Return a StaticEnv that includes the in-scope set from 'env',
+         -- because arg' may well mention those variables (#20639)
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/simplCore/should_compile/T20639.hs b/testsuite/tests/simplCore/should_compile/T20639.hs
new file mode 100644
index 0000000000..4ccb998c9d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20639.hs
@@ -0,0 +1,27 @@
+module CtxRed(ctxRedCQType', CtxRed(..)) where
+
+import Control.Monad.State
+import Control.Monad.Except
+
+type TI = StateT Bool (ExceptT [Integer] (State Bool))
+
+data CDefn = Cclass (Maybe Bool) [CPred]
+data CQType = CQType [CPred]
+data CTypeclass = CTypeclass
+data CPred = CPred CTypeclass
+
+class CtxRed a where
+    ctxRed :: a -> TI a
+
+instance CtxRed CDefn where
+    ctxRed d@(Cclass incoh cpreds) = do
+       (CQType _) <- ctxRedCQType' (CQType [])
+       return (Cclass incoh cpreds)
+
+ctxRedCQType' :: CQType -> TI (CQType)
+ctxRedCQType' cqt = do
+    let CQType cqs = cqt
+    case [p | p@(CPred CTypeclass) <- cqs] of
+      p : _ -> return ()
+      [] -> return ()
+    return (cqt)
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 3b75f2b7a5..d500b5364a 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -376,3 +376,4 @@ test('T20200', normal, compile, [''])
 test('T20200a', normal, compile, ['-O2'])
 test('T20200b', normal, compile, ['-O2'])
 test('T20200KG', [extra_files(['T20200KGa.hs', 'T20200KG.hs-boot'])], multimod_compile, ['T20200KG', '-v0 -O2 -fspecialise-aggressively'])
+test('T20639', normal, compile, ['-O2'])
-- 
cgit v1.2.1