From 3721dd37a707d2aacb5cac814410a78096e28a2c Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 5 Jan 2004 12:11:44 +0000 Subject: [PATCH] [project @ 2004-01-05 12:11:42 by simonpj] --------------------------------------- Don't expose constructors as vigorously --------------------------------------- GHC used to expose the constructors of a data type in the interface file, even if (a) we were not optimising, and (b) the constructors are not exported. In practice this isn't really necessary, and it's bad because it forces too much recompilation. I've been meaning to fix this for some while. Now the data cons are hidden, even in the interface file, if both (a) and (b) are true. That means less interface file wobbling. Mind you, the interface file still changes, because the to/from functions for generic type classes change their types. But provided you don't use them, you'll get "compilation not required". We could play the same game for classes (by hiding their class ops) but that'd mean we'd have to change the data type for IfaceClassDecl, and I can't be bothered to do that today. It's unusual to have a class which exports none of its methods anyway. On the way, I changed the representation of tcg_exports and mg_exports (from Avails to NameSet), but that should be externally invisible. --- ghc/compiler/deSugar/Desugar.lhs | 4 +- ghc/compiler/iface/IfaceSyn.lhs | 18 ++++---- ghc/compiler/iface/MkIface.lhs | 64 +++++++++++++------------ ghc/compiler/main/HscTypes.lhs | 2 +- ghc/compiler/rename/RnNames.lhs | 82 +++++++++++++-------------------- ghc/compiler/typecheck/TcRnDriver.lhs | 14 +++--- ghc/compiler/typecheck/TcRnMonad.lhs | 2 +- ghc/compiler/typecheck/TcRnTypes.lhs | 2 +- 8 files changed, 88 insertions(+), 100 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index ac50a01..2deb343 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -233,9 +233,7 @@ addExportFlags ghci_mode exports keep_alive bndrs prs rules -- introduced by the type checker. is_exported :: Name -> Bool is_exported | ghci_mode == Interactive = isExternalName - | otherwise = (`elemNameSet` export_fvs) - - export_fvs = availsToNameSet exports + | otherwise = (`elemNameSet` exports) ppr_ds_rules [] = empty ppr_ds_rules rules diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 6ad7b07..12fd982 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -46,7 +46,7 @@ import NewDemand ( isTopSig ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), arityInfo, cafInfo, newStrictnessInfo, workerInfo, unfoldingInfo, inlinePragInfo ) -import TyCon ( ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon, +import TyCon ( TyCon, ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon, isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn, @@ -399,16 +399,17 @@ ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a \begin{code} -tyThingToIfaceDecl :: Bool -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl -tyThingToIfaceDecl discard_prags ext (AnId id) +tyThingToIfaceDecl :: Bool -> (TyCon -> Bool) + -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl +tyThingToIfaceDecl discard_id_info _ ext (AnId id) = IfaceId { ifName = getOccName id, ifType = toIfaceType ext (idType id), ifIdInfo = info } where - info | discard_prags = NoInfo - | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id)) + info | discard_id_info = NoInfo + | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id)) -tyThingToIfaceDecl _ ext (AClass clas) +tyThingToIfaceDecl _ _ ext (AClass clas) = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, @@ -434,7 +435,7 @@ tyThingToIfaceDecl _ ext (AClass clas) toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) -tyThingToIfaceDecl _ ext (ATyCon tycon) +tyThingToIfaceDecl _ discard_data_cons ext (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, @@ -473,6 +474,7 @@ tyThingToIfaceDecl _ ext (ATyCon tycon) new_or_data | isNewTyCon tycon = NewType | otherwise = DataType + ifaceConDecls _ | discard_data_cons tycon = Unknown ifaceConDecls Unknown = Unknown ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) @@ -490,7 +492,7 @@ tyThingToIfaceDecl _ ext (ATyCon tycon) -- This case only happens in the call to ifaceThing in InteractiveUI -- Otherwise DataCons are filtered out in ifaceThing_acc -tyThingToIfaceDecl _ ext (ADataCon dc) +tyThingToIfaceDecl _ _ ext (ADataCon dc) = IfaceId { ifName = getOccName dc, ifType = toIfaceType ext full_ty, ifIdInfo = NoInfo } diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 4dad85a..f577371 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -201,14 +201,16 @@ import HscTypes ( ModIface(..), import CmdLineOpts import Name ( Name, nameModule, nameOccName, nameParent, isExternalName, - nameParent_maybe, isWiredInName, NamedThing(..) ) + nameParent_maybe, isWiredInName, NamedThing(..), nameModuleName ) import NameEnv import NameSet import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv_C, OccSet, emptyOccSet, elemOccSet, occSetElts, extendOccSet, extendOccSetList, - isEmptyOccSet, intersectOccSet, intersectsOccSet ) -import TyCon ( visibleDataCons ) + isEmptyOccSet, intersectOccSet, intersectsOccSet, + occNameFS, isTcOcc ) +import TyCon ( visibleDataCons, tyConDataCons ) +import DataCon ( dataConName ) import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ModLocation(..), mkSysModuleNameFS, moduleUserString, ModuleEnv, emptyModuleEnv, lookupModuleEnv, @@ -227,6 +229,7 @@ import FastString import DATA_IOREF ( writeIORef ) import Monad ( when ) +import List ( insert ) import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust ) \end{code} @@ -261,7 +264,7 @@ mkIface hsc_env location maybe_old_iface = do { eps <- hscEPS hsc_env ; let { this_mod_name = moduleName this_mod ; ext_nm = mkExtNameFn hsc_env eps this_mod_name - ; decls = [ tyThingToIfaceDecl omit_prags ext_nm thing + ; decls = [ tyThingToIfaceDecl omit_prags omit_data_cons ext_nm thing | thing <- typeEnvElts type_env , not (isImplicitTyThing thing) && not (isWiredInName (getName thing)) ] -- Don't put implicit Ids and class tycons in the interface file @@ -281,7 +284,7 @@ mkIface hsc_env location maybe_old_iface mi_boot = False, mi_deps = deps, mi_usages = usages, - mi_exports = groupAvails exports, + mi_exports = mkIfaceExports exports, mi_insts = iface_insts, mi_rules = iface_rules, mi_fixities = fixities, @@ -325,6 +328,11 @@ mkIface hsc_env location maybe_old_iface ghci_mode = hsc_mode hsc_env hi_file_path = ml_hi_file location omit_prags = dopt Opt_OmitInterfacePragmas dflags + omit_data_cons tycon -- Don't expose data constructors if none are + -- exported and we are not optimising (i.e. not omit_prags) + | omit_prags = not (any exported_data_con (tyConDataCons tycon)) + | otherwise = False + exported_data_con con = dataConName con `elemNameSet` exports deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) @@ -693,40 +701,36 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names \end{code} \begin{code} -groupAvails :: Avails -> [(ModuleName, [GenAvailInfo OccName])] +mkIfaceExports :: NameSet -> [(ModuleName, [GenAvailInfo OccName])] -- Group by module and sort by occurrence -- This keeps the list in canonical order -groupAvails avails - = [ (mkSysModuleNameFS fs, sortLt lt avails) - | (fs,avails) <- fmToList groupFM +mkIfaceExports exports + = [ (mkSysModuleNameFS fs, eltsFM avails) + | (fs, avails) <- fmToList groupFM ] where - groupFM :: FiniteMap FastString [GenAvailInfo OccName] + groupFM :: FiniteMap FastString (FiniteMap FastString (GenAvailInfo OccName)) -- Deliberately use the FastString so we -- get a canonical ordering - groupFM = foldl add emptyFM avails + groupFM = foldl add emptyFM (nameSetToList exports) - add env avail = addToFM_C (\old _ -> avail':old) env mod_fs [avail'] - where - mod_fs = moduleNameFS (moduleName avail_mod) - avail_mod = nameModule (availName avail) - avail' = sortAvail avail - - a1 `lt` a2 = availName a1 < availName a2 - -sortAvail :: AvailInfo -> GenAvailInfo OccName --- Convert to OccName, and sort the sub-names into canonical order --- The canonical order has the "main name" at the beginning --- (if it's there at all) -sortAvail (Avail n) = Avail (nameOccName n) -sortAvail (AvailTC n ns) - | n `elem` ns = AvailTC occ (occ : mk_occs (filter (/= n) ns)) - | otherwise = AvailTC occ ( mk_occs ns) - where - occ = nameOccName n - mk_occs ns = sortLt (<) (map nameOccName ns) + add env name = addToFM_C add_avail env mod_fs + (unitFM avail_fs avail) + where + occ = nameOccName name + occ_fs = occNameFS occ + mod_fs = moduleNameFS (nameModuleName name) + avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ] + | isTcOcc occ = AvailTC occ [occ] + | otherwise = Avail occ + avail_fs = occNameFS (availName avail) + add_avail avail_fm _ = addToFM_C add_item avail_fm avail_fs avail + + add_item (AvailTC p occs) _ = AvailTC p (insert occ occs) + add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name) \end{code} + %************************************************************************ %* * Load the old interface file for this module (unless diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index c57551b..5fd475c 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -275,7 +275,7 @@ data ModDetails data ModGuts = ModGuts { mg_module :: !Module, - mg_exports :: !Avails, -- What it exports + mg_exports :: !NameSet, -- What it exports mg_deps :: !Dependencies, -- What is below it, directly or otherwise mg_dir_imps :: ![Module], -- Directly-imported modules; used to -- generate initialisation code diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 656d131..62cb2db 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -565,9 +565,8 @@ type ExportAccum -- The type of the accumulating parameter of -- the main worker function in exportsFromAvail = ([ModuleName], -- 'module M's seen so far ExportOccMap, -- Tracks exported occurrence names - AvailEnv) -- The accumulated exported stuff, kept in an env - -- so we can common-up related AvailInfos -emptyExportAccum = ([], emptyOccEnv, emptyAvailEnv) + NameSet) -- The accumulated exported stuff +emptyExportAccum = ([], emptyOccEnv, emptyNameSet) type ExportOccMap = OccEnv (Name, IE RdrName) -- Tracks what a particular exported OccName @@ -578,7 +577,7 @@ type ExportOccMap = OccEnv (Name, IE RdrName) exportsFromAvail :: Bool -- False => no 'module M(..) where' header at all -> Maybe [Located (IE RdrName)] -- Nothing => no explicit export list - -> RnM Avails + -> RnM NameSet -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope @@ -601,33 +600,27 @@ exportsFromAvail explicit_mod exports exports_from_avail real_exports rdr_env imports } -exports_from_avail Nothing rdr_env - imports@(ImportAvails { imp_env = entity_avail_env }) +exports_from_avail Nothing rdr_env imports = -- Export all locally-defined things -- We do this by filtering the global RdrEnv, - -- keeping only things that are (a) qualified, - -- (b) locally defined, (c) a 'main' name - -- Then we look up in the entity-avail-env - return [ lookupAvailEnv entity_avail_env name - | gre <- globalRdrEnvElts rdr_env, - isLocalGRE gre, - let name = gre_name gre, - isNothing (nameParent_maybe name) -- Main things only - ] + -- keeping only things that are locally-defined + return (mkNameSet [ gre_name gre + | gre <- globalRdrEnvElts rdr_env, + isLocalGRE gre ]) exports_from_avail (Just export_items) rdr_env (ImportAvails { imp_qual = mod_avail_env, imp_env = entity_avail_env }) = foldlM (exports_from_litem) emptyExportAccum - export_items `thenM` \ (_, _, export_avail_map) -> - returnM (nameEnvElts export_avail_map) + export_items `thenM` \ (_, _, exports) -> + returnM exports where exports_from_litem :: ExportAccum -> Located (IE RdrName) -> RnM ExportAccum exports_from_litem acc = addLocM (exports_from_item acc) exports_from_item :: ExportAccum -> IE RdrName -> RnM ExportAccum - exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) + exports_from_item acc@(mods, occs, exports) ie@(IEModuleContents mod) | mod `elem` mods -- Duplicate export of M = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; warnIf warn_dup_exports (dupModuleExport mod) ; @@ -640,23 +633,19 @@ exports_from_avail (Just export_items) rdr_env Just avail_env -> let - mod_avails = [ filtered_avail - | avail <- availEnvElts avail_env, - let mb_avail = filter_unqual rdr_env avail, - isJust mb_avail, - let Just filtered_avail = mb_avail] - - avails' = foldl addAvail avails mod_avails + new_exports = [ name | avail <- availEnvElts avail_env, + name <- availNames avail, + inScopeUnqual rdr_env name ] in + -- This check_occs not only finds conflicts between this item -- and others, but also internally within this item. That is, -- if 'M.x' is in scope in several ways, we'll have several -- members of mod_avails with the same OccName. + check_occs ie occs new_exports `thenM` \ occs' -> + returnM (mod:mods, occs', addListToNameSet exports new_exports) - foldlM (check_occs ie) occs mod_avails `thenM` \ occs' -> - returnM (mod:mods, occs', avails') - - exports_from_item acc@(mods, occs, avails) ie + exports_from_item acc@(mods, occs, exports) ie = lookupGlobalOccRn (ieName ie) `thenM` \ name -> if isUnboundName name then returnM acc -- Avoid error cascade @@ -675,41 +664,34 @@ exports_from_avail (Just export_items) rdr_env Just export_avail -> -- Phew! It's OK! Now to check the occurrence stuff! - checkForDodgyExport ie avail `thenM_` - check_occs ie occs export_avail `thenM` \ occs' -> - returnM (mods, occs', addAvail avails export_avail) + + let + new_exports = availNames export_avail + in + checkForDodgyExport ie new_exports `thenM_` + check_occs ie occs new_exports `thenM` \ occs' -> + returnM (mods, occs', addListToNameSet exports new_exports) } ------------------------------- -filter_unqual :: GlobalRdrEnv -> AvailInfo -> Maybe AvailInfo --- Filter the Avail by what's in scope unqualified -filter_unqual env (Avail n) - | in_scope env n = Just (Avail n) - | otherwise = Nothing -filter_unqual env (AvailTC n ns) - | not (null ns') = Just (AvailTC n ns') - | otherwise = Nothing - where - ns' = filter (in_scope env) ns - -in_scope :: GlobalRdrEnv -> Name -> Bool +inScopeUnqual :: GlobalRdrEnv -> Name -> Bool -- Checks whether the Name is in scope unqualified, -- regardless of whether it's ambiguous or not -in_scope env n = any unQualOK (lookupGRE_Name env n) +inScopeUnqual env n = any unQualOK (lookupGRE_Name env n) ------------------------------- -checkForDodgyExport :: IE RdrName -> AvailInfo -> RnM () -checkForDodgyExport (IEThingAll tc) (AvailTC _ [n]) = addWarn (dodgyExportWarn tc) +checkForDodgyExport :: IE RdrName -> [Name] -> RnM () +checkForDodgyExport (IEThingAll tc) [n] = addWarn (dodgyExportWarn tc) -- This occurs when you import T(..), but -- only export T abstractly. The single [n] -- in the AvailTC is the type or class itself checkForDodgyExport _ _ = return () ------------------------------- -check_occs :: IE RdrName -> ExportOccMap -> AvailInfo -> RnM ExportOccMap -check_occs ie occs avail - = foldlM check occs (availNames avail) +check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap +check_occs ie occs names + = foldlM check occs names where check occs name = case lookupOccEnv occs name_occ of diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 2643227..295c15e 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -172,8 +172,9 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports reportDeprecations tcg_env ; -- Process the export list - export_avails <- exportsFromAvail (isJust maybe_mod) exports ; + exports <- exportsFromAvail (isJust maybe_mod) exports ; +{- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus -- Get any supporting decls for the exports that have not already -- been sucked in for the declarations in the body of the module. -- (This can happen if something is imported only to be re-exported.) @@ -184,15 +185,15 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports -- We don't need the results, but sucking them in may side-effect -- the ExternalPackageState, apart from recording usage mappM (tcLookupGlobal . availName) export_avails ; +-} -- Check whether the entire module is deprecated -- This happens only once per module let { mod_deprecs = checkModDeprec mod_deprec } ; -- Add exports and deprecations to envt - let { export_fvs = availsToNameSet export_avails ; - final_env = tcg_env { tcg_exports = export_avails, - tcg_dus = tcg_dus tcg_env `plusDU` usesOnly export_fvs, + let { final_env = tcg_env { tcg_exports = exports, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` mod_deprecs } -- A module deprecation over-rides the earlier ones @@ -469,7 +470,8 @@ tcRnThing hsc_env ictxt rdr_name toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl toIfaceDecl ictxt thing - = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing + = tyThingToIfaceDecl True {- Discard IdInfo -} (const False) {- Show data cons -} + ext_nm thing where unqual = icPrintUnqual ictxt ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack @@ -535,7 +537,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Wrap up let { bndrs = bindersOfBinds core_binds ; - my_exports = map (Avail . idName) bndrs ; + my_exports = mkNameSet (map idName bndrs) ; -- ToDo: export the data types also? final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 54b4550..39313ec 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -84,7 +84,7 @@ initTc hsc_env mod do_this tcg_type_env_var = type_env_var, tcg_inst_env = mkImpInstEnv hsc_env, tcg_inst_uses = dfuns_var, - tcg_exports = [], + tcg_exports = emptyNameSet, tcg_imports = init_imports, tcg_dus = emptyDUs, tcg_binds = emptyBag, diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 9237f8b..8fa34ff 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -160,7 +160,7 @@ data TcGblEnv -- accumulated, but never consulted until the end. -- Nevertheless, it's convenient to accumulate them along -- with the rest of the info from this module. - tcg_exports :: Avails, -- What is exported + tcg_exports :: NameSet, -- What is exported tcg_imports :: ImportAvails, -- Information about what was imported -- from where, including things bound -- in this module -- 1.7.10.4