Fix two separate bugs in CoreLint, both relating to the fact that the substitution
it carries must be applied exactly once.
This cures a lint crash in Text.ParserCombinators.Parsec.Perm, which was triggered
by -O2; specifically, SpecConstr generated some terms with heavy shadowing of type
variables.
import CoreSyn
import CoreFVs ( idFreeVars )
import CoreSyn
import CoreFVs ( idFreeVars )
-import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
+import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize )
import Unify ( coreRefineTys )
import Bag
import Literal ( literalType )
import Unify ( coreRefineTys )
import Bag
import Literal ( literalType )
import Type ( Type, tyVarsOfType, coreEqType,
splitFunTy_maybe, mkTyVarTys,
splitForAllTy_maybe, splitTyConApp_maybe,
import Type ( Type, tyVarsOfType, coreEqType,
splitFunTy_maybe, mkTyVarTys,
splitForAllTy_maybe, splitTyConApp_maybe,
- isUnLiftedType, typeKind,
+ isUnLiftedType, typeKind, mkForAllTy, mkFunTy,
isUnboxedTupleType, isSubKind,
substTyWith, emptyTvSubst, extendTvInScope,
TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
isUnboxedTupleType, isSubKind,
substTyWith, emptyTvSubst, extendTvInScope,
TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
+type InType = Type -- Substitution not yet applied
+type OutType = Type -- Substitution has been applied to this
-lintCoreExpr :: CoreExpr -> LintM Type
+lintCoreExpr :: CoreExpr -> LintM OutType
-- The returned type has the substitution from the monad
-- already applied to it:
-- lintCoreExpr e subst = exprType (subst e)
-- The returned type has the substitution from the monad
-- already applied to it:
-- lintCoreExpr e subst = exprType (subst e)
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
- do { lintBinder var
- ; ty <- addInScopeVars [var] $
- lintCoreExpr expr
- ; applySubst (mkPiType var ty) }
+ do { body_ty <- addInScopeVars [var] $
+ lintCoreExpr expr
+ ; if isId var then do
+ { var_ty <- lintId var
+ ; return (mkFunTy var_ty body_ty) }
+ else
+ return (mkForAllTy var body_ty)
+ }
-- The applySubst is needed to apply the subst to var
lintCoreExpr e@(Case scrut var alt_ty alts) =
-- The applySubst is needed to apply the subst to var
lintCoreExpr e@(Case scrut var alt_ty alts) =
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
-checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
-- a) Check that the alts are non-empty
-- b1) Check that the DEFAULT comes first, if it exists
-- b2) Check that the others are in increasing order
-- a) Check that the alts are non-empty
-- b1) Check that the DEFAULT comes first, if it exists
-- b2) Check that the others are in increasing order
-checkAltExpr :: CoreExpr -> Type -> LintM ()
-checkAltExpr expr ty
+checkAltExpr :: CoreExpr -> OutType -> LintM ()
+checkAltExpr expr ann_ty
= do { actual_ty <- lintCoreExpr expr
= do { actual_ty <- lintCoreExpr expr
- ; ty' <- applySubst ty
- ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
+ ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
lintCoreAlt :: Type -- Type of scrutinee; a fixed point of
-- the substitution
lintCoreAlt :: Type -- Type of scrutinee; a fixed point of
-- the substitution
lintBinder var | isId var = lintId var >> return ()
| otherwise = return ()
lintBinder var | isId var = lintId var >> return ()
| otherwise = return ()
-lintId :: Var -> LintM Type
+lintId :: Var -> LintM OutType
-- ToDo: lint its rules
lintId id
= do { checkL (not (isUnboxedTupleType (idType id)))
-- ToDo: lint its rules
lintId id
= do { checkL (not (isUnboxedTupleType (idType id)))
-- No variable can be bound to an unboxed tuple.
; lintTy (idType id) }
-- No variable can be bound to an unboxed tuple.
; lintTy (idType id) }
-lintTy :: Type -> LintM Type
+lintTy :: InType -> LintM OutType
-- Check the type, and apply the substitution to it
-- ToDo: check the kind structure of the type
lintTy ty
-- Check the type, and apply the substitution to it
-- ToDo: check the kind structure of the type
lintTy ty