X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=52b330c730b08d0c12d7303850db19e8081b555b;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=2fb0bd3b842f6d4c74fb8ea00f7cf62aac247c1b;hpb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 2fb0bd3..52b330c 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -7,88 +7,76 @@ module CoreLint ( lintCoreBindings, lintUnfolding, - showPass, endPass, endPassWithRules + showPass, endPass ) where #include "HsVersions.h" -import IO ( hPutStr, hPutStrLn, stdout ) - import CoreSyn -import Rules ( RuleBase, pprRuleBase ) import CoreFVs ( idFreeVars ) -import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType ) +import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType ) import Bag import Literal ( literalType ) import DataCon ( dataConRepType ) import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding ) import VarSet -import Subst ( mkTyVarSubst, substTy ) +import Subst ( substTyWith ) import Name ( getSrcLoc ) import PprCore -import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass, - ErrMsg, addErrLocHdrLine, pprBagOfErrors, - WarnMsg, pprBagOfWarnings) -import SrcLoc ( SrcLoc, noSrcLoc ) -import Type ( Type, tyVarsOfType, +import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, + mkLocMessage ) +import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan ) +import Type ( Type, tyVarsOfType, eqType, splitFunTy_maybe, mkTyVarTy, splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, isUnLiftedType, typeKind, isUnboxedTupleType, - hasMoreBoxityInfo + isSubKind ) import TyCon ( isPrimTyCon ) import BasicTypes ( RecFlag(..), isNonRec ) import CmdLineOpts -import Maybe import Outputable +#ifdef DEBUG +import Util ( notNull ) +#endif + +import Maybe +import IO ( hPutStrLn, stderr ) + infixr 9 `thenL`, `seqL` \end{code} %************************************************************************ %* * -\subsection{Start and end pass} +\subsection{End pass} %* * %************************************************************************ -@beginPass@ and @endPass@ don't really belong here, but it makes a convenient +@showPass@ and @endPass@ don't really belong here, but it makes a convenient 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 - = do - (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing - return binds - -endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind] - -> Maybe RuleBase - -> IO ([CoreBind], Maybe RuleBase) -endPassWithRules dflags pass_name dump_flag binds rules = do - -- ToDo: force the rules? - -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated if verbosity dflags >= 2 then - hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds)) + hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds)) else return () -- Report verbosely, if required - dumpIfSet_core dflags dump_flag pass_name - (pprCoreBindings binds $$ case rules of - Nothing -> empty - Just rb -> pprRuleBase rb) + dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds) -- Type check lintCoreBindings dflags pass_name binds - -- ToDo: lint the rules - return (binds, rules) + return binds \end{code} @@ -131,13 +119,9 @@ lintCoreBindings dflags whoDunnit binds lintCoreBindings dflags whoDunnit binds = case (initL (lint_binds binds)) of - (Nothing, Nothing) -> done_lint - - (Nothing, Just warnings) -> printDump (warn warnings) >> - done_lint - - (Just bad_news, warns) -> printDump (display bad_news warns) >> - ghcExit 1 + Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit) + Just bad_news -> printDump (display bad_news) >> + ghcExit 1 where -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something @@ -149,24 +133,9 @@ lintCoreBindings dflags whoDunnit binds returnL () lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) - done_lint = doIfSet (verbosity dflags >= 2) - (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n")) - warn warnings - = vcat [ - text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"), - warnings, - offender - ] - - display bad_news warns - = vcat [ - text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), + display bad_news + = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), bad_news, - maybe offender warn warns -- either offender or warnings (with offender) - ] - - offender - = vcat [ ptext SLIT("*** Offending Program ***"), pprCoreBindings binds, ptext SLIT("*** End of Offense ***") @@ -183,17 +152,12 @@ We use this to check all unfoldings that come in from interfaces (it is very painful to catch errors otherwise): \begin{code} -lintUnfolding :: DynFlags - -> SrcLoc +lintUnfolding :: SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr - -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK + -> Maybe Message -- Nothing => OK -lintUnfolding dflags locn vars expr - | not (dopt Opt_DoCoreLinting dflags) - = (Nothing, Nothing) - - | otherwise +lintUnfolding locn vars expr = initL (addLoc (ImportedUnfolding locn) $ addInScopeVars vars $ lintCoreExpr expr) @@ -304,7 +268,7 @@ lintCoreExpr e@(Case scrut var alts) addInScopeVars [var] ( -- Check the alternatives - checkAllCasesCovered e scrut_ty alts `seqL` + checkCaseAlts e scrut_ty alts `seqL` mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) -> mapL (check alt_ty) alt_tys `seqL` @@ -369,13 +333,13 @@ lintTyApp ty arg_ty tyvar_kind = tyVarKind tyvar argty_kind = typeKind arg_ty in - if argty_kind `hasMoreBoxityInfo` tyvar_kind + if argty_kind `isSubKind` tyvar_kind -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. then - returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body) + returnL (substTyWith [tyvar] [arg_ty] body) else addErrL (mkKindErrMsg tyvar arg_ty) @@ -396,46 +360,30 @@ lintTyApps fun_ty (arg_ty : arg_tys) %************************************************************************ \begin{code} -checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM () - -checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e) - -checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL +checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b) Check that the DEFAULT comes first, if it exists +-- 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 +-- possibly match. + +checkCaseAlts e ty [] + = addErrL (mkNullAltsMsg e) + +checkCaseAlts e ty alts + = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL` + checkL (isJust maybe_deflt || not is_infinite_ty) + (nonExhaustiveAltsMsg e) + where + (con_alts, maybe_deflt) = findDefault alts -checkAllCasesCovered e scrut_ty alts - = case splitTyConApp_maybe scrut_ty of { - Nothing -> addErrL (badAltsMsg e); - Just (tycon, tycon_arg_tys) -> + non_deflt (DEFAULT, _, _) = False + non_deflt alt = True - if isPrimTyCon tycon then - checkL (hasDefault alts) (nonExhaustiveAltsMsg e) - else -{- No longer needed -#ifdef DEBUG - -- Algebraic cases are not necessarily exhaustive, because - -- the simplifer correctly eliminates case that can't - -- possibly match. - -- This code just emits a message to say so - let - missing_cons = filter not_in_alts (tyConDataCons tycon) - not_in_alts con = all (not_in_alt con) alts - not_in_alt con (DataCon con', _, _) = con /= con' - not_in_alt con other = True - - case_bndr = case e of { Case _ bndr alts -> bndr } - in - if not (hasDefault alts || null missing_cons) then - pprTrace "Exciting (but not a problem)! Non-exhaustive case:" - (ppr case_bndr <+> ppr missing_cons) - nopL - else -#endif --} - nopL } - -hasDefault [] = False -hasDefault ((DEFAULT,_,_) : alts) = True -hasDefault (alt : alts) = hasDefault alts + is_infinite_ty = case splitTyConApp_maybe ty of + Nothing -> False + Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon \end{code} \begin{code} @@ -458,8 +406,8 @@ lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs) lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) = addLoc (CaseAlt alt) ( - mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg))) - (mkUnboxedTupleMsg arg)) args `seqL` + mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg))) + (mkUnboxedTupleMsg arg)) args `seqL` addInScopeVars args ( @@ -467,6 +415,7 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) -- 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 scrut_ty of { (tycon, tycon_arg_tys) -> lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type -> lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> @@ -510,9 +459,8 @@ lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` \begin{code} type LintM a = [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag ErrMsg -- Error messages so far - -> Bag WarnMsg -- Warning messages so far - -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any) + -> Bag Message -- Error messages so far + -> (Maybe a, Bag Message) -- Result and error messages (if any) data LintLocInfo = RhsOf Id -- The variable bound @@ -524,31 +472,28 @@ data LintLocInfo \end{code} \begin{code} -initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -}) +initL :: LintM a -> Maybe Message {- errors -} initL m - = case m [] emptyVarSet emptyBag emptyBag of - (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors, - ifNonEmptyBag warns pprBagOfWarnings) - where - ifNonEmptyBag bag f | isEmptyBag bag = Nothing - | otherwise = Just (f bag) + = case m [] emptyVarSet emptyBag of + (_, errs) | isEmptyBag errs -> Nothing + | otherwise -> Just (vcat (punctuate (text "") (bagToList errs))) returnL :: a -> LintM a -returnL r loc scope errs warns = (Just r, errs, warns) +returnL r loc scope errs = (Just r, errs) nopL :: LintM a -nopL loc scope errs warns = (Nothing, errs, warns) +nopL loc scope errs = (Nothing, errs) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k loc scope errs warns - = case m loc scope errs warns of - (Just r, errs', warns') -> k r loc scope errs' warns' - (Nothing, errs', warns') -> (Nothing, errs', warns') +thenL m k loc scope errs + = case m loc scope errs of + (Just r, errs') -> k r loc scope errs' + (Nothing, errs') -> (Nothing, errs') seqL :: LintM a -> LintM b -> LintM b -seqL m k loc scope errs warns - = case m loc scope errs warns of - (_, errs', warns') -> k loc scope errs' warns' +seqL m k loc scope errs + = case m loc scope errs of + (_, errs') -> k loc scope errs' mapL :: (a -> LintM b) -> [a] -> LintM [b] mapL f [] = returnL [] @@ -564,12 +509,11 @@ checkL True msg = nopL checkL False msg = addErrL msg addErrL :: Message -> LintM a -addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns) +addErrL msg loc scope errs = (Nothing, addErr errs msg loc) -addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg --- errors or warnings, actually... they're the same type. +addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message addErr errs_so_far msg locs - = ASSERT( not (null locs) ) + = ASSERT( notNull locs ) errs_so_far `snocBag` mk_msg msg where (loc, cxt1) = dumpLoc (head locs) @@ -577,15 +521,15 @@ addErr errs_so_far msg locs context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 | otherwise = cxt1 - mk_msg msg = addErrLocHdrLine loc context msg + mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m loc scope errs warns - = m (extra_loc:loc) scope errs warns +addLoc extra_loc m loc scope errs + = m (extra_loc:loc) scope errs addInScopeVars :: [Var] -> LintM a -> LintM a -addInScopeVars ids m loc scope errs warns - = m loc (scope `unionVarSet` mkVarSet ids) errs warns +addInScopeVars ids m loc scope errs + = m loc (extendVarSetList scope ids) errs \end{code} \begin{code} @@ -601,18 +545,18 @@ checkBndrIdInScope binder id ppr binder checkInScope :: SDoc -> Var -> LintM () -checkInScope loc_msg var loc scope errs warns +checkInScope loc_msg var loc scope errs | mustHaveLocalBinding var && not (var `elemVarSet` scope) - = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns) + = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) | otherwise - = nopL loc scope errs warns + = nopL loc scope errs checkTys :: Type -> Type -> Message -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) checkTys ty1 ty2 msg - | ty1 == ty2 = nopL - | otherwise = addErrL msg + | ty1 `eqType` ty2 = nopL + | otherwise = addErrL msg \end{code} @@ -677,15 +621,13 @@ mkScrutMsg var scrut_ty text "Result binder type:" <+> ppr (idType var), text "Scrutinee type:" <+> ppr scrut_ty] -badAltsMsg :: CoreExpr -> Message -badAltsMsg e - = hang (text "Case statement scrutinee is not a data type:") - 4 (ppr e) + +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) nonExhaustiveAltsMsg :: CoreExpr -> Message nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") - 4 (ppr e) + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) mkBadPatMsg :: Type -> Type -> Message mkBadPatMsg con_result_ty scrut_ty