X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=b11c1e0f48219f005b345b98f589d775fc79dcc2;hp=05e75c78f8d5d95d4676324672e1e88dcc29f355;hb=c004ec62b41aa2137b5b5e298ca562609b0de92e;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 05e75c7..b11c1e0 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -4,19 +4,21 @@ % \begin{code} -{-# OPTIONS_GHC -w #-} +{-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module MkIface ( - mkUsageInfo, -- Construct the usage info for a module - + mkUsedNames, + mkDependencies, mkIface, -- Build a ModIface from a ModGuts, -- including computing version information + mkIfaceTc, + writeIfaceFile, -- Write the interface file checkOldIface, -- See if recompilation is required, by @@ -222,9 +224,11 @@ import Util hiding ( eqListBy ) import FiniteMap import FastString import Maybes +import ListSetOps import Control.Monad import Data.List +import Data.IORef \end{code} @@ -238,34 +242,120 @@ import Data.List \begin{code} mkIface :: HscEnv -> Maybe ModIface -- The old interface, if we have it - -> ModGuts -- Usages, deprecations, etc -> ModDetails -- The trimmed, tidied interface + -> ModGuts -- Usages, deprecations, etc -> IO (ModIface, -- The new one, complete with decls and versions Bool) -- True <=> there was an old Iface, and the new one -- is identical, so no need to write it -mkIface hsc_env maybe_old_iface - (ModGuts{ mg_module = this_mod, +mkIface hsc_env maybe_old_iface mod_details + ModGuts{ mg_module = this_mod, mg_boot = is_boot, - mg_usages = usages, + mg_used_names = used_names, mg_deps = deps, + mg_dir_imps = dir_imp_mods, mg_rdr_env = rdr_env, mg_fix_env = fix_env, - mg_deprecs = src_deprecs, - mg_hpc_info = hpc_info }) - (ModDetails{ md_insts = insts, + mg_deprecs = deprecs, + mg_hpc_info = hpc_info } + = mkIface_ hsc_env maybe_old_iface + this_mod is_boot used_names deps rdr_env + fix_env deprecs hpc_info dir_imp_mods mod_details + +-- | make an interface from the results of typechecking only. Useful +-- for non-optimising compilation, or where we aren't generating any +-- object code at all ('HscNothing'). +mkIfaceTc :: HscEnv + -> Maybe ModIface -- The old interface, if we have it + -> ModDetails -- gotten from mkBootModDetails, probably + -> TcGblEnv -- Usages, deprecations, etc + -> IO (ModIface, + Bool) +mkIfaceTc hsc_env maybe_old_iface mod_details + tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_src = hsc_src, + tcg_imports = imports, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_deprecs = deprecs, + tcg_hpc = other_hpc_info + } + = do + used_names <- mkUsedNames tc_result + deps <- mkDependencies tc_result + let hpc_info = emptyHpcInfo other_hpc_info + mkIface_ hsc_env maybe_old_iface + this_mod (isHsBoot hsc_src) used_names deps rdr_env + fix_env deprecs hpc_info (imp_mods imports) mod_details + + +mkUsedNames :: TcGblEnv -> IO NameSet +mkUsedNames + TcGblEnv{ tcg_inst_uses = dfun_uses_var, + tcg_dus = dus + } + = do + dfun_uses <- readIORef dfun_uses_var -- What dfuns are used + return (allUses dus `unionNameSets` dfun_uses) + +mkDependencies :: TcGblEnv -> IO Dependencies +mkDependencies + TcGblEnv{ tcg_mod = mod, + tcg_imports = imports, + tcg_th_used = th_var + } + = do + th_used <- readIORef th_var -- Whether TH is used + let + dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) + -- M.hi-boot can be in the imp_dep_mods, but we must remove + -- it before recording the modules on which this one depends! + -- (We want to retain M.hi-boot in imp_dep_mods so that + -- loadHiBootInterface can see if M's direct imports depend + -- on M.hi-boot, and hence that we should do the hi-boot consistency + -- check.) + + dir_imp_mods = imp_mods imports + + -- Modules don't compare lexicographically usually, + -- but we want them to do so here. + le_mod :: Module -> Module -> Bool + le_mod m1 m2 = moduleNameFS (moduleName m1) + <= moduleNameFS (moduleName m2) + + le_dep_mod :: (ModuleName, IsBootInterface) + -> (ModuleName, IsBootInterface) -> Bool + le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2 + + + pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports + + return Deps { dep_mods = sortLe le_dep_mod dep_mods, + dep_pkgs = sortLe (<=) pkgs, + dep_orphs = sortLe le_mod (imp_orphs imports), + dep_finsts = sortLe le_mod (imp_finsts imports) } + -- sort to get into canonical order + + +mkIface_ hsc_env maybe_old_iface + this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info + dir_imp_mods + ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, md_vect_info = vect_info, md_types = type_env, - md_exports = exports }) - + md_exports = exports } -- NB: notice that mkIface does not look at the bindings -- only at the TypeEnv. The previous Tidy phase has -- put exactly the info into the TypeEnv that we want -- to expose in the interface - = do { eps <- hscEPS hsc_env + = do {eps <- hscEPS hsc_env + + ; usages <- mkUsageInfo hsc_env dir_imp_mods (dep_mods deps) used_names + ; let { entities = typeEnvElts type_env ; decls = [ tyThingToIfaceDecl entity | entity <- entities, @@ -277,8 +367,8 @@ mkIface hsc_env maybe_old_iface nameIsLocalOrFrom this_mod name ] -- Sigh: see Note [Root-main Id] in TcRnDriver - ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] - ; deprecs = mkIfaceDeprec src_deprecs + ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] + ; deprecs = src_deprecs ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts @@ -319,7 +409,7 @@ mkIface hsc_env maybe_old_iface mi_fix_fn = mkIfaceFixCache fixities } -- Add version information - ; ext_ver_fn = mkParentVerFun hsc_env eps + ; ext_ver_fn = mkParentVerFun hsc_env eps ; (new_iface, no_change_at_all, pp_diffs, pp_orphs) = {-# SCC "versioninfo" #-} addVersionInfo ext_ver_fn maybe_old_iface @@ -333,7 +423,13 @@ mkIface hsc_env maybe_old_iface ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) - ; return (new_iface, no_change_at_all) } + -- bug #1617: on reload we weren't updating the PrintUnqualified + -- correctly. This stems from the fact that the interface had + -- not changed, so addVersionInfo returns the old ModIface + -- with the old GlobalRdrEnv (mi_globals). + ; let final_iface = new_iface{ mi_globals = Just rdr_env } + + ; return (final_iface, no_change_at_all) } where r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2 @@ -608,17 +704,23 @@ computeChangedOccs ver_fn this_module old_usages eq_info -- return True if an external name has changed name_changed :: Name -> Bool name_changed nm - | Just ents <- lookupUFM usg_modmap (moduleName mod) - = case lookupUFM ents parent_occ of - Nothing -> pprPanic "computeChangedOccs" (ppr nm) - Just v -> v < new_version + | Just ents <- lookupUFM usg_modmap (moduleName mod), + Just v <- lookupUFM ents parent_occ + = v < new_version + | modulePackageId mod == this_pkg + = WARN(True, ptext SLIT("computeChangedOccs") <+> ppr nm) True + -- should really be a panic, see #1959. The problem is that the usages doesn't + -- contain all the names that might be referred to by unfoldings. So as a + -- conservative workaround we just assume these names have changed. | otherwise = False -- must be in another package where mod = nameModule nm (parent_occ, new_version) = ver_fn nm + this_pkg = modulePackageId this_module + -- Turn the usages from the old ModIface into a mapping - usg_modmap = listToUFM [ (usg_mod usg, listToUFM (usg_entities usg)) + usg_modmap = listToUFM [ (usg_name usg, listToUFM (usg_entities usg)) | usg <- old_usages ] get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet @@ -653,6 +755,11 @@ computeChangedOccs ver_fn this_module old_usages eq_info type OccIfaceEq = GenIfaceEq OccSet +instance Outputable OccIfaceEq where + ppr Equal = ptext SLIT("Equal") + ppr NotEqual = ptext SLIT("NotEqual") + ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset) + changedWrt :: OccSet -> OccIfaceEq -> Bool changedWrt so_far Equal = False changedWrt so_far NotEqual = True @@ -691,12 +798,6 @@ mkOrphMap get_key decls | otherwise = (non_orphs, d:orphs) ---------------------- -mkIfaceDeprec :: Deprecations -> IfaceDeprecs -mkIfaceDeprec NoDeprecs = NoDeprecs -mkIfaceDeprec (DeprecAll t) = DeprecAll t -mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env)) - ----------------------- bump_unless :: Bool -> Version -> Version bump_unless True v = v -- True <=> no change bump_unless False v = bumpVersion v @@ -847,7 +948,8 @@ mkIfaceExports exports -- Usually just one, but see Note [Original module] add_for_mod env mod - = add_one env mod (AvailTC tc_occ names_from_mod) + = add_one env mod (AvailTC tc_occ (sort names_from_mod)) + -- NB. sort the children, we need a canonical order where names_from_mod = [nameOccName n | n <- ns, nameModule n == mod] \end{code} @@ -1334,7 +1436,7 @@ toIfaceIdInfo id_info ------------ Worker -------------- work_info = workerInfo id_info - has_worker = case work_info of { HasWorker _ _ -> True; other -> False } + has_worker = workerExists work_info wrkr_hsinfo = case work_info of HasWorker work_id wrap_arity -> Just (HsWorker ((idName work_id)) wrap_arity)