From d00cf5b8622c0715a038129c6887bb677baa5996 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 20 Nov 2000 16:07:13 +0000 Subject: [PATCH] [project @ 2000-11-20 16:07:12 by simonpj] Remember local decls when no recompilation is required --- ghc/compiler/hsSyn/HsDecls.lhs | 15 ++++++++++- ghc/compiler/rename/Rename.lhs | 5 +++- ghc/compiler/rename/RnEnv.lhs | 5 ---- ghc/compiler/rename/RnHiFiles.lhs | 47 +++++++++++---------------------- ghc/compiler/rename/RnIfaces.lhs | 21 +++++---------- ghc/compiler/rename/RnNames.lhs | 4 +-- ghc/compiler/typecheck/TcInstDcls.lhs | 5 ++-- ghc/compiler/types/InstEnv.lhs | 14 +++++++--- 8 files changed, 55 insertions(+), 61 deletions(-) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 7fe9bf4..c464de5 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -14,7 +14,7 @@ module HsDecls ( ConDecl(..), ConDetails(..), BangType(..), getBangType, DeprecDecl(..), DeprecTxt, - hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, + hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames, isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls, mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName, getClassDeclSysNames, conDetailsTys @@ -215,6 +215,7 @@ isClassDecl other = False Dealing with names \begin{code} +-------------------------------- tyClDeclName :: TyClDecl name pat -> name tyClDeclName (IfaceSig name _ _ _) = name tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name @@ -222,6 +223,7 @@ tyClDeclName (TySynonym name _ _ _) = name tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name +-------------------------------- tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] -- Returns all the binding names of the decl, along with their SrcLocs -- The first one is guaranteed to be the name of the decl @@ -239,6 +241,17 @@ tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _) tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)] +-------------------------------- +tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)] +-- Similar to tyClDeclNames, but returns the "implicit" +-- or "system" names of the declaration + +tyClDeclSysNames (ClassDecl _ _ _ _ _ _ names loc) = [(n,loc) | n <- names] +tyClDeclSysNames (TyData _ _ _ _ cons _ _ _ _ _) = [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons] +tyClDeclSysNames decl = [] + + +-------------------------------- type ClassDeclSysNames name = [name] -- [tycon, datacon wrapper, datacon worker, -- superclass selector 1, ..., superclass selector n] diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index fefa9dc..41abf2e 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -22,7 +22,7 @@ import RnMonad import RnExpr ( rnExpr ) import RnNames ( getGlobalNames, exportsFromAvail ) import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) -import RnIfaces ( slurpImpDecls, mkImportInfo, +import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, getInterfaceExports, closeDecls, RecompileRequired, outOfDate, recompileRequired ) @@ -563,7 +563,10 @@ closeIfaceDecls dflags hit hst pcs needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` unionManyNameSets (map tyClDeclFVs tycl_decls) + local_names = foldl add emptyNameSet tycl_decls + add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl)) in + recordLocalSlurps local_names `thenRn_` closeDecls decls needed \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 74d6b2e..f7e34dd 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -585,11 +585,6 @@ availNames (Avail n) = [n] availNames (AvailTC n ns) = ns ------------------------------------- -addSysAvails :: AvailInfo -> [Name] -> AvailInfo -addSysAvails avail [] = avail -addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) - -------------------------------------- filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 66d0bc0..4c3b864 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -27,9 +27,8 @@ import HscTypes ( ModuleLocation(..), AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) ) import HsSyn ( TyClDecl(..), InstDecl(..), - HsType(..), ConDecl(..), - FixitySig(..), RuleDecl(..), - tyClDeclNames + HsType(..), FixitySig(..), RuleDecl(..), + tyClDeclNames, tyClDeclSysNames ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl, extractHsTyRdrNames @@ -423,45 +422,31 @@ getIfaceDeclBinders, getTyClDeclBinders -> RdrNameTyClDecl -> RnM d AvailInfo -getIfaceDeclBinders mod tycl_decl - = getTyClDeclBinders mod tycl_decl `thenRn` \ avail -> - getSysTyClDeclBinders mod tycl_decl `thenRn` \ extras -> - returnRn (addSysAvails avail extras) - -- Add the sys-binders to avail. When we import the decl, - -- it's full_avail that will get added to the 'already-slurped' set (iSlurp) - -- If we miss out sys-binders, we'll read the decl multiple times! - +----------------- getTyClDeclBinders mod (IfaceSig var ty prags src_loc) = newTopBinder mod var src_loc `thenRn` \ var_name -> returnRn (Avail var_name) getTyClDeclBinders mod tycl_decl - = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> + = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> returnRn (AvailTC main_name (main_name : sub_names)) - where - do_one (name,loc) = newTopBinder mod name loc -\end{code} - -@getDeclSysBinders@ gets the implicit binders introduced by a decl. -A the moment that's just the tycon and datacon that come with a class decl. -They aren't returned by @getDeclBinders@ because they aren't in scope; -but they {\em should} be put into the @DeclsMap@ of this module. - -Note that this excludes the default-method names of a class decl, -and the dict fun of an instance decl, because both of these have -bindings of their own elsewhere. -\begin{code} -getSysTyClDeclBinders mod (ClassDecl _ cname _ _ sigs _ names src_loc) - = sequenceRn [newTopBinder mod n src_loc | n <- names] +----------------- +getIfaceDeclBinders mod (IfaceSig var ty prags src_loc) + = newTopBinder mod var src_loc `thenRn` \ var_name -> + returnRn (Avail var_name) -getSysTyClDeclBinders mod (TyData _ _ _ _ cons _ _ _ _ _) - = sequenceRn [newTopBinder mod wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] +getIfaceDeclBinders mod tycl_decl + = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> + new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names -> + returnRn (AvailTC main_name (main_name : (sys_names ++ sub_names))) -getSysTyClDeclBinders mod other_decl - = returnRn [] +----------------- +new_top_bndrs mod names_w_locs + = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs] \end{code} + %********************************************************* %* * \subsection{Reading an interface file} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 797e180..7311439 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -344,12 +344,9 @@ recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name) | otherwise = (extendModuleSet imp_mods mod, imp_names) -recordLocalSlurps local_avails +recordLocalSlurps new_names = getIfacesRn `thenRn` \ ifaces -> - let - new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails - in - setIfacesRn (ifaces { iSlurp = new_slurped_names }) + setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names }) \end{code} @@ -603,19 +600,13 @@ data ImportDeclResult | HereItIs (Module, RdrNameTyClDecl) importDecl name - = -- STEP 1: Check if it was loaded before beginning this module - if isLocalName name then - traceRn (text "Already (local)" <+> ppr name) `thenRn_` - returnRn AlreadySlurped - else - - -- STEP 2: Check if we've slurped it in while compiling this module + = -- STEP 1: Check if we've slurped it in while compiling this module getIfacesRn `thenRn` \ ifaces -> if name `elemNameSet` iSlurp ifaces then returnRn AlreadySlurped else - -- STEP 3: Check if it's already in the type environment + -- STEP 2: Check if it's already in the type environment getTypeEnvRn `thenRn` \ lookup -> case lookup name of { Just ty_thing | name `elemNameEnv` wiredInThingEnv @@ -629,13 +620,13 @@ importDecl name Nothing -> - -- STEP 4: OK, we have to slurp it in from an interface file + -- STEP 3: OK, we have to slurp it in from an interface file -- First load the interface file traceRn nd_doc `thenRn_` loadHomeInterface nd_doc name `thenRn_` getIfacesRn `thenRn` \ ifaces -> - -- STEP 5: Get the declaration out + -- STEP 4: Get the declaration out let (decls_map, _) = iDecls ifaces in diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index a739648..571ee3a 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -183,10 +183,10 @@ importsFromLocalDecls this_mod decls (_, dups) = removeDups compare all_names in -- Check for duplicate definitions - mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` + mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` -- Record that locally-defined things are available - recordLocalSlurps avails `thenRn_` + recordLocalSlurps (availsToNameSet avails) `thenRn_` -- Build the environment qualifyImports (moduleName this_mod) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 841988d..a8a3de0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -31,9 +31,9 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcInstId, tcLookupClass, InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, - newDFunName, tcExtendTyVarEnv + newDFunName, tcExtendTyVarEnv, tcGetInstEnv ) -import InstEnv ( InstEnv, extendInstEnv ) +import InstEnv ( InstEnv, extendInstEnv, pprInstEnv ) import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( zonkTcSigTyVars ) @@ -225,7 +225,6 @@ addInstDFuns dfuns infos returnTc inst_env' where bind x f = f x - \end{code} \begin{code} diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index c4b667f..8c5e678 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -9,7 +9,7 @@ The bits common to TcInstDcls and TcDeriv. module InstEnv ( DFunId, ClsInstEnv, InstEnv, - emptyInstEnv, extendInstEnv, + emptyInstEnv, extendInstEnv, pprInstEnv, lookupInstEnv, InstLookupResult(..), classInstEnv, simpleDFunClassTyCon ) where @@ -18,7 +18,7 @@ module InstEnv ( import Class ( Class ) import Var ( Id ) -import VarSet ( TyVarSet, unionVarSet, mkVarSet ) +import VarSet ( TyVarSet, unionVarSet, mkVarSet, varSetElems ) import VarEnv ( TyVarSubstEnv ) import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) import Name ( getSrcLoc ) @@ -29,7 +29,7 @@ import PprType ( ) import TyCon ( TyCon ) import Outputable import Unify ( matchTys, unifyTyListsX ) -import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM ) +import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM ) import Id ( idType ) import ErrUtils ( Message ) import CmdLineOpts @@ -55,6 +55,14 @@ simpleDFunClassTyCon dfun where (_,_,clas,[ty]) = splitDFunTy (idType dfun) tycon = tyConAppTyCon ty + +pprInstEnv :: InstEnv -> SDoc +pprInstEnv env + = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+> + brackets (pprWithCommas ppr tys) <+> ppr dfun + | cls_inst_env <- eltsUFM env + , (tyvars, tys, dfun) <- cls_inst_env + ] \end{code} %************************************************************************ -- 1.7.10.4