X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=a5785ac1311a976f0369aa284f27e6fc2610c75f;hb=4a486aef4c0834a641a97b483f12fd2290fde225;hp=e5744e1b17780159718afa3faa797826d7ae7f62;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index e5744e1..a5785ac 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -7,7 +7,7 @@ module CoreLint ( lintCoreBindings, lintUnfolding, - showPass, endPass, endPassWithRules + showPass, endPass ) where #include "HsVersions.h" @@ -15,7 +15,6 @@ module CoreLint ( import IO ( hPutStr, hPutStrLn, stdout ) import CoreSyn -import Rules ( RuleBase, pprRuleBase ) import CoreFVs ( idFreeVars ) import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType ) @@ -24,12 +23,11 @@ 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) + addErrLocHdrLine ) import SrcLoc ( SrcLoc, noSrcLoc ) import Type ( Type, tyVarsOfType, eqType, splitFunTy_maybe, mkTyVarTy, @@ -42,6 +40,7 @@ import TyCon ( isPrimTyCon ) import BasicTypes ( RecFlag(..), isNonRec ) import CmdLineOpts import Maybe +import Util ( notNull ) import Outputable infixr 9 `thenL`, `seqL` @@ -49,28 +48,18 @@ 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} 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 @@ -79,16 +68,12 @@ endPassWithRules dflags pass_name dump_flag binds rules 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} @@ -375,7 +360,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) @@ -451,6 +436,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 -> @@ -494,9 +480,9 @@ 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 + -> Bag Message -- Warning messages so far + -> (Maybe a, Bag Message, Bag Message) -- Result and error/warning messages (if any) data LintLocInfo = RhsOf Id -- The variable bound @@ -511,11 +497,12 @@ data LintLocInfo initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -}) initL m = case m [] emptyVarSet emptyBag emptyBag of - (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors, - ifNonEmptyBag warns pprBagOfWarnings) + (_, errs, warns) -> (ifNonEmptyBag errs, + ifNonEmptyBag warns) where - ifNonEmptyBag bag f | isEmptyBag bag = Nothing - | otherwise = Just (f bag) + ifNonEmptyBag bag + | isEmptyBag bag = Nothing + | otherwise = Just (vcat (punctuate (text "") (bagToList bag))) returnL :: a -> LintM a returnL r loc scope errs warns = (Just r, errs, warns) @@ -550,10 +537,10 @@ checkL False msg = addErrL msg addErrL :: Message -> LintM a addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns) -addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg +addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message -- errors or warnings, actually... they're the same type. 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)