Fix substitution in bindAuxiliaryDict

In GHC.Core.Opt.Specialise.bindAuxiliaryDict we were unnecessarily
calling `extendInScope` to bring into scope variables that were
/already/ in scope.  Worse, GHC.Core.Subst.extendInScope strangely
deleted the newly-in-scope variables from the substitution -- and that
was fatal in #21391.

I removed the redundant calls to extendInScope.

More ambitiously, I changed GHC.Core.Subst.extendInScope (and cousins)
to stop deleting variables from the substitution.  I even changed the
names of the function to extendSubstInScope (and cousins) and audited
all the calls to check that deleting from the substitution was wrong.
In fact there are very few such calls, and they are all about
introducing a fresh non-in-scope variable.  These are "OutIds"; it is
utterly wrong to mess with the "InId" substitution.

I have not added a Note, because I'm deleting wrong code, and it'd be
distracting to document a bug.

3 files changed, 25 insertions, 18 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index c78285c6f9..6c0729ec5b 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -45,7 +45,7 @@ import GHC.Core.Multiplicity
 -- We have two sorts of substitution:
 --   GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst
 -- Both have substTy, substCo  Hence need for qualification
-import GHC.Core.Subst    as Core hiding ( extendInScopeSet )
+import GHC.Core.Subst    as Core
 import GHC.Core.Type     as Type
 import GHC.Core.Coercion as Type
 
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 90f492ffea..d9429053a0 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -956,7 +956,8 @@ zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
 
 extendScInScope :: ScEnv -> [Var] -> ScEnv
         -- Bring the quantified variables into scope
-extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
+extendScInScope env qvars
+  = env { sc_subst = extendSubstInScopeList (sc_subst env) qvars }
 
         -- Extend the substitution
 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 36ee54b7c0..5c515dd95b 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1307,7 +1307,7 @@ bringFloatedDictsIntoScope env uds =
   env{se_subst=subst'}
   where
    dx_bndrs = ud_bs_of_binds uds
-   subst'   = se_subst env `Core.extendInScopeSet` dx_bndrs
+   subst'   = se_subst env `Core.extendSubstInScopeSet` dx_bndrs
 
 specBind :: SpecEnv                     -- Use this for RHSs
          -> CoreBind                    -- Binders are already cloned by cloneBindSM,
@@ -1516,6 +1516,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
 --                                        , text "spec_args: " <+> ppr spec_args
 --                                        , text "dx_binds:  " <+> ppr dx_binds
 --                                        , text "rhs_env2:  " <+> ppr (se_subst rhs_env2)
+--                                        , text "leftover_bndrs:" <+> pprIds leftover_bndrs
 --                                        , ppr dx_binds ]) $
 --             return ()
 
@@ -2354,6 +2355,9 @@ specHeader env (bndr : bndrs) (SpecType ty : args)
              qvars    = scopedSort $
                         filterOut (`elemInScopeSet` in_scope) $
                         tyCoVarsOfTypeList ty
+             -- qvars are the type variables free in the call that
+             -- are not already in scope.  Quantify over these.
+             -- See Note [Specialising polymorphic dictionaries]
              (env1, qvars') = substBndrs env qvars
              ty'            = substTy env1 ty
              env2           = extendTvSubstList env1 [(bndr, ty')]
@@ -2393,12 +2397,12 @@ specHeader env (bndr : bndrs) (UnspecType : args)
 -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
 -- the nitty-gritty), as a LHS rule and unfolding details.
 specHeader env (bndr : bndrs) (SpecDict d : args)
-  = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
-       ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d
-       ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
-             <- specHeader env' bndrs args
+  = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
+       ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
+       ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+             <- specHeader env2 bndrs args
        ; pure ( True      -- Ha!  A useful specialisation!
-              , env''
+              , env3
               , leftover_bndrs
               -- See Note [Evidence foralls]
               , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs
@@ -2464,9 +2468,9 @@ specHeader env bndrs []
 bindAuxiliaryDict
   :: SpecEnv
   -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression
-  -> ( SpecEnv        -- Substitute for orig_dict_id
+  -> ( SpecEnv        -- Substitutes for orig_dict_id
      , Maybe DictBind -- Auxiliary dict binding, if any
-     , OutExpr)        -- Witnessing expression (always trivial)
+     , OutExpr)       -- Witnessing expression (always trivial)
 bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
                   orig_dict_id fresh_dict_id dict_expr
 
@@ -2474,7 +2478,6 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
   -- don’t bother creating a new dict binding; just substitute
   | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr
   = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr
-                                `Core.extendInScope` dict_id
                           -- See Note [Keep the old dictionaries interesting]
                    , se_interesting = interesting `extendVarSet` dict_id }
     in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $
@@ -2486,8 +2489,8 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
           -- See Note [Specialisation modulo dictionary selectors] for the unfolding
         dict_bind = mkDB (NonRec fresh_dict_id' dict_expr)
         env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')
-                                `Core.extendInScope`     fresh_dict_id'
-                                `Core.extendInScopeList` exprFreeVarsList dict_expr
+                                `Core.extendSubstInScope` fresh_dict_id'
+                                -- Ensure the new unfolding is in the in-scope set
                       -- See Note [Make the new dictionaries interesting]
                    , se_interesting = interesting `extendVarSet` fresh_dict_id' }
     in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id' $$ ppr dict_expr $$ ppr (exprFreeVarsList dict_expr)) $
@@ -3184,13 +3187,16 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pai
                                            [ v | (v,r) <- pairs, typeDeterminesValue (idType v), interestingDict env r ] }
        ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }
 
-newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
+newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr)
 -- Make up completely fresh binders for the dictionaries
 -- Their bindings are going to float outwards
-newDictBndr env b = do { uniq <- getUniqueM
-                        ; let n   = idName b
-                              ty' = substTy env (idType b)
-                        ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) }
+newDictBndr env@(SE { se_subst = subst }) b
+  = do { uniq <- getUniqueM
+       ; let n    = idName b
+             ty'  = Core.substTy subst (idType b)
+             b'   = mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)
+             env' = env { se_subst = subst `Core.extendSubstInScope` b' }
+       ; pure (env', b') }
 
 newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
     -- Give the new Id a similar occurrence name to the old one