From 40f4ef7c40e747dfea491d297475458d2ccaf860 Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Tue, 30 May 2023 11:47:10 +0200
Subject: [PATCH] Substitute free variables captured by breakpoints in
SpecConstr
Fixes #23267
---
compiler/GHC/Core.hs | 2 +-
compiler/GHC/Core/Opt/SpecConstr.hs | 16 ++++++++++++++--
docs/users_guide/using-optimisation.rst | 4 ++--
testsuite/tests/simplCore/should_compile/all.T | 2 +-
4 files changed, 18 insertions(+), 6 deletions(-)
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 6f85f587169e..b8e5532f9b90 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -2129,7 +2129,7 @@ stripNArgs 0 e = Just e
stripNArgs n (App f _) = stripNArgs (n - 1) f
stripNArgs _ _ = Nothing
--- | Like @collectArgs@, but also collects looks through floatable
+-- | Like @collectArgs@, but also looks through floatable
-- ticks if it means that we can find more arguments.
collectArgsTicks :: (CoreTickish -> Bool) -> Expr b
-> (Expr b, [Arg b], [CoreTickish])
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 49ec9b55c1c6..6efec52b23cb 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, LambdaCase #-}
#if __GLASGOW_HASKELL__ < 905
{-# LANGUAGE PatternSynonyms #-}
#endif
@@ -1478,7 +1478,8 @@ scExpr' env (Type t) =
scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
scExpr' _ e@(Lit {}) = return (nullUsage, e)
scExpr' env (Tick t e) = do (usg, e') <- scExpr env e
- return (usg, Tick t e')
+ (usg_t, t') <- scTickish env t
+ return (combineUsage usg usg_t, Tick t' e')
scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
return (usg, mkCast e' (scSubstCo env co))
-- Important to use mkCast here
@@ -1537,6 +1538,17 @@ scExpr' env (Case scrut b ty alts)
; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
+-- | Substitute the free variables captured by a breakpoint.
+-- Variables are dropped if they have a non-variable substitution, like in
+-- 'GHC.Opt.Specialise.specTickish'.
+scTickish :: ScEnv -> CoreTickish -> UniqSM (ScUsage, CoreTickish)
+scTickish env = \case
+ Breakpoint ext i fv modl -> do
+ (usg, fv') <- unzip <$> mapM (\ v -> scExpr env (Var v)) fv
+ pure (combineUsages usg, Breakpoint ext i [v | Var v <- fv'] modl)
+ t@ProfNote {} -> pure (nullUsage, t)
+ t@HpcTick {} -> pure (nullUsage, t)
+ t@SourceNote {} -> pure (nullUsage, t)
{- Note [Do not specialise evals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst
index e747fe7bf779..3b766ea57fe6 100644
--- a/docs/users_guide/using-optimisation.rst
+++ b/docs/users_guide/using-optimisation.rst
@@ -993,8 +993,8 @@ as such you shouldn't need to set any of them explicitly. A flag
last' x (y : ys) = last' y ys
As well avoid unnecessary pattern matching it also helps avoid
- unnecessary allocation. This applies when a argument is strict in
- the recursive call to itself but not on the initial entry. As strict
+ unnecessary allocation. This applies when an argument is strict in
+ the recursive call to itself but not on the initial entry. A strict
recursive branch of the function is created similar to the above
example.
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index c4ff3222a9f4..26542e89f510 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -477,7 +477,7 @@ test('T23012', normal, compile, ['-O'])
test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
test('T23026', normal, compile, ['-O'])
-test('T23267', [expect_broken(23267), only_ways(['ghci-opt']), extra_hc_opts('-fspec-constr')], ghci_script, ['T23267.script'])
+test('T23267', [only_ways(['ghci-opt']), extra_hc_opts('-fspec-constr')], ghci_script, ['T23267.script'])
test('T23362', normal, compile, ['-O'])
test('T23307', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
--
GitLab