[Git][ghc/ghc][wip/torsten.schmits/23612] Fix several mistakes around free variables in iface breakpoints

Torsten Schmits (@torsten.schmits) gitlab at gitlab.haskell.org
Fri Sep 29 14:59:51 UTC 2023



Torsten Schmits pushed to branch wip/torsten.schmits/23612 at Glasgow Haskell Compiler / GHC


Commits:
429af25f by Torsten Schmits at 2023-09-29T16:59:40+02: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/429af25fd6faa0f68c57b904606ba88327110dd7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/429af25fd6faa0f68c57b904606ba88327110dd7
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/20230929/252fd027/attachment-0001.html>


More information about the ghc-commits mailing list