X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=15146ec4ecf06652895e14c7ce8f53b4629d36da;hb=6b1119bd56511dbf4563efddcd485893f3bff8bf;hp=b3de053517497ffd381bcfc848d71f4691f73dad;hpb=30b5ebe424ebae69b162ac3fc547eb14d898535f;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index b3de053..15146ec 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -7,40 +7,40 @@ module CoreLint ( lintCoreBindings, lintUnfolding, - beginPass, endPass + showPass, endPass ) where #include "HsVersions.h" -import IO ( hPutStr, hPutStrLn, stderr ) +import IO ( hPutStr, hPutStrLn, stdout ) -import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug ) import CoreSyn import CoreFVs ( idFreeVars ) -import CoreUtils ( exprOkForSpeculation ) +import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType ) import Bag -import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt ) -import Id ( mayHaveNoBinding ) -import Var ( IdOrTyVar, 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 Subst ( substTyWith ) +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, + addErrLocHdrLine ) +import SrcLoc ( SrcLoc, noSrcLoc ) +import Type ( Type, tyVarsOfType, eqType, + 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 Util ( notNull ) import Outputable infixr 9 `thenL`, `seqL` @@ -48,39 +48,30 @@ infixr 9 `thenL`, `seqL` %************************************************************************ %* * -\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} -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 -- 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 stderr (" 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) -- Type check - lintCoreBindings pass_name binds + lintCoreBindings dflags pass_name binds return binds \end{code} @@ -117,17 +108,15 @@ 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 -> done_lint Just bad_news -> printDump (display bad_news) >> ghcExit 1 where @@ -141,9 +130,11 @@ lintCoreBindings 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")) + display bad_news - = vcat [ - text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), + = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), bad_news, ptext SLIT("*** Offending Program ***"), pprCoreBindings binds, @@ -162,18 +153,14 @@ We use this to check all unfoldings that come in from interfaces \begin{code} lintUnfolding :: SrcLoc - -> [IdOrTyVar] -- Treat these as in scope + -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe Message -- Nothing => OK + -> Maybe Message -- Nothing => OK lintUnfolding locn vars expr - | not opt_DoCoreLinting - = Nothing - - | otherwise = initL (addLoc (ImportedUnfolding locn) $ - addInScopeVars vars $ - lintCoreExpr expr) + addInScopeVars vars $ + lintCoreExpr expr) \end{code} %************************************************************************ @@ -196,7 +183,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 @@ -220,12 +208,13 @@ lintSingleBinding rec_flag (binder,rhs) lintCoreExpr :: CoreExpr -> LintM Type lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var) +lintCoreExpr (Lit lit) = returnL (literalType lit) 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) @@ -243,11 +232,6 @@ lintCoreExpr (Let (Rec pairs) body) where bndrs = map fst pairs -lintCoreExpr e@(Con con args) - = addLoc (AnExpr e) $ - checkL (conOkForApp con) (mkConAppMsg e) `seqL` - lintCoreArgs (conType con) args - lintCoreExpr e@(App fun arg) = lintCoreExpr fun `thenL` \ ty -> addLoc (AnExpr e) $ @@ -255,10 +239,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) @@ -280,7 +268,8 @@ 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` returnL alt_ty) @@ -297,31 +286,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} @@ -330,6 +328,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 @@ -340,7 +339,7 @@ lintTyApp ty arg_ty -- 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) @@ -361,44 +360,30 @@ lintTyApps fun_ty (arg_ty : arg_tys) %************************************************************************ \begin{code} -checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e) - -checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL - -checkAllCasesCovered e scrut_ty alts - = case splitTyConApp_maybe scrut_ty of { - Nothing -> addErrL (badAltsMsg e); - Just (tycon, tycon_arg_tys) -> - - 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 +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 - 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 + non_deflt (DEFAULT, _, _) = False + non_deflt alt = True + + is_infinite_ty = case splitTyConApp_maybe ty of + Nothing -> False + Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon \end{code} \begin{code} @@ -410,12 +395,18 @@ lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs) = checkL (null args) (mkDefaultArgsMsg args) `seqL` lintCoreExpr rhs -lintCoreAlt scrut_ty alt@(con, args, rhs) - = addLoc (CaseAlt alt) ( +lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs) + = checkL (null args) (mkDefaultArgsMsg args) `seqL` + checkTys lit_ty scrut_ty + (mkBadPatMsg lit_ty scrut_ty) `seqL` + lintCoreExpr rhs + where + lit_ty = literalType lit - checkL (conOkForAlt con) (mkConAltMsg con) `seqL` +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 ( @@ -424,9 +415,10 @@ lintCoreAlt scrut_ty alt@(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) -> - lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type -> - lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> + -- 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 -> checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) } `seqL` @@ -435,7 +427,8 @@ lintCoreAlt scrut_ty alt@(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} %************************************************************************ @@ -445,9 +438,10 @@ lintCoreAlt scrut_ty alt@(con, args, rhs) %************************************************************************ \begin{code} -lintBinder :: IdOrTyVar -> LintM () +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` @@ -465,8 +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 - -> (Maybe a, Bag ErrMsg) -- Result and error 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 @@ -478,14 +472,11 @@ data LintLocInfo \end{code} \begin{code} -initL :: LintM a -> Maybe Message +initL :: LintM a -> Maybe Message {- errors -} initL m - = case (m [] emptyVarSet emptyBag) of { (_, errs) -> - if isEmptyBag errs then - Nothing - else - Just (pprBagOfErrors errs) - } + = 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 = (Just r, errs) @@ -514,16 +505,15 @@ 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) -addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg - +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) @@ -531,54 +521,42 @@ 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 -addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a +addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars ids m loc scope errs = m loc (scope `unionVarSet` mkVarSet ids) errs \end{code} \begin{code} -checkIdInScope :: IdOrTyVar -> LintM () +checkIdInScope :: Var -> LintM () checkIdInScope id = checkInScope (ptext SLIT("is out of scope")) id -checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM () +checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id = checkInScope msg id where msg = ptext SLIT("is out of scope inside info for") <+> ppr binder -checkInScope :: SDoc -> IdOrTyVar -> LintM () +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 + | mustHaveLocalBinding var && not (var `elemVarSet` scope) = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) | otherwise - = (Nothing,errs) + = nopL loc scope errs 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 `eqType` ty2 = nopL + | otherwise = addErrL msg \end{code} @@ -595,7 +573,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) @@ -607,32 +588,24 @@ 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} ------------------------------------------------------ -- Messages for case expressions -mkConAppMsg :: CoreExpr -> Message -mkConAppMsg e - = hang (text "Application of newtype constructor:") - 4 (ppr e) - -mkConAltMsg :: Con -> Message -mkConAltMsg con - = text "PrimOp in case pattern:" <+> ppr con - mkNullAltsMsg :: CoreExpr -> Message mkNullAltsMsg e = hang (text "Case expression with no alternatives:") 4 (ppr e) -mkDefaultArgsMsg :: [IdOrTyVar] -> Message +mkDefaultArgsMsg :: [Var] -> Message mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) @@ -648,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