import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..),
eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
- eqMaybeBy, eqListBy,
+ eqMaybeBy, eqListBy, visibleIfConDecls,
tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule )
import LoadIface ( readIface, loadInterface, ifaceInstGates )
import BasicTypes ( Version, initialVersion, bumpVersion )
import TcRnMonad
import TcRnTypes ( ImportAvails(..), mkModDeps )
-import HscTypes ( ModIface(..),
+import TcType ( isFFITy )
+import HscTypes ( ModIface(..), TyThing(..),
ModGuts(..), ModGuts, IfaceExport,
- GhciMode(..),
+ GhciMode(..), isOneShot,
HscEnv(..), hscEPS,
Dependencies(..), FixItem(..),
- isImplicitTyThing,
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
typeEnvElts,
- Avails, AvailInfo, GenAvailInfo(..), availName,
+ GenAvailInfo(..), availName,
ExternalPackageState(..),
Usage(..), IsBootInterface,
Deprecs(..), IfaceDeprecs, Deprecations,
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 ( tyConDataCons, isNewTyCon, newTyConRep )
+import Class ( classSelIds )
+import DataCon ( dataConName, dataConFieldLabels )
import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
ModLocation(..), mkSysModuleNameFS, moduleUserString,
ModuleEnv, emptyModuleEnv, lookupModuleEnv,
)
import Outputable
import DriverUtil ( createDirectoryHierarchy, directoryOf )
-import Util ( sortLt, seqList )
+import Util ( sortLe, seqList )
import Binary ( getBinFileWithDict )
-import BinIface ( writeBinIface, v_IgnoreHiVersion )
+import BinIface ( writeBinIface, v_IgnoreHiWay )
import Unique ( Unique, Uniquable(..) )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Digraph ( stronglyConnComp, SCC(..) )
+import SrcLoc ( SrcSpan )
import FiniteMap
import FastString
import DATA_IOREF ( writeIORef )
import Monad ( when )
+import List ( insert )
import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust )
\end{code}
= 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
- | thing <- typeEnvElts type_env
- , not (isImplicitTyThing thing) && not (isWiredInName (getName thing)) ]
+ ; local_things = [thing | thing <- typeEnvElts type_env,
+ not (isWiredInName (getName thing)) ]
+ -- Do not export anything about wired-in things
+ -- (GHC knows about them already)
+
+ ; abstract_tcs :: NameSet -- TyCons and Classes whose representation is not exposed
+ ; abstract_tcs
+ | not omit_prags = emptyNameSet -- In the -O case, nothing is abstract
+ | otherwise = mkNameSet [ getName thing
+ | thing <- local_things
+ , not (mustExposeThing exports thing)]
+
+ ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing
+ | thing <- local_things, wantDeclFor exports abstract_tcs thing ]
-- Don't put implicit Ids and class tycons in the interface file
- -- Nor wired-in things (GHC knows about them already)
; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
; deprecs = mkIfaceDeprec src_deprecs
; iface_rules
| omit_prags = []
- | otherwise = sortLt lt_rule $
+ | otherwise = sortLe le_rule $
map (coreRuleToIfaceRule this_mod_name ext_nm) rules
- ; iface_insts = sortLt lt_inst (map (dfunToIfaceInst this_mod_name) insts)
+ ; iface_insts = sortLe le_inst (map dfunToIfaceInst insts)
; intermediate_iface = ModIface {
mi_module = this_mod,
mi_boot = False,
mi_deps = deps,
mi_usages = usages,
- mi_exports = groupAvails this_mod exports,
+ mi_exports = mkIfaceExports exports,
mi_insts = iface_insts,
mi_rules = iface_rules,
mi_fixities = fixities,
writeBinIface hi_file_path new_iface
-- Debug printing
- ; when (dopt Opt_D_dump_hi_diffs dflags)
- (printDump (write_diffs maybe_old_iface no_change_at_all pp_diffs))
+ ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
; return new_iface }
where
- r1 `lt_rule` r2 = ifRuleName r1 < ifRuleName r2
- i1 `lt_inst` i2 = ifDFun i1 < ifDFun i2
+ r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
+ i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
dflags = hsc_dflags hsc_env
ghci_mode = hsc_mode hsc_env
hi_file_path = ml_hi_file location
omit_prags = dopt Opt_OmitInterfacePragmas dflags
+
+mustExposeThing :: NameSet -> TyThing -> Bool
+-- We are compiling without -O, and thus trying to write as little as
+-- possible into the interface file. But we must expose the details of
+-- any data types and classes whose constructors, fields, methods are
+-- visible to an importing module
+mustExposeThing exports (ATyCon tc)
+ = any exported_data_con (tyConDataCons tc)
+ -- Expose rep if any datacon or field is exported
+
+ || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
+ -- Expose the rep for newtypes if the rep is an FFI type.
+ -- For a very annoying reason. 'Foreign import' is meant to
+ -- be able to look through newtypes transparently, but it
+ -- can only do that if it can "see" the newtype representation
+ where
+ exported_data_con con
+ = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con)
+
+mustExposeThing exports (AClass cls)
+ = any exported_class_op (classSelIds cls)
+ where -- Expose rep if any classs op is exported
+ exported_class_op op = getName op `elemNameSet` exports
+
+mustExposeThing exports other = False
+
+
+wantDeclFor :: NameSet -- User-exported things
+ -> NameSet -- Abstract things
+ -> TyThing -> Bool
+wantDeclFor exports abstracts thing
+ | Just parent <- nameParent_maybe name -- An implicit thing
+ = parent `elemNameSet` abstracts && name `elemNameSet` exports
+ | otherwise
+ = True
+ where
+ name = getName thing
+
+
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
-----------------------------
|| anyNothing getRuleKey (mi_rules new_iface),
mi_decls = [(initialVersion, decl) | decl <- new_decls],
mi_ver_fn = \n -> Just initialVersion },
- False, text "No old interface available")
+ False, ptext SLIT("No old interface file") $$
+ pprOrphans orph_insts orph_rules)
+ where
+ orph_insts = filter (isNothing . getInstKey) (mi_insts new_iface)
+ orph_rules = filter (isNothing . getRuleKey) (mi_rules new_iface)
addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers,
mi_exp_vers = old_exp_vers,
new_iface@(ModIface { mi_fix_fn = new_fixities })
new_decls
- | no_change_at_all = (old_iface, True, empty)
- | otherwise = (final_iface, False, pp_diffs)
+ | no_change_at_all = (old_iface, True, ptext SLIT("Interface file unchanged") $$ pp_orphs)
+ | otherwise = (final_iface, False, vcat [ptext SLIT("Interface file has changed"),
+ nest 2 pp_diffs,
+ text "" $$ pp_orphs])
where
final_iface = new_iface { mi_mod_vers = bump_unless no_output_change old_mod_vers,
mi_exp_vers = bump_unless no_export_change old_exp_vers,
decls_w_vers = [(add_vers decl, decl) | decl <- new_decls]
-------------------
- (new_non_orph_insts, new_orph_insts) = mkRuleMap getInstKey (mi_insts new_iface)
(old_non_orph_insts, old_orph_insts) = mkRuleMap getInstKey (mi_insts old_iface)
+ (new_non_orph_insts, new_orph_insts) = mkRuleMap getInstKey (mi_insts new_iface)
same_insts occ = eqMaybeBy (eqListBy eqIfInst)
(lookupOccEnv old_non_orph_insts occ)
(lookupOccEnv new_non_orph_insts occ)
no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface
-- If the usages havn't changed either, we don't need to write the interface file
- -- Question: should we also check for equality of mi_deps?
- no_other_changes = mi_usages new_iface == mi_usages old_iface
+ no_other_changes = mi_usages new_iface == mi_usages old_iface &&
+ mi_deps new_iface == mi_deps old_iface
no_change_at_all = no_output_change && no_other_changes
- pp_diffs = vcat [pp_decl_diffs,
- pp_change no_export_change "Export list"
+ pp_diffs = vcat [pp_change no_export_change "Export list"
(ppr old_exp_vers <+> arrow <+> ppr (mi_exp_vers final_iface)),
pp_change no_rule_change "Rules"
(ppr old_rule_vers <+> arrow <+> ppr (mi_rule_vers final_iface)),
pp_change no_deprec_change "Deprecations" empty,
- pp_change no_other_changes "Usages" empty]
+ pp_change no_other_changes "Usages" empty,
+ pp_decl_diffs]
pp_change True what info = empty
pp_change False what info = text what <+> ptext SLIT("changed") <+> info
eq_ind_occs [op | IfaceClassOp op _ _ <- sigs]
eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
= same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too
- eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleDataCons cons]
+ eq_ind_occs (map ifConOcc (visibleIfConDecls cons))
eq_indirects other = Equal -- Synonyms and foreign declarations
eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
-> ppr occ <+> ptext SLIT("only in new interface")
other -> pprPanic "MkIface.show_change" (ppr occ)
+ pp_orphs = pprOrphans new_orph_insts new_orph_rules
+
+pprOrphans insts rules
+ = vcat [if null insts then empty else
+ ptext SLIT("Orphan instances:") <+> vcat (map ppr insts),
+ if null rules then empty else
+ ptext SLIT("Orphan rules:") <+> vcat (map ppr rules)]
computeChangedOccs :: [(OccName, IfaceEq)] -> OccSet
computeChangedOccs eq_info
mkIfaceDeprec :: Deprecations -> IfaceDeprecs
mkIfaceDeprec NoDeprecs = NoDeprecs
mkIfaceDeprec (DeprecAll t) = DeprecAll t
-mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLt (<) (nameEnvElts env))
-
-----------------------
-write_diffs :: Maybe ModIface -> Bool -> SDoc -> SDoc
-write_diffs Nothing _ _ = ptext SLIT("NO OLD INTERFACE FILE")
-write_diffs (Just _) True _ = ptext SLIT("INTERFACE UNCHANGED")
-write_diffs (Just _) False diffs = sep [ptext SLIT("INTERFACE HAS CHANGED"), nest 2 diffs]
+mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env))
----------------------
bump_unless :: Bool -> Version -> Version
\begin{code}
-mkUsageInfo :: HscEnv -> ImportAvails -> NameSet -> IO [Usage]
-mkUsageInfo hsc_env
- (ImportAvails { imp_mods = dir_imp_mods,
- imp_dep_mods = dep_mods })
- used_names
+mkUsageInfo :: HscEnv
+ -> ModuleEnv (Module, Maybe Bool, SrcSpan)
+ -> [(ModuleName, IsBootInterface)]
+ -> NameSet -> IO [Usage]
+mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
= do { eps <- hscEPS hsc_env
- ; return (mk_usage_info (eps_PIT eps) (hsc_HPT hsc_env)
- dir_imp_mods dep_mods used_names) }
+ ; let usages = mk_usage_info (eps_PIT eps) (hsc_HPT hsc_env)
+ dir_imp_mods dep_mods used_names
+ ; usages `seqList` return usages }
+ -- seq the list of Usages returned: occasionally these
+ -- don't get evaluated for a while and we can end up hanging on to
+ -- the entire collection of Ifaces.
mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names
- = -- seq the list of Usages returned: occasionally these
- -- don't get evaluated for a while and we can end up hanging on to
- -- the entire collection of Ifaces.
- usages `seqList` usages
+ = mapCatMaybes mkUsage dep_mods
+ -- ToDo: do we need to sort into canonical order?
where
used_names = mkNameSet $ -- Eliminate duplicates
[ nameParent n -- Just record usage on the 'main' names
mod = nameModule name
add_item occs _ = occ:occs
- usages = mapCatMaybes mkUsage (moduleEnvElts dep_mods)
- -- ToDo: do we need to sort into canonical order?
-
import_all mod = case lookupModuleEnv dir_imp_mods mod of
- Just (_,imp_all) -> isNothing imp_all
- Nothing -> False
+ Just (_,imp_all,_) -> isNothing imp_all
+ Nothing -> False
-- We want to create a Usage for a home module if
-- a) we used something from; has something in used_names
used_occs = lookupModuleEnv ent_map mod `orElse` []
ent_vers :: [(OccName,Version)]
ent_vers = [ (occ, version_env occ `orElse` initialVersion)
- | occ <- sortLt (<) used_occs]
+ | occ <- sortLe (<=) used_occs]
\end{code}
\begin{code}
-groupAvails :: Module -> Avails -> [(ModuleName, [GenAvailInfo OccName])]
+mkIfaceExports :: NameSet -> [(ModuleName, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
-- This keeps the list in canonical order
-groupAvails this_mod 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
+ 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
readIface (moduleName this_mod) iface_path False `thenM` \ read_result ->
case read_result of {
Left err -> -- Old interface file not found, or garbled; give up
- traceHiDiffs (text "FYI: cannot read old interface file:"
+ traceIf (text "FYI: cannot read old interface file:"
$$ nest 4 err) `thenM_`
returnM (outOfDate, Nothing)
| not source_unchanged
= returnM outOfDate
| otherwise
- = traceHiDiffs (text "Considering whether compilation is required for" <+>
- ppr (mi_module iface) <> colon) `thenM_`
+ = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon)
-- Source code unchanged and no errors yet... carry on
- -- First put the dependent-module info in the envt, just temporarily,
+
+ -- First put the dependent-module info, read from the old interface, into the envt,
-- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
+ --
-- It's just temporary because either the usage check will succeed
-- (in which case we are done with this module) or it'll fail (in which
-- case we'll compile the module from scratch anyhow).
- updGblEnv (\ gbl -> gbl { if_is_boot = mod_deps }) (
- checkList [checkModUsage u | u <- mi_usages iface]
- )
+ --
+ -- We do this regardless of compilation mode
+ ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
+
+ ; checkList [checkModUsage u | u <- mi_usages iface]
+ }
where
-- This is a bit of a hack really
mod_deps :: ModuleEnv (ModuleName, IsBootInterface)
showIface filename = do
-- skip the version check; we don't want to worry about profiled vs.
-- non-profiled interfaces, for example.
- writeIORef v_IgnoreHiVersion True
+ writeIORef v_IgnoreHiWay True
iface <- Binary.getBinFileWithDict filename
printDump (pprModIface iface)
where
<+> doubleQuotes (ftext (mi_package iface))
<+> ppr (mi_module iface) <+> ppr (mi_mod_vers iface)
<+> pp_sub_vers
- <+> (if mi_orphan iface then char '!' else empty)
+ <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty)
<+> int opt_HiVersion
<+> ptext SLIT("where")
, vcat (map pprExport (mi_exports iface))
projects / ghc-hetmet.git / blobdiff