[commit: ghc] master: Get the right in-scope set in specUnfolding (4ddfe13)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4ddfe1352e20d805a0ad6eeea0400ee218023bfb/ghc

>---------------------------------------------------------------

commit 4ddfe1352e20d805a0ad6eeea0400ee218023bfb
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Feb 25 15:55:56 2016 +0000

    Get the right in-scope set in specUnfolding
    
    This fixes Trac #11600


>---------------------------------------------------------------

4ddfe1352e20d805a0ad6eeea0400ee218023bfb
 compiler/coreSyn/CoreUnfold.hs    |  4 ++++
 compiler/specialise/Specialise.hs | 21 ++++++++++++++++-----
 2 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index 48cdb5e..7dde2c0 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -149,6 +149,10 @@ mkInlinableUnfolding dflags expr
 
 specUnfolding :: DynFlags -> Subst -> [Var] -> [CoreExpr] -> Unfolding -> Unfolding
 -- See Note [Specialising unfoldings]
+-- specUnfolding subst new_bndrs spec_args unf
+--   = \new_bndrs. (subst( unf ) spec_args)
+--
+-- Precondition: in-scope(subst) `superset` fvs( spec_args )
 specUnfolding _ subst new_bndrs spec_args
               df@(DFunUnfolding { df_bndrs = bndrs, df_con = con , df_args = args })
   = ASSERT2( length bndrs >= length spec_args, ppr df $$ ppr spec_args $$ ppr new_bndrs )
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index a8380d8..477092e 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -1309,9 +1309,17 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
                   = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding)
 
                   | otherwise
-                  = (inl_prag, specUnfolding dflags (se_subst env)
-                                             poly_tyvars (ty_args ++ spec_dict_args)
-                                             fn_unf)
+                  = (inl_prag, specUnfolding dflags spec_unf_subst poly_tyvars
+                                             spec_unf_args fn_unf)
+
+                spec_unf_args  = ty_args ++ spec_dict_args
+                spec_unf_subst = CoreSubst.setInScope (se_subst env)
+                                    (CoreSubst.substInScope (se_subst rhs_env2))
+                  -- Extend the in-scope set to satisfy the precondition of
+                  -- specUnfolding, namely that in-scope(unf_subst) includes
+                  -- the free vars of spec_unf_args.  The in-scope set of rhs_env2
+                  -- is just the ticket; but the actual substitution we want is
+                  -- the same old one from 'env'
 
                 --------------------------------------
                 -- Adding arity information just propagates it a bit faster
@@ -1357,9 +1365,12 @@ bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
   = (env', dx_binds, spec_dict_args)
   where
     (dx_binds, spec_dict_args) = go call_ds inst_dict_ids
-    env' = env { se_subst = CoreSubst.extendIdSubstList subst (orig_dict_ids `zip` spec_dict_args)
+    env' = env { se_subst = subst `CoreSubst.extendIdSubstList`
+                                     (orig_dict_ids `zip` spec_dict_args)
+                                  `CoreSubst.extendInScopeList` dx_ids
                , se_interesting = interesting `unionVarSet` interesting_dicts }
 
+    dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]
     interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds
                                  , interestingDict env dx ]
                   -- See Note [Make the new dictionaries interesting]
@@ -1367,7 +1378,7 @@ bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
     go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])
     go [] _  = ([], [])
     go (dx:dxs) (dx_id:dx_ids)
-      | exprIsTrivial dx = (dx_binds, dx:args)
+      | exprIsTrivial dx = (dx_binds,                          dx        : args)
       | otherwise        = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)
       where
         (dx_binds, args) = go dxs dx_ids