X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FMkIface.lhs;h=f577371c6241fadd3aa2d5bc8adbdd977dfbb0be;hb=3721dd37a707d2aacb5cac814410a78096e28a2c;hp=ddc44c6ff024547451691eb86f08a5be19683b84;hpb=576650d4966549866ad2d07d618f99c9a0c7529d;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index ddc44c6..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, @@ -218,7 +220,7 @@ import Outputable import DriverUtil ( createDirectoryHierarchy, directoryOf ) import Util ( sortLt, 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(..) ) @@ -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 this_mod exports, + mi_exports = mkIfaceExports exports, mi_insts = iface_insts, mi_rules = iface_rules, mi_fixities = fixities, @@ -312,8 +315,7 @@ mkIface hsc_env location maybe_old_iface 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) @@ -326,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) @@ -378,7 +385,11 @@ addVersionInfo Nothing new_iface new_decls || 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, @@ -389,8 +400,10 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_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, @@ -402,8 +415,8 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_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) @@ -428,13 +441,13 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, no_other_changes = mi_usages new_iface == mi_usages 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 @@ -511,6 +524,13 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, -> 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 @@ -584,12 +604,6 @@ 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] - ----------------------- bump_unless :: Bool -> Version -> Version bump_unless True v = v -- True <=> no change bump_unless False v = bumpVersion v @@ -687,40 +701,36 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names \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 + 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 @@ -741,7 +751,7 @@ checkOldIface hsc_env mod iface_path source_unchanged maybe_iface = do { showPass (hsc_dflags hsc_env) ("Checking old interface for " ++ moduleUserString mod) ; - ; initIfaceIO hsc_env $ + ; initIfaceCheck hsc_env $ check_old_iface mod iface_path source_unchanged maybe_iface } @@ -770,7 +780,7 @@ check_old_iface this_mod iface_path source_unchanged maybe_iface 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) @@ -930,7 +940,7 @@ showIface :: FilePath -> IO () 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 @@ -945,7 +955,7 @@ pprModIface iface <+> 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))