X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FMkIface.lhs;h=29110c77c6e4f47af2444209030db6d015ee62c8;hb=f4eaa144a42d26f70fe8452916131c33b0c56f8f;hp=ebbca13e8c079d56d920a89a5eab9841fe68e0d1;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index ebbca13..29110c7 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -4,7 +4,7 @@ \begin{code} module MkIface ( - showIface, -- Print the iface in Foo.hi + pprModIface, showIface, -- Print the iface in Foo.hi mkUsageInfo, -- Construct the usage info for a module @@ -174,7 +174,7 @@ compiled with -O. I think this is the case.] #include "HsVersions.h" import HsSyn -import Packages ( isHomeModule ) +import Packages ( isHomeModule, PackageIdH(..) ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..), eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, @@ -183,12 +183,13 @@ import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), import LoadIface ( readIface, loadInterface, ifaceInstGates ) import BasicTypes ( Version, initialVersion, bumpVersion ) import TcRnMonad -import TcRnTypes ( ImportAvails(..), mkModDeps ) +import TcRnTypes ( mkModDeps ) import TcType ( isFFITy ) -import HscTypes ( ModIface(..), TyThing(..), IfacePackage(..), +import HscTypes ( ModIface(..), TyThing(..), ModGuts(..), ModGuts, IfaceExport, GhciMode(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..), + ModSummary(..), msHiFilePath, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, GenAvailInfo(..), availName, @@ -234,7 +235,8 @@ import FastString import DATA_IOREF ( writeIORef ) import Monad ( when ) import List ( insert ) -import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust ) +import Maybes ( orElse, mapCatMaybes, isNothing, isJust, + fromJust, expectJust, MaybeErr(..) ) \end{code} @@ -251,12 +253,13 @@ mkIface :: HscEnv -> Maybe ModIface -- The old interface, if we have it -> ModGuts -- The compiled, tidied module -> IO ModIface -- The new one, complete with decls and versions --- mkFinalIface --- a) completes the interface --- b) writes it out to a file if necessary +-- mkIface +-- a) Builds the ModIface +-- b) Writes it out to a file if necessary mkIface hsc_env location maybe_old_iface guts@ModGuts{ mg_module = this_mod, + mg_boot = is_boot, mg_usages = usages, mg_deps = deps, mg_exports = exports, @@ -266,7 +269,8 @@ mkIface hsc_env location maybe_old_iface mg_rules = rules, mg_types = type_env } = do { eps <- hscEPS hsc_env - ; let { ext_nm = mkExtNameFn hsc_env eps this_mod + ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod + ; ext_nm_lhs = mkLhsNameFn this_mod ; local_things = [thing | thing <- typeEnvElts type_env, not (isWiredInName (getName thing)) ] -- Do not export anything about wired-in things @@ -279,7 +283,7 @@ mkIface hsc_env location maybe_old_iface | thing <- local_things , not (mustExposeThing exports thing)] - ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing + ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm_rhs thing | thing <- local_things, wantDeclFor exports abstract_tcs thing ] -- Don't put implicit Ids and class tycons in the interface file @@ -288,13 +292,13 @@ mkIface hsc_env location maybe_old_iface ; iface_rules | omit_prags = [] | otherwise = sortLe le_rule $ - map (coreRuleToIfaceRule this_mod ext_nm) rules - ; iface_insts = sortLe le_inst (map dfunToIfaceInst insts) + map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules + ; iface_insts = sortLe le_inst (map (dfunToIfaceInst ext_nm_lhs) insts) ; intermediate_iface = ModIface { mi_module = this_mod, - mi_package = ThisPackage, - mi_boot = False, + mi_package = HomePackage, + mi_boot = is_boot, mi_deps = deps, mi_usages = usages, mi_exports = mkIfaceExports exports, @@ -317,7 +321,7 @@ mkIface hsc_env location maybe_old_iface mi_fix_fn = mkIfaceFixCache fixities } -- Add version information - ; (new_iface, no_change_at_all, pp_diffs) + ; (new_iface, no_change_at_all, pp_diffs, pp_orphs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface intermediate_iface decls } @@ -328,6 +332,8 @@ mkIface hsc_env location maybe_old_iface writeBinIface hi_file_path new_iface -- Debug printing + ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) + (printDump (fromJust pp_orphs)) ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) @@ -337,10 +343,10 @@ mkIface hsc_env location maybe_old_iface 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 + dflags = hsc_dflags hsc_env + ghci_mode = hsc_mode hsc_env + omit_prags = dopt Opt_OmitInterfacePragmas dflags hi_file_path = ml_hi_file location - omit_prags = dopt Opt_OmitInterfacePragmas dflags mustExposeThing :: NameSet -> TyThing -> Bool @@ -416,6 +422,20 @@ mkExtNameFn hsc_env eps this_mod iface = lookupIfaceByModule hpt pit mod `orElse` pprPanic "lookupVers2" (ppr mod <+> ppr occ) + +--------------------- +-- mkLhsNameFn ignores versioning info altogether +-- It is used for the LHS of instance decls and rules, where we +-- there's no point in recording version info +mkLhsNameFn :: Module -> Name -> IfaceExtName +mkLhsNameFn this_mod name + | mod == this_mod = LocalTop occ + | otherwise = ExtPkg mod occ + where + mod = nameModule name + occ = nameOccName name + + ----------------------------- -- Compute version numbers for local decls @@ -424,7 +444,8 @@ addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi -> [IfaceDecl] -- The new decls -> (ModIface, Bool, -- True <=> no changes at all; no need to write new Iface - SDoc) -- Differences + SDoc, -- Differences + Maybe SDoc) -- Warnings about orphans addVersionInfo Nothing new_iface new_decls -- No old interface, so definitely write a new one! @@ -432,8 +453,9 @@ 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, ptext SLIT("No old interface file") $$ - pprOrphans orph_insts orph_rules) + 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) @@ -447,10 +469,9 @@ 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, ptext SLIT("Interface file unchanged") $$ pp_orphs) + | 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]) + nest 2 pp_diffs], 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, @@ -574,10 +595,16 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, 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)] + | null insts && null rules = Nothing + | otherwise + = Just $ vcat [ + if null insts then empty else + hang (ptext SLIT("Warning: orphan instances:")) + 2 (vcat (map ppr insts)), + if null rules then empty else + hang (ptext SLIT("Warning: orphan rules:")) + 2 (vcat (map ppr rules)) + ] computeChangedOccs :: [(OccName, IfaceEq)] -> OccSet computeChangedOccs eq_info @@ -774,8 +801,8 @@ mkIfaceExports exports 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) + add_item (AvailTC p occs) _ = AvailTC p (List.insert occ occs) + add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name) \end{code} @@ -789,21 +816,20 @@ mkIfaceExports exports \begin{code} checkOldIface :: HscEnv - -> Module - -> FilePath -- Where the interface file is + -> ModSummary -> Bool -- Source unchanged -> Maybe ModIface -- Old interface from compilation manager, if any -> IO (RecompileRequired, Maybe ModIface) -checkOldIface hsc_env mod iface_path source_unchanged maybe_iface +checkOldIface hsc_env mod_summary source_unchanged maybe_iface = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ moduleUserString mod) ; + ("Checking old interface for " ++ moduleUserString (ms_mod mod_summary)) ; ; initIfaceCheck hsc_env $ - check_old_iface mod iface_path source_unchanged maybe_iface + check_old_iface mod_summary source_unchanged maybe_iface } -check_old_iface this_mod iface_path source_unchanged maybe_iface +check_old_iface mod_summary source_unchanged maybe_iface = -- CHECK WHETHER THE SOURCE HAS CHANGED ifM (not source_unchanged) (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) @@ -825,14 +851,17 @@ check_old_iface this_mod iface_path source_unchanged maybe_iface -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it - readIface this_mod iface_path False `thenM` \ read_result -> + let + iface_path = msHiFilePath mod_summary + in + readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result -> case read_result of { - Left err -> -- Old interface file not found, or garbled; give up + Failed err -> -- Old interface file not found, or garbled; give up traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) `thenM_` returnM (outOfDate, Nothing) - ; Right iface -> + ; Succeeded iface -> -- We have got the old iface; check its versions checkVersions source_unchanged iface `thenM` \ recomp -> @@ -899,13 +928,13 @@ checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers, -- Instead, get an Either back which we can test case mb_iface of { - Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), + Failed exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), ppr mod_name])); -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain -- it might just be that -- the current module doesn't need that import and it's been deleted - Right iface -> + Succeeded iface -> let new_mod_vers = mi_mod_vers iface new_decl_vers = mi_ver_fn iface @@ -1006,8 +1035,8 @@ pprModIface :: ModIface -> SDoc pprModIface iface = vcat [ ptext SLIT("interface") <+> ppr_package (mi_package iface) - <+> ppr (mi_module iface) <+> ppr (mi_mod_vers iface) - <+> pp_sub_vers + <+> ppr (mi_module iface) <+> pp_boot + <+> ppr (mi_mod_vers iface) <+> pp_sub_vers <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) <+> int opt_HiVersion <+> ptext SLIT("where") @@ -1021,8 +1050,10 @@ pprModIface iface , pprDeprecs (mi_deprecs iface) ] where - ppr_package ThisPackage = empty - ppr_package (ExternalPackage id) = doubleQuotes (ftext id) + pp_boot | mi_boot iface = ptext SLIT("[boot]") + | otherwise = empty + ppr_package HomePackage = empty + ppr_package (ExtPackage id) = doubleQuotes (ppr id) exp_vers = mi_exp_vers iface rule_vers = mi_rule_vers iface