diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T20639.hs | 27 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
3 files changed, 33 insertions, 2 deletions
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']) |