[commit: ghc] master: Make Lint check that for CoVars more carefully (e7ff934)

[git at git.haskell.org]

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

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

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

commit e7ff9344a18c58c7b321566545fd37c10c609fb1
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Oct 3 13:28:04 2018 +0100

    Make Lint check that for CoVars more carefully
    
    Check than an Id of type (t1 ~# t2) is a CoVar; if not,
    it ends up in the wrong simplifier environment, with
    strange consequences. (Trac #15648)


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

e7ff9344a18c58c7b321566545fd37c10c609fb1
 compiler/coreSyn/CoreLint.hs | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index f879a30..1cbfcd6 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -749,7 +749,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body)
   | isId bndr
   = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
         ; addLoc (BodyOfLetRec [bndr])
-                 (lintIdBndr NotTopLevel LetBind bndr $ \_ ->
+                 (lintBinder LetBind bndr $ \_ ->
                   addGoodJoins [bndr] $
                   lintCoreExpr body) }
 
@@ -826,7 +826,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
      ; subst <- getTCvSubst
      ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
 
-     ; lintIdBndr NotTopLevel CaseBind var $ \_ ->
+     ; lintBinder CaseBind var $ \_ ->
        do { -- Check the alternatives
             mapM_ (lintCoreAlt scrut_ty alt_ty) alts
           ; checkCaseAlts e scrut_ty alts
@@ -1247,6 +1247,7 @@ lintIdBndr top_lvl bind_site id linterF
            (mkNonTopExternalNameMsg id)
 
        ; (ty, k) <- lintInTy (idType id)
+
           -- See Note [Levity polymorphism invariants] in CoreSyn
        ; lintL (isJoinId id || not (isKindLevPoly k))
            (text "Levity-polymorphic binder:" <+>
@@ -1257,6 +1258,11 @@ lintIdBndr top_lvl bind_site id linterF
          checkL (not is_top_lvl && is_let_bind) $
          mkBadJoinBindMsg id
 
+       -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);
+       -- if so, it should be a CoVar, and checked by lintCoVarBndr
+       ; lintL (not (isCoercionType ty))
+               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr ty)
+
        ; let id' = setIdType id ty
        ; addInScopeVar id' $ (linterF id') }
   where