X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=be323be8faa25721e970c006189a926930488792;hb=fe108ff1b0d4b52679ba6deddadf5d2fb3fa8f22;hp=5e088e4ae36f06283d277c1014e866af1232fcfb;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 5e088e4..be323be 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -14,29 +14,32 @@ module CoreLint ( 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 DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon ) -import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding ) +import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConWorkId ) +import TysWiredIn ( tupleCon ) +import Var ( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding ) import VarSet import Name ( getSrcLoc ) import PprCore import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, mkLocMessage, debugTraceMsg ) import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan ) -import Type ( Type, tyVarsOfType, eqType, - splitFunTy_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, - extendTvSubst, isInScope ) -import TyCon ( isPrimTyCon, TyCon ) -import BasicTypes ( RecFlag(..), isNonRec ) -import CmdLineOpts + TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy, + extendTvSubst, composeTvSubst, isInScope, + getTvSubstEnv, getTvInScope ) +import TyCon ( isPrimTyCon ) +import BasicTypes ( RecFlag(..), Boxity(..), isNonRec ) +import StaticFlags ( opt_PprStyle_Debug ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import Outputable #ifdef DEBUG @@ -63,8 +66,8 @@ endPass dflags pass_name dump_flag binds = do -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated - debugTraceMsg dflags $ - " Result size = " ++ show (coreBindsSize binds) + debugTraceMsg dflags 2 $ + (text " Result size =" <+> int (coreBindsSize binds)) -- Report verbosely, if required dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds) @@ -101,9 +104,9 @@ Outstanding issues: -- -- Things are *not* OK if: -- - -- * Unsaturated type app before specialisation has been done; + -- * Unsaturated type app before specialisation has been done; -- - -- * Oversaturated type app after specialisation (eta reduction + -- * Oversaturated type app after specialisation (eta reduction -- may well be happening...); \begin{code} @@ -117,7 +120,7 @@ lintCoreBindings dflags whoDunnit binds = case (initL (lint_binds binds)) of Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit) Just bad_news -> printDump (display bad_news) >> - ghcExit 1 + ghcExit dflags 1 where -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something @@ -195,11 +198,13 @@ lintSingleBinding rec_flag (binder,rhs) %************************************************************************ \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 = exprTpye (subst e) +-- lintCoreExpr e subst = exprType (subst e) lintCoreExpr (Var var) = do { checkIdInScope var @@ -230,7 +235,7 @@ lintCoreExpr (Let (Rec pairs) body) where bndrs = map fst pairs -lintCoreExpr (App fun (Type ty)) +lintCoreExpr e@(App fun (Type ty)) -- This is like 'let' for types -- It's needed when dealing with desugarer output for GADTs. Consider -- data T = forall a. T a (a->Int) Bool @@ -255,7 +260,8 @@ lintCoreExpr (App fun (Type ty)) -- False -> fail) -- ) a -- Now the inner case look as though it has incompatible branches. - = go fun [ty] + = addLoc (AnExpr e) $ + go fun [ty] where go (App fun (Type ty)) tys = do { go fun (ty:tys) } @@ -273,16 +279,20 @@ lintCoreExpr (App fun (Type ty)) ; lintCoreArgs fun_ty (map Type tys) } lintCoreExpr e@(App fun arg) - = do { ty <- lintCoreExpr fun + = do { fun_ty <- lintCoreExpr fun ; addLoc (AnExpr e) $ - lintCoreArg ty arg } + lintCoreArg fun_ty arg } 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) = @@ -327,14 +337,14 @@ lintCoreArgs ty (a : args) = do { res <- lintCoreArg ty a ; lintCoreArgs res args } -lintCoreArg ty a@(Type arg_ty) = +lintCoreArg fun_ty a@(Type arg_ty) = do { arg_ty <- lintTy arg_ty - ; lintTyApp ty arg_ty } + ; lintTyApp fun_ty arg_ty } lintCoreArg fun_ty arg = -- Make sure function type matches argument do { arg_ty <- lintCoreExpr arg - ; let err = mkAppMsg fun_ty arg_ty + ; let err = mkAppMsg fun_ty arg_ty arg ; case splitFunTy_maybe fun_ty of Just (arg,res) -> do { checkTys arg arg_ty err @@ -379,9 +389,10 @@ checkKinds tyvar arg_ty %************************************************************************ \begin{code} -checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM () +checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () -- a) Check that the alts are non-empty --- b) Check that the DEFAULT comes first, if it exists +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order -- c) Check that there's a default for infinite types -- NB: Algebraic cases are not necessarily exhaustive, because -- the simplifer correctly eliminates case that can't @@ -392,11 +403,16 @@ checkCaseAlts e ty [] checkCaseAlts e ty alts = do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) ; checkL (isJust maybe_deflt || not is_infinite_ty) (nonExhaustiveAltsMsg e) } where (con_alts, maybe_deflt) = findDefault alts + -- Check that successive alternatives have increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag other = True + non_deflt (DEFAULT, _, _) = False non_deflt alt = True @@ -406,14 +422,13 @@ checkCaseAlts e ty alts = \end{code} \begin{code} -checkAltExpr :: CoreExpr -> Type -> LintM () -checkAltExpr expr ty +checkAltExpr :: CoreExpr -> OutType -> LintM () +checkAltExpr expr ann_ty = 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 - -> Type -- Type of the alternative +lintCoreAlt :: OutType -- Type of scrutinee + -> OutType -- Type of the alternative -> CoreAlt -> LintM () @@ -423,50 +438,59 @@ lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) = lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = do { checkL (null args) (mkDefaultArgsMsg args) - ; checkTys lit_ty scrut_ty - (mkBadPatMsg lit_ty scrut_ty) + ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) ; checkAltExpr rhs alt_ty } where lit_ty = literalType lit lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) - | isVanillaDataCon con + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty, + tycon == dataConTyCon con = addLoc (CaseAlt alt) $ - addInScopeVars args $ - do { mapM lintBinder args - -- FIX! Add check that all args are Ids. - -- 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 - - ; case splitTyConApp_maybe scrut_ty of { - Just (tycon, tycon_arg_tys) -> - do { con_type <- lintTyApps (dataConRepType con) tycon_arg_tys + addInScopeVars args $ -- Put the args in scope before lintBinder, + -- because the Ids mention the type variables + if isVanillaDataCon con then + do { addLoc (CasePat alt) $ do + { mapM lintBinder args + -- FIX! Add check that all args are Ids. + -- 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_type <- lintTyApps (dataConRepType con) tycon_arg_tys -- Can just map Var as we know that this is a vanilla datacon - ; con_result_ty <- lintCoreArgs con_type (map Var args) - ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) - -- Check the RHS - ; checkAltExpr rhs alt_ty } ; - Nothing -> addErrL (mkBadAltMsg scrut_ty alt) - } } - - | otherwise - = addLoc (CaseAlt alt) $ - addInScopeVars args $ -- Put the args in scope before lintBinder, because - -- the Ids mention the type variables - do { mapM lintBinder args - ; case splitTyConApp_maybe scrut_ty of { - Nothing -> addErrL (mkBadAltMsg scrut_ty alt) ; - Just (tycon, tycon_args_tys) -> - do { checkL (tycon == dataConTyCon con) (mkIncTyconMsg tycon alt) - ; pat_res_ty <- lintCoreArgs (dataConRepType con) (map varToCoreExpr args) - ; subst <- getTvSubst - ; case coreRefineTys args subst pat_res_ty scrut_ty of - Just senv -> updateTvSubstEnv senv (checkAltExpr rhs alt_ty) - Nothing -> return () -- Alternative is dead code - } } } + ; con_result_ty <- lintCoreArgs con_type (map Var args) + ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) + } + -- Check the RHS + ; checkAltExpr rhs alt_ty } + + else -- GADT + do { let (tvs,ids) = span isTyVar args + ; subst <- getTvSubst + ; let in_scope = getTvInScope subst + subst_env = getTvSubstEnv subst + ; case coreRefineTys in_scope con tvs scrut_ty of { + Nothing -> return () ; -- Alternative is dead code + Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $ + do { addLoc (CasePat alt) $ do + { tvs' <- mapM lintTy (mkTyVarTys tvs) + ; con_type <- lintTyApps (dataConRepType con) tvs' + ; mapM lintBinder ids -- Lint Ids in the refined world + ; lintCoreArgs con_type (map Var ids) + } + + ; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty + -- alt_ty is already an OutType, so don't re-apply + -- the current substitution. But we must apply the + -- refinement so that the check in checkAltExpr is ok + ; checkAltExpr rhs refined_alt_ty + } } } + + | otherwise -- Scrut-ty is wrong shape + = addErrL (mkBadAltMsg scrut_ty alt) \end{code} %************************************************************************ @@ -480,7 +504,7 @@ lintBinder :: Var -> LintM () 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))) @@ -488,7 +512,7 @@ lintId 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 @@ -527,7 +551,8 @@ data LintLocInfo = RhsOf Id -- The variable bound | LambdaBodyOf Id -- The lambda-binder | BodyOfLetRec [Id] -- One of the binders - | CaseAlt CoreAlt -- Pattern of a case alternative + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- *Pattern* of the case alternative | AnExpr CoreExpr -- Some expression | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) \end{code} @@ -570,7 +595,6 @@ addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars vars m = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) --- gaw 2004 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a updateTvSubstEnv substenv m = LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs) @@ -589,7 +613,12 @@ extendSubstL tv ty m \begin{code} checkIdInScope :: Var -> LintM () checkIdInScope id - = checkInScope (ptext SLIT("is out of scope")) id + = do { checkL (not (id == oneTupleDataConId)) + (ptext SLIT("Illegal one-tuple")) + ; checkInScope (ptext SLIT("is out of scope")) id } + +oneTupleDataConId :: Id -- Should not happen +oneTupleDataConId = dataConWorkId (tupleCon Boxed 1) checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id @@ -608,7 +637,7 @@ checkTys :: Type -> Type -> Message -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied -checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg +checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg \end{code} %************************************************************************ @@ -634,7 +663,10 @@ dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) dumpLoc (CaseAlt (con, args, rhs)) - = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (con, args, rhs)) + = (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"))) @@ -675,6 +707,8 @@ mkScrutMsg var scrut_ty mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) nonExhaustiveAltsMsg :: CoreExpr -> Message nonExhaustiveAltsMsg e @@ -694,21 +728,15 @@ mkBadAltMsg scrut_ty alt text "Scrutinee type:" <+> ppr scrut_ty, text "Alternative:" <+> pprCoreAlt alt ] -mkIncTyconMsg :: TyCon -> CoreAlt -> Message -mkIncTyconMsg tycon1 alt@(DataAlt con,_,_) - = vcat [ text "Incompatible tycon applications in alternative", - text "Scrutinee tycon:" <+> ppr tycon1, - text "Alternative tycon:" <+> ppr (dataConTyCon con), - text "Alternative:" <+> pprCoreAlt alt ] - ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> Message -mkAppMsg fun arg +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), - hang (ptext SLIT("Arg type:")) 4 (ppr arg)] + 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