diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2018-10-03 13:28:04 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2018-10-04 15:37:58 +0100 |
| commit | e7ff9344a18c58c7b321566545fd37c10c609fb1 (patch) | |
| tree | 671b6aab39ac6886cee6353d77b3db7be68d40f8 | |
| parent | 43c2ffe7c0ce85a8e1305cea3be453fd01de5b63 (diff) | |
| download | haskell-e7ff9344a18c58c7b321566545fd37c10c609fb1.tar.gz | |
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)
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 10 |
1 files changed, 8 insertions, 2 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index f879a30300..1cbfcd6c50 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 |