X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=a33c469e53ea6a4849bc372d031449023f47ac1b;hb=311b1cdfc9b1c311cc53482c461c18cba8885b2a;hp=788c4b4bb6bee2f33c10d2da5f7c76a63258d278;hpb=c94408e522e5af3b79a5beadc7e6d15cee553ee7;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 788c4b4..a33c469 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -\section[CoreLint]{A ``lint'' pass to check for Core correctness} + +A ``lint'' pass to check for Core correctness \begin{code} module CoreLint ( @@ -13,43 +15,32 @@ module CoreLint ( #include "HsVersions.h" import CoreSyn -import CoreFVs ( idFreeVars ) -import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize ) +import CoreFVs +import CoreUtils import Bag -import Literal ( literalType ) -import DataCon ( dataConRepType, dataConTyCon, dataConWorkId ) -import TysWiredIn ( tupleCon ) -import Var ( Var, Id, TyVar, isCoVar, idType, tyVarKind, - mustHaveLocalBinding, setTyVarKind, setIdType ) -import VarEnv ( lookupInScope ) +import Literal +import DataCon +import TysWiredIn +import Var +import VarEnv import VarSet -import Name ( getSrcLoc ) +import Name import PprCore -import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, - mkLocMessage, debugTraceMsg ) -import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan ) -import Type ( Type, tyVarsOfType, coreEqType, - splitFunTy_maybe, mkTyVarTys, - splitForAllTy_maybe, splitTyConApp_maybe, - isUnLiftedType, typeKind, mkForAllTy, mkFunTy, - isUnboxedTupleType, isSubKind, - substTyWith, emptyTvSubst, extendTvInScope, - TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy, - extendTvSubst, composeTvSubst, substTyVarBndr, isInScope, - getTvSubstEnv, getTvInScope, mkTyVarTy ) -import Coercion ( Coercion, coercionKind, coercionKindTyConApp ) -import TyCon ( isPrimTyCon, isNewTyCon ) -import BasicTypes ( RecFlag(..), Boxity(..), isNonRec ) -import StaticFlags ( opt_PprStyle_Debug ) -import DynFlags ( DynFlags, DynFlag(..), dopt ) +import ErrUtils +import SrcLoc +import Type +import Coercion +import TyCon +import BasicTypes +import StaticFlags +import DynFlags import Outputable #ifdef DEBUG import Util ( notNull ) #endif -import Maybe - +import Data.Maybe \end{code} %************************************************************************ @@ -396,12 +387,13 @@ lintCoreArg fun_ty a@(Type arg_ty) = lintCoreArg fun_ty arg = -- Make sure function type matches argument do { arg_ty <- lintCoreExpr arg - ; let err = mkAppMsg fun_ty arg_ty arg + ; let err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg ; case splitFunTy_maybe fun_ty of Just (arg,res) -> - do { checkTys arg arg_ty err + do { checkTys arg arg_ty err1 ; return res } - _ -> addErrL err } + _ -> addErrL err2 } \end{code} \begin{code} @@ -415,12 +407,6 @@ lintTyApp ty arg_ty ; checkKinds tyvar arg_ty ; return (substTyWith [tyvar] [arg_ty] body) } -lintTyApps fun_ty [] = return fun_ty - -lintTyApps fun_ty (arg_ty : arg_tys) = - do { fun_ty' <- lintTyApp fun_ty arg_ty - ; lintTyApps fun_ty' arg_tys } - checkKinds tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give @@ -430,7 +416,7 @@ checkKinds tyvar arg_ty (mkKindErrMsg tyvar arg_ty) where tyvar_kind = tyVarKind tyvar - arg_kind | isCoVar tyvar = coercionKindTyConApp arg_ty + arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty | otherwise = typeKind arg_ty \end{code} @@ -499,22 +485,25 @@ lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty - = addLoc (CaseAlt alt) $ lintBinders args $ \ args -> - - do { addLoc (CasePat alt) $ do - { -- Check the pattern + = addLoc (CaseAlt alt) $ do + { -- First instantiate the universally quantified + -- type variables of the data constructor + con_payload_ty <- lintCoreArgs (dataConRepType con) (map Type tycon_arg_tys) + + -- And now bring the new binders into scope + ; lintBinders args $ \ args -> do + { addLoc (CasePat alt) $ do + { -- Check the pattern -- Scrutinee type must be a tycon applicn; checked by caller -- This code is remarkably compact considering what it does! -- NB: args must be in scope here so that the lintCoreArgs line works. -- NB: relies on existential type args coming *after* ordinary type args - ; con_result_ty <- - lintCoreArgs (dataConRepType con) - (map Type tycon_arg_tys ++ varsToCoreExprs args) + ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args) ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) } -- Check the RHS - ; checkAltExpr rhs alt_ty } + ; checkAltExpr rhs alt_ty } } | otherwise -- Scrut-ty is wrong shape = addErrL (mkBadAltMsg scrut_ty alt) @@ -600,6 +589,21 @@ newtype LintM a = Bag Message -> -- Error messages so far (Maybe a, Bag Message) } -- Result and error messages (if any) +{- Note [Type substitution] + ~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. +-} + instance Monad LintM where return x = LintM (\ loc subst errs -> (Just x, errs)) fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc)) @@ -819,6 +823,13 @@ mkAppMsg fun_ty arg_ty arg hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty), hang (ptext SLIT("Arg:")) 4 (ppr arg)] +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [ptext SLIT("Non-function type in function position"), + hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty), + hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty), + hang (ptext SLIT("Arg:")) 4 (ppr arg)] + mkKindErrMsg :: TyVar -> Type -> Message mkKindErrMsg tyvar arg_ty = vcat [ptext SLIT("Kinds don't match in type application:"),