X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=a3ba3ae250afa9d3a7bc2ab58116b3609e5a10ae;hp=354b95c7624db36c4452626b6d9420937c862eb3;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=204e70a4a6b977116c77226f014ebed5407713c2 diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 354b95c..a3ba3ae 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -1,55 +1,48 @@ + % +% (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 ( lintCoreBindings, lintUnfolding, - showPass, endPass + showPass, endPass, endPassIf, endIteration ) where #include "HsVersions.h" +import NewDemand 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 Id +import IdInfo 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 ListSetOps +import DynFlags import Outputable - -#ifdef DEBUG -import Util ( notNull ) -#endif - -import Maybe - +import FastString +import Util +import Data.Maybe \end{code} %************************************************************************ @@ -63,8 +56,18 @@ place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] -endPass dflags pass_name dump_flag binds +endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () +endPass = dumpAndLint dumpIfSet_core + +endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () +endPassIf cond = dumpAndLint (dumpIf_core cond) + +endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () +endIteration = dumpAndLint dumpIfSet_dyn + +dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) + -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () +dumpAndLint dump dflags pass_name dump_flag binds = do -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated @@ -72,12 +75,10 @@ endPass dflags pass_name dump_flag binds (text " Result size =" <+> int (coreBindsSize binds)) -- Report verbosely, if required - dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds) + dump dflags dump_flag pass_name (pprCoreBindings binds) -- Type check lintCoreBindings dflags pass_name binds - - return binds \end{code} @@ -112,21 +113,15 @@ Outstanding issues: -- may well be happening...); -Note [Type lets] -~~~~~~~~~~~~~~~~ +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ In the desugarer, it's very very convenient to be able to say (in effect) - let a = Int in -That is, use a type let. (See notes just below for why we want this.) - -We don't have type lets in Core, so the desugarer uses type lambda - (/\a. ) Int -However, in the lambda form, we'd get lint errors from: - (/\a. let x::a = 4 in ) Int -because (x::a) doesn't look compatible with (4::Int). - -So (HACK ALERT) the Lint phase does type-beta reduction "on the fly", -as it were. It carries a type substitution (in this example [a -> Int]) -and applies this substitution before comparing types. The functin + let a = Type Int in +That is, use a type let. See Note [Type let] in CoreSyn. + +However, when linting we need to remember that a=Int, else we might +reject a correct program. So we carry a type substitution (in this example +[a -> Int]) and apply this substitution before comparing types. The functin lintTy :: Type -> LintM Type returns a substituted type; that's the only reason it returns anything. @@ -138,37 +133,10 @@ itself is part of the TvSubst we are carrying down), and when we find an occurence of an Id, we fetch it from the in-scope set. -Why we need type let -~~~~~~~~~~~~~~~~~~~~ -It's needed when dealing with desugarer output for GADTs. Consider - data T = forall a. T a (a->Int) Bool - f :: T -> ... -> - f (T x f True) = - f (T y g False) = -After desugaring we get - f t b = case t of - T a (x::a) (f::a->Int) (b:Bool) -> - case b of - True -> - False -> (/\b. let y=x; g=f in ) a -And for a reason I now forget, the ...... can mention a; so -we want Lint to know that b=a. Ugh. - -I tried quite hard to make the necessity for this go away, by changing the -desugarer, but the fundamental problem is this: - - T a (x::a) (y::Int) -> let fail::a = ... - in (/\b. ...(case ... of - True -> x::b - False -> fail) - ) a -Now the inner case look as though it has incompatible branches. - - \begin{code} lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () -lintCoreBindings dflags whoDunnit binds +lintCoreBindings dflags _whoDunnit _binds | not (dopt Opt_DoCoreLinting dflags) = return () @@ -181,18 +149,19 @@ lintCoreBindings dflags whoDunnit binds -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something -- into use 'unexpectedly' - lint_binds binds = addInScopeVars (bindersOfBinds binds) $ + lint_binds binds = addLoc TopLevelBindings $ + addInScopeVars (bindersOfBinds binds) $ mapM lint_bind binds - lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs - lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) + lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs + lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) display bad_news = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), bad_news, - ptext SLIT("*** Offending Program ***"), + ptext (sLit "*** Offending Program ***"), pprCoreBindings binds, - ptext SLIT("*** End of Offense ***") + ptext (sLit "*** End of Offense ***") ] \end{code} @@ -226,7 +195,8 @@ lintUnfolding locn vars expr Check a core binding, returning the list of variables bound. \begin{code} -lintSingleBinding rec_flag (binder,rhs) +lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () +lintSingleBinding top_lvl_flag rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs do { ty <- lintCoreExpr rhs @@ -237,14 +207,29 @@ lintSingleBinding rec_flag (binder,rhs) ; checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs)) (mkRhsPrimMsg binder rhs) + -- Check that if the binder is top-level or recursive, it's not demanded + ; checkL (not (isStrictId binder) + || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) + (mkStrictMsg binder) -- Check whether binder's specialisations contain any out-of-scope variables - ; mapM_ (checkBndrIdInScope binder) bndr_vars } + ; mapM_ (checkBndrIdInScope binder) bndr_vars + + -- Check whether arity and demand type are consistent (only if demand analysis + -- already happened) + ; checkL (case maybeDmdTy of + Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs + Nothing -> True) + (mkArityMsg binder) } -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. - where - binder_ty = idType binder - bndr_vars = varSetElems (idFreeVars binder) + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + where + binder_ty = idType binder + maybeDmdTy = idNewStrictness_maybe binder + bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars) + wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info) + | otherwise = emptyVarSet + wkr_info = idWorkerInfo binder lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () \end{code} @@ -263,10 +248,14 @@ 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" can be a kind, if the expression is (Type ty) lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) - (ptext SLIT("Illegal one-tuple")) + (ptext (sLit "Illegal one-tuple")) + + ; checkDeadIdOcc var ; var' <- lookupIdInScope var ; return (idType var') } @@ -288,44 +277,35 @@ lintCoreExpr (Cast expr co) ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) ; return to_ty } -lintCoreExpr (Note other_note expr) +lintCoreExpr (Note _ expr) = lintCoreExpr expr +lintCoreExpr (Let (NonRec tv (Type ty)) body) + = -- See Note [Type let] in CoreSyn + do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate + ; ty' <- lintTy ty + ; kind' <- lintTy (tyVarKind tv) + ; let tv' = setTyVarKind tv kind' + ; checkKinds tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; addLoc (BodyOfLetRec [tv]) $ + addInScopeVars [tv'] $ + extendSubstL tv' ty' $ + lintCoreExpr body } + lintCoreExpr (Let (NonRec bndr rhs) body) - = do { lintSingleBinding NonRecursive (bndr,rhs) + = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) ; addLoc (BodyOfLetRec [bndr]) (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } lintCoreExpr (Let (Rec pairs) body) = lintAndScopeIds bndrs $ \_ -> - do { mapM (lintSingleBinding Recursive) pairs + do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } where bndrs = map fst pairs -lintCoreExpr e@(App fun (Type ty)) --- See Note [Type let] above - = addLoc (AnExpr e) $ - go fun [ty] - where - go (App fun (Type ty)) tys - = do { go fun (ty:tys) } - go (Lam tv body) (ty:tys) - = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate - ; ty' <- lintTy ty - ; let kind = tyVarKind tv - ; kind' <- lintTy kind - ; let tv' = setTyVarKind tv kind' - ; checkKinds tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; addInScopeVars [tv'] $ - extendSubstL tv' ty' $ - go body tys } - go fun tys - = do { fun_ty <- lintCoreExpr fun - ; lintCoreArgs fun_ty (map Type tys) } - lintCoreExpr e@(App fun arg) = do { fun_ty <- lintCoreExpr fun ; addLoc (AnExpr e) $ @@ -347,6 +327,19 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = do { scrut_ty <- lintCoreExpr scrut ; alt_ty <- lintTy alt_ty ; var_ty <- lintTy (idType var) + + ; let mb_tc_app = splitTyConApp_maybe (idType var) + ; case mb_tc_app of + Just (tycon, _) + | debugIsOn && + isAlgTyCon tycon && + not (isOpenTyCon tycon) && + null (tyConDataCons tycon) -> + pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate ; subst <- getTvSubst @@ -358,14 +351,15 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = else lintAndScopeId var ; scope $ \_ -> do { -- Check the alternatives - checkCaseAlts e scrut_ty alts - ; mapM (lintCoreAlt scrut_ty alt_ty) alts + mapM_ (lintCoreAlt scrut_ty alt_ty) alts + ; checkCaseAlts e scrut_ty alts ; return alt_ty } } where pass_var f = f var -lintCoreExpr e@(Type ty) - = addErrL (mkStrangeTyMsg e) +lintCoreExpr (Type ty) + = do { ty' <- lintTy ty + ; return (typeKind ty') } \end{code} %************************************************************************ @@ -378,8 +372,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} @@ -389,7 +383,7 @@ lintCoreArgs ty (a : args) = do { res <- lintCoreArg ty a ; lintCoreArgs res args } -lintCoreArg fun_ty a@(Type arg_ty) = +lintCoreArg fun_ty (Type arg_ty) = do { arg_ty <- lintTy arg_ty ; lintTyApp fun_ty arg_ty } @@ -407,6 +401,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 +411,7 @@ 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 :: Var -> Type -> LintM () 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 @@ -433,6 +423,17 @@ checkKinds tyvar arg_ty tyvar_kind = tyVarKind tyvar arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty | otherwise = typeKind arg_ty + +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } + | otherwise + = return () \end{code} @@ -452,7 +453,7 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () -- the simplifer correctly eliminates case that can't -- possibly match. -checkCaseAlts e ty [] +checkCaseAlts e _ [] = addErrL (mkNullAltsMsg e) checkCaseAlts e ty alts = @@ -465,14 +466,14 @@ checkCaseAlts e ty alts = -- Check that successive alternatives have increasing tags increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest - increasing_tag other = True + increasing_tag _ = True non_deflt (DEFAULT, _, _) = False - non_deflt alt = True + non_deflt _ = True is_infinite_ty = case splitTyConApp_maybe ty of - Nothing -> False - Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon + Nothing -> False + Just (tycon, _) -> isPrimTyCon tycon \end{code} \begin{code} @@ -486,11 +487,11 @@ lintCoreAlt :: OutType -- Type of scrutinee -> CoreAlt -> LintM () -lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) = +lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = do { checkL (null args) (mkDefaultArgsMsg args) ; checkAltExpr rhs alt_ty } -lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = +lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) = do { checkL (null args) (mkDefaultArgsMsg args) ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) ; checkAltExpr rhs alt_ty } @@ -500,22 +501,28 @@ 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 + -- 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) + -- 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 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) @@ -543,7 +550,7 @@ lintBinder var linterF | isTyVar var = lint_ty_bndr | otherwise = lintIdBndr var linterF where - lint_ty_bndr = do { lintTy (tyVarKind var) + lint_ty_bndr = do { _ <- lintTy (tyVarKind var) ; subst <- getTvSubst ; let (subst', tv') = substTyVarBndr subst var ; updateTvSubst subst' (linterF tv') } @@ -577,6 +584,7 @@ lintAndScopeId id linterF lintTy :: InType -> LintM OutType -- Check the type, and apply the substitution to it +-- See Note [Linting type lets] -- ToDo: check the kind structure of the type lintTy ty = do { ty' <- applySubst ty @@ -601,8 +609,23 @@ 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)) + return x = LintM (\ _ _ errs -> (Just x, errs)) fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc)) m >>= k = LintM (\ loc subst errs -> let (res, errs') = unLintM m loc subst errs in @@ -615,9 +638,10 @@ data LintLocInfo | LambdaBodyOf Id -- The lambda-binder | BodyOfLetRec [Id] -- One of the binders | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- *Pattern* of the case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative | AnExpr CoreExpr -- Some expression | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings \end{code} @@ -626,12 +650,12 @@ initL :: LintM a -> Maybe Message {- errors -} initL m = case unLintM m [] emptyTvSubst emptyBag of (_, errs) | isEmptyBag errs -> Nothing - | otherwise -> Just (vcat (punctuate (text "") (bagToList errs))) + | otherwise -> Just (vcat (punctuate blankLine (bagToList errs))) \end{code} \begin{code} checkL :: Bool -> Message -> LintM () -checkL True msg = return () +checkL True _ = return () checkL False msg = addErrL msg addErrL :: Message -> LintM a @@ -645,7 +669,7 @@ addErr subst errs_so_far msg locs (loc, cxt1) = dumpLoc (head locs) cxts = [snd (dumpLoc loc) | loc <- locs] context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ - ptext SLIT("Substitution:") <+> ppr subst + ptext (sLit "Substitution:") <+> ppr subst | otherwise = cxt1 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) @@ -654,16 +678,27 @@ addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m = LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs) + where + is_case_pat (CasePat {} : _) = True + is_case_pat _other = False + addInScopeVars :: [Var] -> LintM a -> LintM a -addInScopeVars vars m = - LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) +addInScopeVars vars m + | null dups + = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) + | otherwise + = addErrL (dupVars dups) + where + (_, dups) = removeDups compare vars updateTvSubst :: TvSubst -> LintM a -> LintM a updateTvSubst subst' m = - LintM (\ loc subst errs -> unLintM m loc subst' errs) + LintM (\ loc _ errs -> unLintM m loc subst' errs) getTvSubst :: LintM TvSubst -getTvSubst = LintM (\ loc subst errs -> (Just subst, errs)) +getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) applySubst :: Type -> LintM Type applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) } @@ -682,10 +717,10 @@ lookupIdInScope id = do { subst <- getTvSubst ; case lookupInScope (getTvInScope subst) id of Just v -> return v - Nothing -> do { addErrL out_of_scope + Nothing -> do { _ <- addErrL out_of_scope ; return id } } where - out_of_scope = ppr id <+> ptext SLIT("is out of scope") + out_of_scope = ppr id <+> ptext (sLit "is out of scope") oneTupleDataConId :: Id -- Should not happen @@ -695,11 +730,11 @@ checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id = checkInScope msg id where - msg = ptext SLIT("is out of scope inside info for") <+> + msg = ptext (sLit "is out of scope inside info for") <+> ppr binder checkTyVarInScope :: TyVar -> LintM () -checkTyVarInScope tv = checkInScope (ptext SLIT("is out of scope")) tv +checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var = @@ -721,36 +756,40 @@ checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg %************************************************************************ \begin{code} +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + dumpLoc (RhsOf v) - = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v])) + = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v])) dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)) + = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b)) dumpLoc (BodyOfLetRec []) - = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders"))) + = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders"))) dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)) + = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs)) dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) -dumpLoc (CaseAlt (con, args, rhs)) +dumpLoc (CaseAlt (con, args, _)) = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) -dumpLoc (CasePat (con, args, rhs)) +dumpLoc (CasePat (con, args, _)) = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) dumpLoc (ImportedUnfolding locn) - = (locn, brackets (ptext SLIT("in an imported unfolding"))) + = (locn, brackets (ptext (sLit "in an imported unfolding"))) +dumpLoc TopLevelBindings + = (noSrcLoc, empty) pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) pp_binder :: Var -> SDoc pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] - | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] \end{code} \begin{code} @@ -777,9 +816,9 @@ mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, - hsep [ptext SLIT("Current TV subst"), ppr subst]] - + hsep [ptext (sLit "Current TV subst"), ppr subst]] +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) mkNonIncreasingAltsMsg e @@ -789,6 +828,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 [ @@ -815,60 +862,83 @@ mkNewTyDataConAltMsg scrut_ty alt mkAppMsg :: Type -> Type -> CoreExpr -> Message mkAppMsg fun_ty arg_ty arg - = vcat [ptext SLIT("Argument value doesn't match argument type:"), - 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)] + = vcat [ptext (sLit "Argument value doesn't match argument type:"), + 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)] 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)] + = 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:"), - hang (ptext SLIT("Type variable:")) + = vcat [ptext (sLit "Kinds don't match in type application:"), + hang (ptext (sLit "Type variable:")) 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext SLIT("Arg type:")) + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] mkTyAppMsg :: Type -> Type -> Message mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", - hang (ptext SLIT("Exp type:")) + hang (ptext (sLit "Exp type:")) 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (ptext SLIT("Arg type:")) + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] mkRhsMsg :: Id -> Type -> Message mkRhsMsg binder ty = vcat - [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), + [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), ppr binder], - hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], - hsep [ptext SLIT("Rhs type:"), ppr ty]] + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], + hsep [ptext (sLit "Rhs type:"), ppr ty]] mkRhsPrimMsg :: Id -> CoreExpr -> Message -mkRhsPrimMsg binder rhs - = vcat [hsep [ptext SLIT("The type of this binder is primitive:"), +mkRhsPrimMsg binder _rhs + = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), ppr binder], - hsep [ptext SLIT("Binder's type:"), ppr (idType binder)] + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] ] +mkStrictMsg :: Id -> Message +mkStrictMsg binder + = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), + ppr binder], + hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)] + ] + +mkArityMsg :: Id -> Message +mkArityMsg binder + = vcat [hsep [ptext (sLit "Demand type has "), + ppr (dmdTypeDepth dmd_ty), + ptext (sLit " arguments, rhs has "), + ppr (idArity binder), + ptext (sLit "arguments, "), + ppr binder], + hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] + + ] + where (StrictSig dmd_ty) = idNewStrictness binder + mkUnboxedTupleMsg :: Id -> Message mkUnboxedTupleMsg binder - = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder], - hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]] + = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder], + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]] +mkCastErr :: Type -> Type -> Message mkCastErr from_ty expr_ty - = vcat [ptext SLIT("From-type of Cast differs from type of enclosed expression"), - ptext SLIT("From-type:") <+> ppr from_ty, - ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty + = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), + ptext (sLit "From-type:") <+> ppr from_ty, + ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty ] -mkStrangeTyMsg e - = ptext SLIT("Type where expression expected:") <+> ppr e +dupVars :: [[Var]] -> Message +dupVars vars + = hang (ptext (sLit "Duplicate variables brought into scope")) + 2 (ppr vars) \end{code}