X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=62a89033456e19cf313ff079f7637cdd07390ea3;hb=29e5b129c2e95d8890048f5dd27711c351db8e7e;hp=02d6e87475185a831dea2e0275d9929059fb0b97;hpb=783e505e2d884f94d30ec8074e590507f2561c49;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 02d6e87..62a8903 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -7,41 +7,42 @@ module CoreLint ( lintCoreBindings, lintUnfolding, - beginPass, endPass + beginPass, endPass, endPassWithRules ) where #include "HsVersions.h" -import IO ( hPutStr, hPutStrLn, stderr, stdout ) +import IO ( hPutStr, hPutStrLn, stdout ) import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug ) import CoreSyn -import CoreFVs ( idFreeVars ) -import CoreUtils ( exprOkForSpeculation, coreBindsSize ) +import Rules ( RuleBase, pprRuleBase ) +import CoreFVs ( idFreeVars, mustHaveLocalBinding ) +import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType ) import Bag -import Literal ( Literal, literalType ) -import DataCon ( DataCon, dataConRepType ) -import Id ( mayHaveNoBinding, isDeadBinder ) +import Literal ( literalType ) +import DataCon ( dataConRepType ) import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId ) import VarSet import Subst ( mkTyVarSubst, substTy ) -import Name ( isLocallyDefined, getSrcLoc ) +import Name ( getSrcLoc ) import PprCore import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message, - ErrMsg, addErrLocHdrLine, pprBagOfErrors ) -import PrimRep ( PrimRep(..) ) + ErrMsg, addErrLocHdrLine, pprBagOfErrors, + WarnMsg, pprBagOfWarnings) import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc ) -import Type ( Type, Kind, tyVarsOfType, - splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy, +import Type ( Type, tyVarsOfType, + splitFunTy_maybe, mkTyVarTy, splitForAllTy_maybe, splitTyConApp_maybe, isUnLiftedType, typeKind, - splitAlgTyConApp_maybe, isUnboxedTupleType, hasMoreBoxityInfo ) +import PprType ( {- instance Outputable Type -} ) import TyCon ( TyCon, isPrimTyCon, tyConDataCons ) import BasicTypes ( RecFlag(..), isNonRec ) +import Maybe import Outputable infixr 9 `thenL`, `seqL` @@ -61,14 +62,23 @@ and do Core Lint when necessary. beginPass :: String -> IO () beginPass pass_name | opt_D_show_passes - = hPutStrLn stderr ("*** " ++ pass_name) + = hPutStrLn stdout ("*** " ++ pass_name) | otherwise = return () endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind] endPass pass_name dump_flag binds + = do + (binds, _) <- endPassWithRules pass_name dump_flag binds Nothing + return binds + +endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase + -> IO ([CoreBind], Maybe RuleBase) +endPassWithRules 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 opt_D_show_passes then @@ -78,12 +88,15 @@ endPass pass_name dump_flag binds -- Report verbosely, if required dumpIfSet dump_flag pass_name - (pprCoreBindings binds) + (pprCoreBindings binds $$ case rules of + Nothing -> empty + Just rb -> pprRuleBase rb) -- Type check lintCoreBindings pass_name binds + -- ToDo: lint the rules - return binds + return (binds, rules) \end{code} @@ -126,11 +139,13 @@ lintCoreBindings whoDunnit binds lintCoreBindings whoDunnit binds = case (initL (lint_binds binds)) of - Nothing -> doIfSet opt_D_show_passes - (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n")) + (Nothing, Nothing) -> done_lint + + (Nothing, Just warnings) -> printDump (warn warnings) >> + done_lint - Just bad_news -> printDump (display bad_news) >> - ghcExit 1 + (Just bad_news, warns) -> printDump (display bad_news warns) >> + ghcExit 1 where -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something @@ -142,10 +157,24 @@ lintCoreBindings whoDunnit binds returnL () lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) - display bad_news + done_lint = doIfSet opt_D_show_passes + (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 ++ " ***"), 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 ***") @@ -165,11 +194,11 @@ We use this to check all unfoldings that come in from interfaces lintUnfolding :: SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe Message -- Nothing => OK + -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK lintUnfolding locn vars expr | not opt_DoCoreLinting - = Nothing + = (Nothing, Nothing) | otherwise = initL (addLoc (ImportedUnfolding locn) $ @@ -197,7 +226,8 @@ lintSingleBinding rec_flag (binder,rhs) checkTys binder_ty ty (mkRhsMsg binder ty) `seqL` -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) - checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs)) + checkL (not (isUnLiftedType binder_ty) + || (isNonRec rec_flag && exprOkForSpeculation rhs)) (mkRhsPrimMsg binder rhs) `seqL` -- Check whether binder's specialisations contain any out-of-scope variables @@ -227,7 +257,7 @@ lintCoreExpr (Note (Coerce to_ty from_ty) expr) = lintCoreExpr expr `thenL` \ expr_ty -> lintTy to_ty `seqL` lintTy from_ty `seqL` - checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL` + checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL` returnL to_ty lintCoreExpr (Note other_note expr) @@ -252,10 +282,14 @@ lintCoreExpr e@(App fun arg) lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ - checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var) + (if isId var then + checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var) + else + returnL ()) `seqL` (addInScopeVars [var] $ lintCoreExpr expr `thenL` \ ty -> + returnL (mkPiType var ty)) lintCoreExpr e@(Case scrut var alts) @@ -277,7 +311,8 @@ lintCoreExpr e@(Case scrut var alts) addInScopeVars [var] ( -- Check the alternatives - checkAllCasesCovered e scrut_ty alts `seqL` + checkAllCasesCovered e scrut_ty alts `seqL` + mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) -> mapL (check alt_ty) alt_tys `seqL` returnL alt_ty) @@ -294,31 +329,40 @@ lintCoreExpr e@(Type ty) %* * %************************************************************************ -The boolean argument indicates whether we should flag type -applications to primitive types as being errors. +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 +lintCoreArgs = lintCoreArgs0 checkTys -lintCoreArgs ty [] = returnL ty -lintCoreArgs ty (a : args) - = lintCoreArg ty a `thenL` \ res -> - lintCoreArgs res args +lintCoreArg :: Type -> CoreArg -> LintM Type +lintCoreArg = lintCoreArg0 checkTys \end{code} +The primitive version of these functions takes a check argument, +allowing a different comparison. + \begin{code} -lintCoreArg :: Type -> CoreArg -> LintM Type +lintCoreArgs0 check_tys ty [] = returnL ty +lintCoreArgs0 check_tys ty (a : args) + = lintCoreArg0 check_tys ty a `thenL` \ res -> + lintCoreArgs0 check_tys res args -lintCoreArg ty a@(Type arg_ty) +lintCoreArg0 check_tys ty a@(Type arg_ty) = lintTy arg_ty `seqL` lintTyApp ty arg_ty -lintCoreArg fun_ty arg +lintCoreArg0 check_tys fun_ty arg = -- Make sure function type matches argument lintCoreExpr arg `thenL` \ arg_ty -> - case (splitFunTy_maybe fun_ty) of - Just (arg,res) | (arg_ty == arg) -> returnL res - _ -> addErrL (mkAppMsg fun_ty arg_ty) + let + err = mkAppMsg fun_ty arg_ty + in + case splitFunTy_maybe fun_ty of + Just (arg,res) -> check_tys arg arg_ty err `seqL` + returnL res + _ -> addErrL err \end{code} \begin{code} @@ -327,6 +371,7 @@ lintTyApp ty arg_ty Nothing -> addErrL (mkTyAppMsg ty arg_ty) Just (tyvar,body) -> + if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else let tyvar_kind = tyVarKind tyvar argty_kind = typeKind arg_ty @@ -358,6 +403,8 @@ 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 @@ -418,7 +465,7 @@ 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))) + mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg))) (mkUnboxedTupleMsg arg)) args `seqL` addInScopeVars args ( @@ -438,7 +485,8 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) )) where mk_arg b | isTyVar b = Type (mkTyVarTy b) - | otherwise = Var b + | isId b = Var b + | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b) \end{code} %************************************************************************ @@ -451,6 +499,7 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) lintBinder :: Var -> LintM () lintBinder v = nopL -- ToDo: lint its type +-- ToDo: lint its rules lintTy :: Type -> LintM () lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` @@ -469,7 +518,8 @@ lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` type LintM a = [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag ErrMsg -- Error messages so far - -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any) + -> Bag WarnMsg -- Warning messages so far + -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any) data LintLocInfo = RhsOf Id -- The variable bound @@ -481,31 +531,31 @@ data LintLocInfo \end{code} \begin{code} -initL :: LintM a -> Maybe Message +initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -}) initL m - = case (m [] emptyVarSet emptyBag) of { (_, errs) -> - if isEmptyBag errs then - Nothing - else - Just (pprBagOfErrors errs) - } + = 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) returnL :: a -> LintM a -returnL r loc scope errs = (Just r, errs) +returnL r loc scope errs warns = (Just r, errs, warns) nopL :: LintM a -nopL loc scope errs = (Nothing, errs) +nopL loc scope errs warns = (Nothing, errs, warns) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k loc scope errs - = case m loc scope errs of - (Just r, errs') -> k r loc scope errs' - (Nothing, errs') -> (Nothing, errs') +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') seqL :: LintM a -> LintM b -> LintM b -seqL m k loc scope errs - = case m loc scope errs of - (_, errs') -> k loc scope errs' +seqL m k loc scope errs warns + = case m loc scope errs warns of + (_, errs', warns') -> k loc scope errs' warns' mapL :: (a -> LintM b) -> [a] -> LintM [b] mapL f [] = returnL [] @@ -517,16 +567,19 @@ mapL f (x:xs) \begin{code} checkL :: Bool -> Message -> LintM () -checkL True msg loc scope errs = (Nothing, errs) -checkL False msg loc scope errs = (Nothing, addErr errs msg loc) +checkL True msg = nopL +checkL False msg = addErrL msg addErrL :: Message -> LintM a -addErrL msg loc scope errs = (Nothing, addErr errs msg loc) +addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns) -addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg +addWarnL :: Message -> LintM a +addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc) +addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg +-- errors or warnings, actually... they're the same type. addErr errs_so_far msg locs - = ASSERT (not (null locs)) + = ASSERT( not (null locs) ) errs_so_far `snocBag` mk_msg msg where (loc, cxt1) = dumpLoc (head locs) @@ -539,12 +592,12 @@ addErr errs_so_far msg locs | otherwise = addErrLocHdrLine loc context msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m loc scope errs - = m (extra_loc:loc) scope errs +addLoc extra_loc m loc scope errs warns + = m (extra_loc:loc) scope errs warns addInScopeVars :: [Var] -> LintM a -> LintM a -addInScopeVars ids m loc scope errs - = m loc (scope `unionVarSet` mkVarSet ids) errs +addInScopeVars ids m loc scope errs warns + = m loc (scope `unionVarSet` mkVarSet ids) errs warns \end{code} \begin{code} @@ -560,28 +613,18 @@ checkBndrIdInScope binder id ppr binder checkInScope :: SDoc -> Var -> LintM () -checkInScope loc_msg var loc scope errs - | isLocallyDefined var - && not (var `elemVarSet` scope) - && not (isId var && mayHaveNoBinding var) - -- Micro-hack here... Class decls generate applications of their - -- dictionary constructor, but don't generate a binding for the - -- constructor (since it would never be used). After a single round - -- of simplification, these dictionary constructors have been - -- inlined (from their UnfoldInfo) to CoCons. Just between - -- desugaring and simplfication, though, they appear as naked, unbound - -- variables as the function in an application. - -- The hack here simply doesn't check for out-of-scope-ness for - -- data constructors (at least, in a function position). - -- Ditto primitive Ids - = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) +checkInScope loc_msg var loc scope errs warns + | mustHaveLocalBinding var && not (var `elemVarSet` scope) + = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns) | otherwise - = (Nothing,errs) + = nopL loc scope errs warns checkTys :: Type -> Type -> Message -> LintM () -checkTys ty1 ty2 msg loc scope errs - | ty1 == ty2 = (Nothing, errs) - | otherwise = (Nothing, addErr errs msg loc) +-- 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 \end{code} @@ -598,7 +641,10 @@ dumpLoc (RhsOf v) dumpLoc (LambdaBodyOf b) = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)) -dumpLoc (BodyOfLetRec bs) +dumpLoc (BodyOfLetRec []) + = (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)) dumpLoc (AnExpr e) @@ -610,11 +656,12 @@ dumpLoc (CaseAlt (con, args, rhs)) dumpLoc (ImportedUnfolding locn) = (locn, brackets (ptext SLIT("in an imported unfolding"))) -pp_binders :: [Id] -> SDoc +pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) -pp_binder :: Id -> SDoc -pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] +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)] \end{code} \begin{code} @@ -663,6 +710,7 @@ mkBadPatMsg con_result_ty scrut_ty ------------------------------------------------------ -- Other error messages +mkAppMsg :: Type -> Type -> Message mkAppMsg fun arg = vcat [ptext SLIT("Argument value doesn't match argument type:"), hang (ptext SLIT("Fun type:")) 4 (ppr fun),