From a76db2a07f99716c40e05d73210f80b4e4794b9a Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 24 Oct 2000 10:36:09 +0000 Subject: [PATCH] [project @ 2000-10-24 10:36:08 by simonpj] Wibbles --- ghc/compiler/rename/Rename.lhs | 16 +++----- ghc/compiler/rename/RnIfaces.lhs | 38 +++++++++++++------ ghc/compiler/rename/RnMonad.lhs | 66 +++++++++++++++------------------ ghc/compiler/typecheck/TcDeriv.lhs | 16 +++----- ghc/compiler/typecheck/TcInstDcls.lhs | 24 +++++------- ghc/compiler/typecheck/TcModule.lhs | 16 +++----- 6 files changed, 83 insertions(+), 93 deletions(-) diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 0e1ff00..9b95413 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -50,8 +50,8 @@ import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, ) import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv ) import Type ( namesOfType, funTyCon ) -import ErrUtils ( printErrorsAndWarnings, dumpIfSet ) -import Bag ( isEmptyBag, bagToList ) +import ErrUtils ( dumpIfSet ) +import Bag ( bagToList ) import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C, elemFM, addToFM ) @@ -77,21 +77,17 @@ renameModule :: DynFlags -> Finder -> Module -> RdrNameHsModule -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl])) -renameModule dflags finder hit hst old_pcs this_module - this_mod@(HsModule _ _ _ _ _ _ loc) +renameModule dflags finder hit hst old_pcs this_module rdr_module = -- Initialise the renamer monad do { - ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs) - <- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ; - - -- Check for warnings - printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ; + (new_pcs, errors_found, (maybe_rn_stuff, dump_action)) + <- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ; -- Dump any debugging output dump_action ; -- Return results - if not (isEmptyBag rn_errs_bag) then + if errors_found then return (old_pcs, Nothing) else return (new_pcs, maybe_rn_stuff) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 28362f6..591c92e 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -10,13 +10,15 @@ module RnIfaces getImportedInstDecls, getImportedRules, lookupFixityRn, importDecl, ImportDeclResult(..), recordLocalSlurps, - mkImportInfo, getSlurped + mkImportInfo, getSlurped, + + recompileRequired ) where #include "HsVersions.h" -import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) import HscTypes import HsSyn ( HsDecl(..), InstDecl(..), HsType(..) ) import HsImpExp ( ImportDecl(..) ) @@ -300,7 +302,7 @@ mkImportInfo this_mod imports where go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far - mod_iface = lookupIface hit pit mod_name + mod_iface = lookupTableByModName hit pit mod_name `orElse` panic "mkImportInfo" mod = mi_module mod_iface is_lib_module = not (isModuleInThisPackage mod) version_info = mi_version mod_iface @@ -495,14 +497,27 @@ that we know just what instances to bring into scope. %* * %******************************************************** +@recompileRequired@ is called from the HscMain. It checks whether +a recompilation is required. It needs access to the persistent state, +finder, etc, because it may have to load lots of interface files to +check their versions. + \begin{code} type RecompileRequired = Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required -recompileRequired :: Module -> Bool -> Maybe ModIface -> RnMG RecompileRequired -recompileRequired mod source_unchanged maybe_iface - = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_` +recompileRequired :: DynFlags -> Finder + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module + -> Bool -- Source unchanged + -> Maybe ModIface -- Old interface, if any + -> IO (PersistentCompilerState, Bool, RecompileRequired) + -- True <=> errors happened +recompileRequired dflags finder hit hst pcs mod source_unchanged maybe_iface + = initRn dflags finder hit hst pcs mod $ + traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_` -- CHECK WHETHER THE SOURCE HAS CHANGED if not source_unchanged then @@ -516,8 +531,7 @@ recompileRequired mod source_unchanged maybe_iface returnRn outOfDate ; Just iface -> -- Source code unchanged and no errors yet... carry on - getHomeIfaceTableRn `thenRn` \ hit -> - checkList [checkModUsage hit u | u <- mi_usages iface] + checkList [checkModUsage u | u <- mi_usages iface] checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired checkList [] = returnRn upToDate @@ -529,12 +543,12 @@ checkList (check:checks) = check `thenRn` \ recompile -> \end{code} \begin{code} -checkModUsage :: HomeIfaceTable -> ImportVersion Name -> RnMG RecompileRequired +checkModUsage :: ImportVersion Name -> RnMG RecompileRequired -- Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage hit (mod_name, _, _, NothingAtAll) +checkModUsage (mod_name, _, _, NothingAtAll) -- If CurrentModule.hi contains -- import Foo :: ; -- then that simply records that Foo lies below CurrentModule in the @@ -542,7 +556,7 @@ checkModUsage hit (mod_name, _, _, NothingAtAll) -- In this case we don't even want to open Foo's interface. = up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name) -checkModUsage hit (mod_name, _, _, whats_imported) +checkModUsage (mod_name, _, _, whats_imported) = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> case maybe_err of { Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), @@ -552,6 +566,8 @@ checkModUsage hit (mod_name, _, _, whats_imported) -- the current module doesn't need that import and it's been deleted Nothing -> + + getHomeIfaceTableRn `thenRn` \ hit -> let mod_details = lookupTableByModName hit (iPIT ifaces) mod_name `orElse` panic "checkModUsage" diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 92f012d..fd2e8b9 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -44,7 +44,7 @@ import HscTypes ( Finder, HomeSymbolTable, PackageSymbolTable, PersistentCompilerState(..), GlobalRdrEnv, HomeIfaceTable, PackageIfaceTable, - RdrAvailInfo, ModIface ) + RdrAvailInfo ) import BasicTypes ( Version, defaultFixity ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message @@ -59,17 +59,18 @@ import Name ( Name, OccName, NamedThing(..), getSrcLoc, NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) -import Module ( Module, ModuleName, lookupModuleEnvByName ) +import Module ( Module, ModuleName ) import NameSet import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import SrcLoc ( SrcLoc, generatedSrcLoc ) +import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc ) import Unique ( Unique ) import FiniteMap ( FiniteMap, emptyFM ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable import PrelNames ( mkUnboundName ) -import Maybes ( maybeToBool, seqMaybe, orElse ) +import Maybes ( maybeToBool, seqMaybe ) +import ErrUtils ( printErrorsAndWarnings ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -285,28 +286,38 @@ type IsLoaded = Bool %************************************************************************ \begin{code} -initRn :: DynFlags - -> Finder - -> HomeIfaceTable - -> HomeSymbolTable +initRn :: DynFlags -> Finder + -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState - -> Module - -> SrcLoc + -> Module -> RnMG t - -> IO (t, (Bag WarnMsg, Bag ErrMsg), PersistentCompilerState) + -> IO (PersistentCompilerState, Bool, t) + -- True <=> found errors -initRn dflags finder hit hst pcs mod loc do_rn +initRn dflags finder hit hst pcs mod do_rn = do let prs = pcs_PRS pcs let pst = pcs_PST pcs + let ifaces = Ifaces { iPIT = pcs_PIT pcs, + iDecls = prsDecls prs, + iInsts = prsInsts prs, + iRules = prsRules prs, + + iImpModInfo = emptyFM, + iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), + -- Pretend that the dummy unbound name has already been + -- slurped. This is what's returned for an out-of-scope name, + -- and we don't want thereby to try to suck it in! + iVSlurp = [] + } let uniqs = prsNS prs names_var <- newIORef (uniqs, origNames (prsOrig prs), origIParam (prsOrig prs)) errs_var <- newIORef (emptyBag,emptyBag) - iface_var <- newIORef (initIfaces pcs) + iface_var <- newIORef ifaces let rn_down = RnDown { rn_mod = mod, - rn_loc = loc, + rn_loc = noSrcLoc, rn_finder = finder, rn_dflags = dflags, @@ -334,34 +345,15 @@ initRn dflags finder hit hst pcs mod loc do_rn let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, pcs_PRS = new_prs } - return (res, (warns, errs), new_pcs) + -- Check for warnings + printErrorsAndWarnings (warns, errs) ; + + return (new_pcs, not (isEmptyBag errs), res) is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool -- Returns True iff the name is in either symbol table is_done hst pst n = maybeToBool (lookupTypeEnv pst n `seqMaybe` lookupTypeEnv hst n) -lookupIface :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> ModIface -lookupIface hit pit mod = lookupModuleEnvByName hit mod `orElse` - lookupModuleEnvByName pit mod `orElse` - pprPanic "lookupIface" (ppr mod) - -initIfaces :: PersistentCompilerState -> Ifaces -initIfaces (PCS { pcs_PIT = pit, pcs_PRS = prs }) - = Ifaces { iPIT = pit, - iDecls = prsDecls prs, - iInsts = prsInsts prs, - iRules = prsRules prs, - - iImpModInfo = emptyFM, - iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), - -- Pretend that the dummy unbound name has already been - -- slurped. This is what's returned for an out-of-scope name, - -- and we don't want thereby to try to suck it in! - iVSlurp = [] - } - - -initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode -> RnMS r -> RnM d r initRnMS rn_env fixity_env mode thing_inside rn_down g_down = let s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index dac3e4a..ac28035 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -16,7 +16,7 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds ) import CmdLineOpts ( DynFlag(..), DynFlags ) import TcMonad -import TcEnv ( TcEnv, tcSetInstEnv, getTcGST, newDFunName ) +import TcEnv ( TcEnv, tcSetInstEnv, newDFunName ) import TcGenDeriv -- Deriv stuff import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, simpleDFunClassTyCon, extendInstEnv ) @@ -26,33 +26,29 @@ import RnBinds ( rnMethodBinds, rnTopMonoBinds ) import RnEnv ( bindLocatedLocalsRn ) import RnMonad ( --RnNameSupply, renameSourceCode, thenRn, mapRn, returnRn ) -import HscTypes ( DFunId, GlobalSymbolTable, PersistentRenamerState ) +import HscTypes ( DFunId, PersistentRenamerState ) import BasicTypes ( Fixity ) -import Bag ( Bag, emptyBag, unionBags, listToBag ) import Class ( classKey, Class ) import ErrUtils ( dumpIfSet_dyn, Message ) import MkId ( mkDictFunId ) -import Id ( mkVanillaId, idType ) +import Id ( idType ) import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) -import Name ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) ) +import Name ( Name, isLocallyDefined, getSrcLoc ) import RdrName ( RdrName ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, - isEnumerationTyCon, isAlgTyCon, TyCon + isEnumerationTyCon, TyCon ) import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, - mkSigmaTy, splitDFunTy, mkDictTy, - isUnboxedType, splitAlgTyConApp, classesToPreds + splitDFunTy, isUnboxedType ) -import TysWiredIn ( voidTy ) import Var ( TyVar ) import PrelNames -import Bag ( bagToList ) import Util ( zipWithEqual, sortLt, thenCmp ) import ListSetOps ( removeDups, assoc ) import Outputable diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 571ebf7..12e853d 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -11,11 +11,10 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where import CmdLineOpts ( DynFlag(..), dopt ) -import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), InPat(..), - MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), Match(..), +import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), + MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), andMonoBindList, collectMonoBinders, isClassDecl ) -import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar ) import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, extractHsTyVars, maybeGenericMatch @@ -29,25 +28,23 @@ import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) import TcEnv ( TcEnv, tcExtendGlobalValEnv, - tcExtendTyVarEnvForMeths, TyThing (..), + tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcInstId, tcLookupClass, newDFunName, tcExtendTyVarEnv ) import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon, simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst, extendInstEnv ) -import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType ) +import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( zonkTcSigTyVars ) import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId, ModDetails(..) ) -import Bag ( emptyBag, unitBag, unionBags, unionManyBags, - foldBag, Bag, listToBag - ) +import Bag ( unionManyBags ) import Class ( Class, DefMeth(..), classBigSig ) import Var ( idName, idType ) -import Maybes ( maybeToBool, expectJust ) +import Maybes ( maybeToBool ) import MkId ( mkDictFunId ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) @@ -58,7 +55,7 @@ import PprType ( pprConstraint, pprPred ) import TyCon ( TyCon, isSynTyCon, tyConDerivings ) import Type ( mkTyVarTys, splitDFunTy, isTyVarTy, splitTyConApp_maybe, splitDictTy, - splitAlgTyConApp_maybe, classesToPreds, classesOfPreds, + splitAlgTyConApp_maybe, unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy, getClassTys_maybe ) @@ -66,12 +63,9 @@ import Subst ( mkTopTyVarSubst, substClasses, substTheta ) import VarSet ( mkVarSet, varSetElems ) import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) -import Name ( Name, NameEnv, extendNameEnv_C, emptyNameEnv, - plusNameEnv_C, nameEnvElts ) -import FiniteMap ( mapFM ) +import Name ( Name ) import SrcLoc ( SrcLoc ) import VarSet ( varSetElems ) -import UniqFM ( mapUFM ) import Unique ( Uniquable(..) ) import BasicTypes ( NewOrData(..), Fixity ) import ErrUtils ( dumpIfSet_dyn ) @@ -79,7 +73,7 @@ import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, assocElts, extendAssoc_C, equivClassesByUniq, minusList ) -import List ( intersect, (\\), partition ) +import List ( partition ) import Outputable \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index a47d783..d0e1993 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -21,7 +21,7 @@ import TcHsSyn ( TypecheckedMonoBinds, ) import TcMonad -import Inst ( emptyLIE, plusLIE ) +import Inst ( plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) @@ -47,16 +47,13 @@ import Module ( Module, moduleName, plusModuleEnv ) import Name ( Name, nameOccName, isLocallyDefined, isGlobalName, toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv ) -import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo ) +import TyCon ( tyConGenInfo, isClassTyCon ) import OccName ( isSysOcc ) -import TyCon ( TyCon, isClassTyCon ) -import Class ( Class ) import PrelNames ( mAIN_Name, mainName ) -import UniqSupply ( UniqSupply ) -import Maybes ( maybeToBool, thenMaybe ) +import Maybes ( thenMaybe ) import Util import BasicTypes ( EP(..), Fixity ) -import Bag ( Bag, isEmptyBag ) +import Bag ( isEmptyBag ) import Outputable import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable, PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..), @@ -135,7 +132,6 @@ tcModule pcs hst get_fixity this_mod decls unf_env let classes = tcEnvClasses env tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes - local_classes = filter isLocallyDefined classes local_tycons = [ tc | tc <- tycons, isLocallyDefined tc, not (isClassTyCon tc) @@ -295,8 +291,8 @@ printTcDump dflags (Just (_,results)) dump_tc results = vcat [ppr (tc_binds results), - pp_rules (tc_rules results) --, --- ppr_gen_tycons (tc_tycons results) + pp_rules (tc_rules results), + ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] ] dump_sigs results -- Print type signatures -- 1.7.10.4