X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=59c52da46a6f691e1082163a6dbf9bf86b3f6313;hb=054b55029dbf8b7d76ac917e4e2ac937785cb90b;hp=31a52f0bba114a573f1f126c7f4e92a287df7086;hpb=ef47b5c2f44fce638b623c9cf5bb2f7f62ba619d;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 31a52f0..59c52da 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, coercionKindPredTy ) -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} %************************************************************************ @@ -378,8 +369,8 @@ The basic version of these functions checks that the argument is a subtype of the required type, as one would expect. \begin{code} -lintCoreArgs :: Type -> [CoreArg] -> LintM Type -lintCoreArg :: Type -> CoreArg -> LintM Type +lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType +lintCoreArg :: OutType -> CoreArg -> LintM OutType -- First argument has already had substitution applied to it \end{code} @@ -407,6 +398,7 @@ lintCoreArg fun_ty arg = \begin{code} -- Both args have had substitution applied +lintTyApp :: OutType -> OutType -> LintM OutType lintTyApp ty arg_ty = case splitForAllTy_maybe ty of Nothing -> addErrL (mkTyAppMsg ty arg_ty) @@ -416,12 +408,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 @@ -500,21 +486,27 @@ 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 - = 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 + -- We've already check + checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let con_payload_ty = applyTys (dataConRepType con) 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 +592,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)) @@ -778,7 +785,6 @@ mkScrutMsg var var_ty scrut_ty subst text "Scrutinee type:" <+> ppr scrut_ty, hsep [ptext SLIT("Current TV subst"), ppr subst]] - mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) mkNonIncreasingAltsMsg e @@ -788,6 +794,14 @@ nonExhaustiveAltsMsg :: CoreExpr -> Message nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) +mkBadConMsg :: TyCon -> DataCon -> Message +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + mkBadPatMsg :: Type -> Type -> Message mkBadPatMsg con_result_ty scrut_ty = vcat [