[commit: ghc] master: Use the correct substitution in lintCoercion (4a93e4f)

[git at git.haskell.org]

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

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

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

commit 4a93e4f9a86a62d1cdf2e666f977b8b58e61eaaf
Author: Bartosz Nitka <niteria at gmail.com>
Date:   Tue Mar 29 12:42:32 2016 +0200

    Use the correct substitution in lintCoercion
    
    We need the free vars of `t2` to satisfy the substitution
    invariant. Luckily they are in the in-scope carried around.
    
    Test Plan: ./validate
    
    Reviewers: bgamari, austin, goldfire, simonpj
    
    Reviewed By: simonpj
    
    Subscribers: thomie, simonmar
    
    Differential Revision: https://phabricator.haskell.org/D2044
    
    GHC Trac Issues: #11371


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

4a93e4f9a86a62d1cdf2e666f977b8b58e61eaaf
 compiler/coreSyn/CoreLint.hs | 7 ++++++-
 compiler/types/TyCoRep.hs    | 5 +++++
 compiler/types/Type.hs       | 1 +
 3 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index ef44aff..bd750a3 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1291,9 +1291,14 @@ lintCoercion (ForAllCo tv1 kind_co co)
   = do { (_, k2) <- lintStarCoercion kind_co
        ; let tv2 = setTyVarKind tv1 k2
        ; (k3, k4, t1, t2, r) <- addInScopeVar tv1 $ lintCoercion co
+       ; in_scope <- getInScope
        ; let tyl = mkNamedForAllTy tv1 Invisible t1
+             subst = zipTvSubst [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo kind_co]
+                     `extendTCvInScopeInScope` in_scope
+             -- We need free vars of `t2` in scope to satisfy
+             -- Note [The substitution invariant]
              tyr = mkNamedForAllTy tv2 Invisible $
-                   substTyWithUnchecked [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo kind_co] t2
+                   substTy subst t2
        ; return (k3, k4, tyl, tyr, r) }
 
 lintCoercion (CoVarCo cv)
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 6cbdfda..46214e8 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -83,6 +83,7 @@ module TyCoRep (
         getCvSubstEnv, getTCvInScope, isInScope, notElemTCvSubst,
         setTvSubstEnv, setCvSubstEnv, zapTCvSubst,
         extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,
+        extendTCvInScopeInScope,
         extendTCvSubst,
         extendCvSubst, extendCvSubstWithClone,
         extendTvSubst, extendTvSubstWithClone,
@@ -1798,6 +1799,10 @@ extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst
 extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars
   = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv
 
+extendTCvInScopeInScope :: TCvSubst -> InScopeSet -> TCvSubst
+extendTCvInScopeInScope (TCvSubst in_scope tenv cenv) in_scope'
+  = TCvSubst (unionInScope in_scope in_scope') tenv cenv
+
 extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst
 extendTCvSubst subst v ty
   | isTyVar v
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index c5561a3..a940200 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -158,6 +158,7 @@ module Type (
         getTvSubstEnv, setTvSubstEnv,
         zapTCvSubst, getTCvInScope,
         extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,
+        extendTCvInScopeInScope,
         extendTCvSubst, extendCvSubst,
         extendTvSubst, extendTvSubstList, extendTvSubstAndInScope,
         isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv,