[commit: ghc] ghc-8.0: Use the correct substitution in lintCoercion (b7ee635)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/b7ee63556c14adbf793b30a65e2cc6770023b7c2/ghc

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

commit b7ee63556c14adbf793b30a65e2cc6770023b7c2
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
    
    (cherry picked from commit 4a93e4f9a86a62d1cdf2e666f977b8b58e61eaaf)


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

b7ee63556c14adbf793b30a65e2cc6770023b7c2
 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 59673ae..64543f9 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1273,9 +1273,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 acff6a2..165350d 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,
@@ -1668,6 +1669,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 7b5922f..47a234e 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,