Commit 3721dd37 authored by simonpj's avatar simonpj
Browse files

[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.
parent e802f7a7
......@@ -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
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 ;
......
......@@ -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,
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment