X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=bd88b5f10866d2ace7292246d6ee8fd62173734a;hb=62f6cc1dec4223532fbd15de64db4fb036932944;hp=406bf90349cc9ffe33dcad6ff80500b25d135f06;hpb=bf40e268d916947786c56ec38db86190854a2d2c;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 406bf90..bd88b5f 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -1,55 +1,53 @@ + % +% (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} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CoreLint ( lintCoreBindings, lintUnfolding, - showPass, endPass + showPass, endPass, 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 PprCore -import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, - mkLocMessage, debugTraceMsg ) -import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan ) -import Type ( Type, tyVarsOfType, coreEqType, - splitFunTy_maybe, - splitForAllTy_maybe, splitTyConApp_maybe, - isUnLiftedType, typeKind, mkForAllTy, mkFunTy, - isUnboxedTupleType, isSubKind, - substTyWith, emptyTvSubst, extendTvInScope, - TvSubst, substTy, - extendTvSubst, substTyVarBndr, isInScope, - getTvInScope ) -import 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 Util +import Data.Maybe \end{code} %************************************************************************ @@ -64,7 +62,14 @@ and do Core Lint when necessary. \begin{code} endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] -endPass dflags pass_name dump_flag binds +endPass = dumpAndLint dumpIfSet_core + +endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endIteration = dumpAndLint dumpIfSet_dyn + +dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) + -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +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,7 +77,7 @@ 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 @@ -181,11 +186,12 @@ 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 ++ " ***"), @@ -226,7 +232,7 @@ lintUnfolding locn vars expr Check a core binding, returning the list of variables bound. \begin{code} -lintSingleBinding rec_flag (binder,rhs) +lintSingleBinding top_lvl_flag rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs do { ty <- lintCoreExpr rhs @@ -237,14 +243,26 @@ 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) lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () \end{code} @@ -292,13 +310,13 @@ lintCoreExpr (Note other_note expr) = lintCoreExpr expr 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 @@ -358,8 +376,8 @@ 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 @@ -378,8 +396,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 +425,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) @@ -497,7 +516,9 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) = 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) + -- 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 @@ -505,9 +526,10 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) { -- 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 - + -- 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) } @@ -568,7 +590,7 @@ lintAndScopeIds ids linterF lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a lintAndScopeId id linterF = do { ty <- lintTy (idType id) - ; let id' = setIdType id ty + ; let id' = Var.setIdType id ty ; addInScopeVars [id'] $ (linterF id') } @@ -630,6 +652,7 @@ data LintLocInfo | CasePat CoreAlt -- *Pattern* of the case alternative | AnExpr CoreExpr -- Some expression | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings \end{code} @@ -667,8 +690,13 @@ addLoc extra_loc m = LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) 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 = @@ -756,6 +784,8 @@ dumpLoc (CasePat (con, args, rhs)) dumpLoc (ImportedUnfolding locn) = (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)) @@ -791,7 +821,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 @@ -801,6 +830,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 [ @@ -870,6 +907,26 @@ mkRhsPrimMsg binder rhs 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], @@ -881,6 +938,10 @@ mkCastErr from_ty expr_ty ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty ] +dupVars vars + = hang (ptext SLIT("Duplicate variables brought into scope")) + 2 (ppr vars) + mkStrangeTyMsg e = ptext SLIT("Type where expression expected:") <+> ppr e \end{code}