[Git][ghc/ghc][master] Fix several mistakes around free variables in iface breakpoints
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Sep 30 20:09:39 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d3874407 by Torsten Schmits at 2023-09-30T16:08:10-04:00
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
- - - - -
12 changed files:
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- + testsuite/tests/ghci/T23612/T23612.hs
- + testsuite/tests/ghci/T23612/T23612.script
- + testsuite/tests/ghci/T23612/T23612b.script
- + testsuite/tests/ghci/T23612/T23612bA.hs
- + testsuite/tests/ghci/T23612/T23612bB.hs
- + testsuite/tests/ghci/T23612/all.T
Changes:
=====================================
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 at ProfNote {} -> pure (nullUsage, t)
- t at HpcTick {} -> pure (nullUsage, t)
- t at SourceNote {} -> pure (nullUsage, t)
+scTickish :: ScEnv -> CoreTickish -> CoreTickish
+scTickish SCE {sc_subst = subst} = substTickish subst
{- Note [Do not specialise evals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
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
=====================================
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]
=====================================
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
=====================================
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
=====================================
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
=====================================
testsuite/tests/ghci/T23612/T23612.hs
=====================================
@@ -0,0 +1,23 @@
+module T23612 where
+
+-- | This will be inlined into @f2 at .
+-- Then @a@, @x@, and @y@ will be floated out as constants using @3@ for @a at .
+-- @x@ and @y@ get a breakpoint around the RHS, which is then inlined and
+-- retains a reference to @a at .
+--
+-- 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 at .
+-- 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
=====================================
testsuite/tests/ghci/T23612/T23612.script
=====================================
@@ -0,0 +1 @@
+:load T23612
=====================================
testsuite/tests/ghci/T23612/T23612b.script
=====================================
@@ -0,0 +1 @@
+:load T23612bB
=====================================
testsuite/tests/ghci/T23612/T23612bA.hs
=====================================
@@ -0,0 +1,5 @@
+module T23612bA where
+
+class C a where
+ c :: a -> a
+ c a = a
=====================================
testsuite/tests/ghci/T23612/T23612bB.hs
=====================================
@@ -0,0 +1,5 @@
+module T23612bB where
+
+import T23612bA
+
+instance C Bool
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3874407df4223a5e14a43571f4cc344349a537d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3874407df4223a5e14a43571f4cc344349a537d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230930/a85ddac3/attachment-0001.html>
More information about the ghc-commits
mailing list