[Git][ghc/ghc][master] Substitute free variables captured by breakpoints in SpecConstr

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
40f4ef7c by Torsten Schmits at 2023-07-05T18:06:19-04:00
Substitute free variables captured by breakpoints in SpecConstr

Fixes #23267

- - - - -


4 changed files:

- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- docs/users_guide/using-optimisation.rst
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
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])


=====================================
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 at ProfNote {} -> pure (nullUsage, t)
+  t at HpcTick {} -> pure (nullUsage, t)
+  t at SourceNote {} -> pure (nullUsage, t)
 
 {- Note [Do not specialise evals]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
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.
 


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40f4ef7c40e747dfea491d297475458d2ccaf860

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40f4ef7c40e747dfea491d297475458d2ccaf860
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/20230705/6c313f20/attachment-0001.html>