From 67c9fee8910e4549d73d6c468bfbd76350df41fb Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 28 Jun 2022 15:06:16 +0100
Subject: Fix a scoping bug in the Specialiser

In the call to `specLookupRule` in `already_covered`, in `specCalls`,
we need an in-scope set that includes the free vars of the arguments.
But we simply were not guaranteeing that: did not include the
`rule_bndrs`.

Easily fixed.  I'm not sure how how this bug has lain for quite
so long without biting us.

Fixes #21828.
---
 compiler/GHC/Core/Opt/Specialise.hs | 34 ++++++++++++++++++----------------
 compiler/GHC/Core/Rules.hs          |  2 +-
 2 files changed, 19 insertions(+), 17 deletions(-)

diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index c256ac3d55..ab72537005 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1158,9 +1158,10 @@ specExpr env (Let bind body)
 rewriteClassOps :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])
 rewriteClassOps env (Var f) args
   | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt`
-  , Just (rule, expr) <- specLookupRule env f args (idCoreRules f)
+  , Just (rule, expr) <- -- pprTrace "rewriteClassOps" (ppr f $$ ppr args $$ ppr (se_subst env)) $
+                         specLookupRule env f args (idCoreRules f)
   , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target]
-  -- , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True
+--  , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True
   , (fun, args) <- collectArgs expr
   = rewriteClassOps env fun (args++rest_args)
 rewriteClassOps _ fun args = (fun, args)
@@ -1490,10 +1491,9 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
     -- Bring into scope the binders from the floated dicts
     env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds
 
-    already_covered :: [CoreRule] -> [CoreExpr] -> Bool
-    already_covered new_rules args      -- Note [Specialisations already covered]
-       = isJust (specLookupRule env_with_dict_bndrs fn args
-                                (new_rules ++ existing_rules))
+    already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
+    already_covered env new_rules args      -- Note [Specialisations already covered]
+       = isJust (specLookupRule env fn args (new_rules ++ existing_rules))
          -- NB: we look both in the new_rules (generated by this invocation
          --     of specCalls), and in existing_rules (passed in to specCalls)
 
@@ -1515,21 +1515,22 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
              , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs
                                                                rhs_bndrs all_call_args
 
---           ; pprTrace "spec_call" (vcat [ text "fun:       " <+> ppr fn
---                                        , text "call info: " <+> ppr _ci
---                                        , text "useful:    " <+> ppr useful
---                                        , text "rule_bndrs:" <+> ppr rule_bndrs
---                                        , text "lhs_args:  " <+> ppr rule_lhs_args
---                                        , text "spec_bndrs:" <+> ppr spec_bndrs1
---                                        , text "spec_args: " <+> ppr spec_args
---                                        , text "dx_binds:  " <+> ppr dx_binds
---                                        , text "rhs_env2:  " <+> ppr (se_subst rhs_env2)
+--           ; pprTrace "spec_call" (vcat [ text "fun:       "  <+> ppr fn
+--                                        , text "call info: "  <+> ppr _ci
+--                                        , text "useful:    "  <+> ppr useful
+--                                        , text "rule_bndrs:"  <+> ppr rule_bndrs
+--                                        , text "lhs_args:  "  <+> ppr rule_lhs_args
+--                                        , text "spec_bndrs1:" <+> ppr spec_bndrs1
 --                                        , text "leftover_bndrs:" <+> pprIds leftover_bndrs
+--                                        , text "spec_args: "  <+> ppr spec_args
+--                                        , text "dx_binds:  "  <+> ppr dx_binds
+--                                        , text "rhs_body"     <+> ppr rhs_body
+--                                        , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)
 --                                        , ppr dx_binds ]) $
 --             return ()
 
            ; if not useful  -- No useful specialisation
-                || already_covered rules_acc rule_lhs_args
+                || already_covered rhs_env2 rules_acc rule_lhs_args
              then return spec_acc
              else
         do { -- Run the specialiser on the specialised RHS
@@ -1633,6 +1634,7 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
                     ) } }
 
 -- Convenience function for invoking lookupRule from Specialise
+-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]
 specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 specLookupRule env fn args rules
   = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 451d1ac5c1..444ed1e50b 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -395,7 +395,7 @@ lookupRule :: RuleOpts -> InScopeEnv
 -- See Note [Extra args in the target]
 -- See comments on matchRule
 lookupRule opts rule_env@(in_scope,_) is_active fn args rules
-  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
+  = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $
     case go [] rules of
         []     -> Nothing
         (m:ms) -> Just (findBest in_scope (fn,args') m ms)
-- 
cgit v1.2.1