From d3874407df4223a5e14a43571f4cc344349a537d Mon Sep 17 00:00:00 2001
From: Torsten Schmits <git@tryp.io>
Date: Wed, 2 Aug 2023 19:35:37 +0200
Subject: [PATCH] Fix several mistakes around free variables in iface
breakpoints
Fixes #23612 , #23607, #23998 and #23666.
MR: !11026
The fingerprinting logic in `Iface.Recomp` failed lookups when processing decls containing breakpoints for two reasons:
* IfaceBreakpoint created binders for free variables instead of expressions
* When collecting free names for the dependency analysis for fingerprinting, breakpoint FVs were skipped
---
compiler/GHC/Core/Opt/SpecConstr.hs | 13 +++---------
compiler/GHC/Core/Opt/Specialise.hs | 7 ++-----
compiler/GHC/Core/Subst.hs | 2 ++
compiler/GHC/CoreToIface.hs | 2 +-
compiler/GHC/Iface/Syntax.hs | 9 +++++++--
compiler/GHC/IfaceToCore.hs | 4 ++--
testsuite/tests/ghci/T23612/T23612.hs | 23 ++++++++++++++++++++++
testsuite/tests/ghci/T23612/T23612.script | 1 +
testsuite/tests/ghci/T23612/T23612b.script | 1 +
testsuite/tests/ghci/T23612/T23612bA.hs | 5 +++++
testsuite/tests/ghci/T23612/T23612bB.hs | 5 +++++
testsuite/tests/ghci/T23612/all.T | 2 ++
12 files changed, 54 insertions(+), 20 deletions(-)
create mode 100644 testsuite/tests/ghci/T23612/T23612.hs
create mode 100644 testsuite/tests/ghci/T23612/T23612.script
create mode 100644 testsuite/tests/ghci/T23612/T23612b.script
create mode 100644 testsuite/tests/ghci/T23612/T23612bA.hs
create mode 100644 testsuite/tests/ghci/T23612/T23612bB.hs
create mode 100644 testsuite/tests/ghci/T23612/all.T
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 1721496f03b6..09460812a435 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1480,8 +1480,7 @@ 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
- (usg_t, t') <- scTickish env t
- return (combineUsage usg usg_t, Tick t' e')
+ return (usg, Tick (scTickish env 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
@@ -1543,14 +1542,8 @@ scExpr' env (Case scrut b ty alts)
-- | 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)
+scTickish :: ScEnv -> CoreTickish -> CoreTickish
+scTickish SCE {sc_subst = subst} = substTickish subst
{- Note [Do not specialise evals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index f36eb67af603..29688e709eeb 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -67,6 +67,7 @@ import GHC.Core.Unfold
import Data.List( partition )
import Data.List.NonEmpty ( NonEmpty (..) )
+import GHC.Core.Subst (substTickish)
{-
************************************************************************
@@ -1267,11 +1268,7 @@ specLam env bndrs body
--------------
specTickish :: SpecEnv -> CoreTickish -> CoreTickish
-specTickish (SE { se_subst = subst }) (Breakpoint ext ix ids modl)
- = Breakpoint ext ix [ id' | id <- ids, Var id' <- [Core.lookupIdSubst subst id]] modl
- -- drop vars from the list if they have a non-variable substitution.
- -- should never happen, but it's harmless to drop them anyway.
-specTickish _ other_tickish = other_tickish
+specTickish (SE { se_subst = subst }) bp = substTickish subst bp
--------------
specCase :: SpecEnv
diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index c84f72989c48..23c643b142a7 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -589,11 +589,13 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs
= exprFVs fv_expr (const True) emptyVarSet $! acc
------------------
+-- | Drop free vars from the breakpoint if they have a non-variable substitution.
substTickish :: Subst -> CoreTickish -> CoreTickish
substTickish subst (Breakpoint ext n ids modl)
= Breakpoint ext n (mapMaybe do_one ids) modl
where
do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst
+
substTickish _subst other = other
{- Note [Substitute lazily]
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index c03be313abc1..02feadd85f2d 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -574,7 +574,7 @@ toIfaceTickish (HpcTick modl ix) = IfaceHpcTick modl ix
toIfaceTickish (SourceNote src (LexicalFastString names)) =
IfaceSource src names
toIfaceTickish (Breakpoint _ ix fv m) =
- IfaceBreakpoint ix (toIfaceIdBndr <$> fv) m
+ IfaceBreakpoint ix (toIfaceVar <$> fv) m
---------------------
toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index f1a1cf8b64c1..ebea95e3ad08 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -635,7 +635,7 @@ data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
| IfaceSCC CostCentre Bool Bool -- from ProfNote
| IfaceSource RealSrcSpan FastString -- from SourceNote
- | IfaceBreakpoint Int [IfaceIdBndr] Module -- from Breakpoint
+ | IfaceBreakpoint Int [IfaceExpr] Module -- from Breakpoint
data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr
-- Note: IfLclName, not IfaceBndr (and same with the case binder)
@@ -1844,7 +1844,7 @@ freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
-freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
+freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
freeNamesIfExpr (IfaceCase s _ alts)
= freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts
@@ -1891,6 +1891,11 @@ freeNamesIfaceTyConParent IfNoParent = emptyNameSet
freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
= unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys
+freeNamesIfTickish :: IfaceTickish -> NameSet
+freeNamesIfTickish (IfaceBreakpoint _ fvs _) =
+ fnList freeNamesIfExpr fvs
+freeNamesIfTickish _ = emptyNameSet
+
-- helpers
(&&&) :: NameSet -> NameSet -> NameSet
(&&&) = unionNameSet
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index c51849029ca0..2150d9a79150 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1624,8 +1624,8 @@ tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name))
tcIfaceTickish (IfaceBreakpoint ix fvs modl) = do
- fvs' <- bindIfaceIds fvs pure
- return (Breakpoint NoExtField ix fvs' modl)
+ fvs' <- mapM tcIfaceExpr fvs
+ return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl)
-------------------------
tcIfaceLit :: Literal -> IfL Literal
diff --git a/testsuite/tests/ghci/T23612/T23612.hs b/testsuite/tests/ghci/T23612/T23612.hs
new file mode 100644
index 000000000000..e8f478f52932
--- /dev/null
+++ b/testsuite/tests/ghci/T23612/T23612.hs
@@ -0,0 +1,23 @@
+module T23612 where
+
+-- | This will be inlined into @f2@.
+-- Then @a@, @x@, and @y@ will be floated out as constants using @3@ for @a@.
+-- @x@ and @y@ get a breakpoint around the RHS, which is then inlined and
+-- retains a reference to @a@.
+--
+-- Since the actual terms in @x@ and @y@ are now constants, the dependency
+-- analysis for fingerprinting in Recomp doesn't register @a@ as a free variable
+-- anymore.
+-- But when the fingerprints are computed, the breakpoint triggers a lookup of
+-- @a@ (called @f2_a@ then), which fails.
+--
+-- The fix was to include the FVs in the dependencies in @freeNamesIfExpr@.
+-- This has the side effect that the floated out @a@ will still remain in the
+-- program.
+f1 :: Int -> (Int, Int)
+f1 a =
+ let x = a + 1
+ y = a * 2
+ in (x, y)
+
+f2 = f1 3
diff --git a/testsuite/tests/ghci/T23612/T23612.script b/testsuite/tests/ghci/T23612/T23612.script
new file mode 100644
index 000000000000..930848389221
--- /dev/null
+++ b/testsuite/tests/ghci/T23612/T23612.script
@@ -0,0 +1 @@
+:load T23612
diff --git a/testsuite/tests/ghci/T23612/T23612b.script b/testsuite/tests/ghci/T23612/T23612b.script
new file mode 100644
index 000000000000..da6212754569
--- /dev/null
+++ b/testsuite/tests/ghci/T23612/T23612b.script
@@ -0,0 +1 @@
+:load T23612bB
diff --git a/testsuite/tests/ghci/T23612/T23612bA.hs b/testsuite/tests/ghci/T23612/T23612bA.hs
new file mode 100644
index 000000000000..4c677b5145aa
--- /dev/null
+++ b/testsuite/tests/ghci/T23612/T23612bA.hs
@@ -0,0 +1,5 @@
+module T23612bA where
+
+class C a where
+ c :: a -> a
+ c a = a
diff --git a/testsuite/tests/ghci/T23612/T23612bB.hs b/testsuite/tests/ghci/T23612/T23612bB.hs
new file mode 100644
index 000000000000..9a322c3762b4
--- /dev/null
+++ b/testsuite/tests/ghci/T23612/T23612bB.hs
@@ -0,0 +1,5 @@
+module T23612bB where
+
+import T23612bA
+
+instance C Bool
diff --git a/testsuite/tests/ghci/T23612/all.T b/testsuite/tests/ghci/T23612/all.T
new file mode 100644
index 000000000000..0f14b6490d10
--- /dev/null
+++ b/testsuite/tests/ghci/T23612/all.T
@@ -0,0 +1,2 @@
+test('T23612', only_ways(['ghci-opt']), ghci_script, ['T23612.script'])
+test('T23612b', [only_ways(['ghci-opt']), extra_files(['T23612bA.hs', 'T23612bB.hs'])], ghci_script, ['T23612b.script'])
--
GitLab