X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=c5315ec7e0ede0b28896a2b387343169b57ff2ee;hb=dea9b472bd8df7381ffac9305a6a367569826503;hp=7881f4a6ac1227b82736c19a39d7c49bf8072d47;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 7881f4a..c5315ec 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -7,41 +7,41 @@ module CoreLint ( lintCoreBindings, lintUnfolding, - beginPass, endPass + showPass, 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 Rules ( RuleBase, pprRuleBase ) import CoreFVs ( idFreeVars ) -import CoreUtils ( exprOkForSpeculation ) +import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType ) import Bag -import Literal ( Literal, literalType ) -import DataCon ( DataCon, dataConRepType ) -import Id ( mayHaveNoBinding, isDeadBinder ) -import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId ) +import Literal ( literalType ) +import DataCon ( dataConRepType ) +import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding ) 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(..) ) -import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc ) -import Type ( Type, Kind, tyVarsOfType, - splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy, - splitForAllTy_maybe, splitTyConApp_maybe, +import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass, + ErrMsg, addErrLocHdrLine, pprBagOfErrors, + WarnMsg, pprBagOfWarnings) +import SrcLoc ( SrcLoc, noSrcLoc ) +import Type ( Type, tyVarsOfType, + splitFunTy_maybe, mkTyVarTy, + splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, isUnLiftedType, typeKind, - splitAlgTyConApp_maybe, isUnboxedTupleType, hasMoreBoxityInfo ) -import TyCon ( TyCon, isPrimTyCon, tyConDataCons ) +import TyCon ( isPrimTyCon ) import BasicTypes ( RecFlag(..), isNonRec ) +import CmdLineOpts +import Maybe import Outputable infixr 9 `thenL`, `seqL` @@ -58,32 +58,37 @@ place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -beginPass :: String -> IO () -beginPass pass_name - | opt_D_show_passes - = hPutStrLn stderr ("*** " ++ pass_name) - | otherwise - = return () - - -endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind] -endPass pass_name dump_flag binds +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 opt_D_show_passes then + if verbosity dflags >= 2 then hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds)) else return () -- Report verbosely, if required - dumpIfSet dump_flag pass_name - (pprCoreBindings binds) + dumpIfSet_core dflags dump_flag pass_name + (pprCoreBindings binds $$ case rules of + Nothing -> empty + Just rb -> pprRuleBase rb) -- Type check - lintCoreBindings pass_name binds + lintCoreBindings dflags pass_name binds + -- ToDo: lint the rules - return binds + return (binds, rules) \end{code} @@ -118,19 +123,21 @@ Outstanding issues: -- may well be happening...); \begin{code} -lintCoreBindings :: String -> [CoreBind] -> IO () +lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () -lintCoreBindings whoDunnit binds - | not opt_DoCoreLinting +lintCoreBindings dflags whoDunnit binds + | not (dopt Opt_DoCoreLinting dflags) = return () -lintCoreBindings whoDunnit binds +lintCoreBindings dflags 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 +149,24 @@ lintCoreBindings whoDunnit binds returnL () lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) - display bad_news + 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 ++ " ***"), 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 ***") @@ -162,19 +183,20 @@ We use this to check all unfoldings that come in from interfaces (it is very painful to catch errors otherwise): \begin{code} -lintUnfolding :: SrcLoc +lintUnfolding :: DynFlags + -> 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 +lintUnfolding dflags locn vars expr + | not (dopt Opt_DoCoreLinting dflags) + = (Nothing, Nothing) | otherwise = initL (addLoc (ImportedUnfolding locn) $ - addInScopeVars vars $ - lintCoreExpr expr) + addInScopeVars vars $ + lintCoreExpr expr) \end{code} %************************************************************************ @@ -197,7 +219,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 +250,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 +275,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 +304,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 +322,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 +364,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 +396,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 +458,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 ( @@ -427,7 +467,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. - case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) -> + 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 -> checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) @@ -438,7 +478,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 +492,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 +511,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 +524,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 +560,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) @@ -534,17 +580,15 @@ addErr errs_so_far msg locs context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 | otherwise = cxt1 - mk_msg msg - | isNoSrcLoc loc = (loc, hang context 4 msg) - | otherwise = addErrLocHdrLine loc context msg + mk_msg msg = 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 +604,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 +632,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 +647,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 +701,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),