X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=188aa45baae0d606060f3f006675bc32742aee05;hb=8604da0136707cc14845d14a88c2272fe576b6d0;hp=cca8ab57d71f06a1892712994df91a1c5a4168a2;hpb=6777144f7522d8db5935737e12fa451ca3211e6d;p=ghc-hetmet.git diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index cca8ab5..188aa45 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -5,11 +5,13 @@ \begin{code} 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 @@ -122,7 +124,7 @@ We produce a line for every module B below the module, A, currently being compiled: import B ; to record the fact that A does import B indirectly. This is used to decide -to look to look for B.hi rather than B.hi-boot when compiling a module that +to look for B.hi rather than B.hi-boot when compiling a module that imports A. This line says that A imports B, but uses nothing in it. So we'll get an early bale-out when compiling A if B's version changes. @@ -172,6 +174,10 @@ code of A, and thereby haul in all the stuff reachable from it. haul in all the unfoldings for B, in case the module that imports A *is* compiled with -O. I think this is the case.] +SimonM [30/11/2007]: I believe the above is all out of date; the +current implementation doesn't do it this way. Instead, when any of +the dependencies of a declaration changes, the version of the +declaration itself changes. \begin{code} #include "HsVersions.h" @@ -193,11 +199,12 @@ import InstEnv import FamInstEnv import TcRnMonad import HscTypes - +import Finder import DynFlags import VarEnv import Var import Name +import RdrName import NameEnv import NameSet import OccName @@ -207,17 +214,19 @@ import Unique import ErrUtils import Digraph import SrcLoc -import PackageConfig hiding ( Version ) import Outputable import BasicTypes hiding ( SuccessFlag(..) ) -import UniqFM +import LazyUniqFM import Util hiding ( eqListBy ) import FiniteMap import FastString import Maybes +import ListSetOps import Control.Monad import Data.List +import Data.IORef +import System.FilePath \end{code} @@ -231,33 +240,124 @@ 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}) - (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.) + + -- 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_ :: HscEnv -> Maybe ModIface -> Module -> IsBootInterface + -> NameSet -> Dependencies -> GlobalRdrEnv + -> NameEnv FixItem -> Deprecations -> HpcInfo + -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]) + -> ModDetails + -> IO (ModIface, Bool) +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, @@ -269,8 +369,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 @@ -304,6 +404,7 @@ mkIface hsc_env maybe_old_iface mi_finsts = False, -- Ditto mi_decls = deliberatelyOmitted "decls", mi_ver_fn = deliberatelyOmitted "ver_fn", + mi_hpc = isHpcUsed hpc_info, -- And build the cached values mi_dep_fn = mkIfaceDepCache deprecs, @@ -312,7 +413,7 @@ mkIface hsc_env maybe_old_iface -- Add version information ; ext_ver_fn = mkParentVerFun hsc_env eps ; (new_iface, no_change_at_all, pp_diffs, pp_orphs) - = _scc_ "versioninfo" + = {-# SCC "versioninfo" #-} addVersionInfo ext_ver_fn maybe_old_iface intermediate_iface decls } @@ -324,7 +425,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 @@ -339,13 +446,24 @@ mkIface hsc_env maybe_old_iface deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) ifFamInstTcName = ifaceTyConName . ifFamInstTyCon - flattenVectInfo (VectInfo ccVar) = - IfaceVectInfo [Var.varName v | (v, _) <- varEnvElts ccVar] + flattenVectInfo (VectInfo { vectInfoVar = vVar + , vectInfoTyCon = vTyCon + }) = + IfaceVectInfo { + ifaceVectInfoVar = [ Var.varName v + | (v, _) <- varEnvElts vVar], + ifaceVectInfoTyCon = [ tyConName t + | (t, t_v) <- nameEnvElts vTyCon + , t /= t_v], + ifaceVectInfoTyConReuse = [ tyConName t + | (t, t_v) <- nameEnvElts vTyCon + , t == t_v] + } ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () writeIfaceFile dflags location new_iface - = do createDirectoryHierarchy (directoryOf hi_file_path) + = do createDirectoryHierarchy (takeDirectory hi_file_path) writeBinIface dflags hi_file_path new_iface where hi_file_path = ml_hi_file location @@ -388,7 +506,7 @@ addVersionInfo SDoc, -- Differences Maybe SDoc) -- Warnings about orphans -addVersionInfo ver_fn Nothing new_iface new_decls +addVersionInfo _ Nothing new_iface new_decls -- No old interface, so definitely write a new one! = (new_iface { mi_orphan = not (null orph_insts && null orph_rules) , mi_finsts = not . null $ mi_fam_insts new_iface @@ -397,7 +515,7 @@ addVersionInfo ver_fn Nothing new_iface new_decls new_decls) }, False, - ptext SLIT("No old interface file"), + ptext (sLit "No old interface file"), pprOrphans orph_insts orph_rules) where orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface) @@ -413,9 +531,9 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { new_iface@(ModIface { mi_fix_fn = new_fixities }) new_decls | no_change_at_all - = (old_iface, True, ptext SLIT("Interface file unchanged"), pp_orphs) + = (old_iface, True, ptext (sLit "Interface file unchanged"), pp_orphs) | otherwise - = (final_iface, False, vcat [ptext SLIT("Interface file has changed"), + = (final_iface, False, vcat [ptext (sLit "Interface file has changed"), nest 2 pp_diffs], pp_orphs) where final_iface = new_iface { @@ -461,7 +579,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { -- If the usages havn't changed either, we don't need to write the interface file no_other_changes = mi_usages new_iface == mi_usages old_iface && - mi_deps new_iface == mi_deps old_iface + mi_deps new_iface == mi_deps old_iface && + mi_hpc new_iface == mi_hpc old_iface no_change_at_all = no_output_change && no_other_changes pp_diffs = vcat [pp_change no_export_change "Export list" @@ -471,8 +590,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { pp_change no_deprec_change "Deprecations" 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 + pp_change True _ _ = empty + pp_change False what info = text what <+> ptext (sLit "changed") <+> info ------------------- old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls] @@ -517,7 +636,7 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { 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 (map ifConOcc (visibleIfConDecls cons)) - eq_indirects other = Equal -- Synonyms and foreign declarations + eq_indirects _ = Equal -- Synonyms and foreign declarations eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules eq_ind_occ occ = same_fixity occ &&& same_rules occ @@ -534,8 +653,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { pp_decl_diffs | isEmptyOccSet changed_occs = empty | otherwise - = vcat [ptext SLIT("Changed occs:") <+> ppr (occSetElts changed_occs), - ptext SLIT("Version change for these decls:"), + = vcat [ptext (sLit "Changed occs:") <+> ppr (occSetElts changed_occs), + ptext (sLit "Version change for these decls:"), nest 2 (vcat (map show_change new_decls))] eq_env = mkOccEnv eq_info @@ -547,30 +666,31 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { where occ = ifName new_decl why = case lookupOccEnv eq_env occ of - Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:") <> ppr names, + Just (EqBut names) -> sep [ppr occ <> colon, ptext (sLit "Free vars (only) changed:") <> ppr names, nest 2 (braces (fsep (map ppr (occSetElts (occs `intersectOccSet` changed_occs)))))] where occs = mkOccSet (map nameOccName (nameSetToList names)) Just NotEqual | Just old_decl <- lookupOccEnv old_decl_env occ - -> vcat [ptext SLIT("Old:") <+> ppr old_decl, - ptext SLIT("New:") <+> ppr new_decl] + -> vcat [ptext (sLit "Old:") <+> ppr old_decl, + ptext (sLit "New:") <+> ppr new_decl] | otherwise - -> ppr occ <+> ptext SLIT("only in new interface") - other -> pprPanic "MkIface.show_change" (ppr occ) + -> ppr occ <+> ptext (sLit "only in new interface") + _ -> pprPanic "MkIface.show_change" (ppr occ) pp_orphs = pprOrphans new_orph_insts new_orph_rules +pprOrphans :: [IfaceInst] -> [IfaceRule] -> Maybe SDoc pprOrphans insts rules | null insts && null rules = Nothing | otherwise = Just $ vcat [ if null insts then empty else - hang (ptext SLIT("Warning: orphan instances:")) + hang (ptext (sLit "Warning: orphan instances:")) 2 (vcat (map ppr insts)), if null rules then empty else - hang (ptext SLIT("Warning: orphan rules:")) + hang (ptext (sLit "Warning: orphan rules:")) 2 (vcat (map ppr rules)) ] @@ -587,20 +707,28 @@ 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 + | isWiredInName nm -- Wired-in things don't get into interface + = False -- files and hence don't get into the ver_fn + | 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 + get_local_eq_info :: GenIfaceEq Name -> GenIfaceEq OccName get_local_eq_info Equal = Equal get_local_eq_info NotEqual = NotEqual get_local_eq_info (EqBut ns) = foldNameSet f Equal ns @@ -616,7 +744,7 @@ computeChangedOccs ver_fn this_module old_usages eq_info | node@(occ, iface_eq) <- local_eq_infos , let occs = case iface_eq of EqBut occ_set -> occSetElts occ_set - other -> [] ] + _ -> [] ] -- Changes in declarations add_changes :: OccSet -> SCC (OccName, OccIfaceEq) -> OccSet @@ -628,26 +756,26 @@ computeChangedOccs ver_fn this_module old_usages eq_info -- One of this group has changed = extendOccSetList so_far occs where (occs, iface_eqs) = unzip pairs - add_changes so_far other = so_far + add_changes so_far _ = so_far -type OccIfaceEq = GenIfaceEq OccSet +type OccIfaceEq = GenIfaceEq OccName changedWrt :: OccSet -> OccIfaceEq -> Bool -changedWrt so_far Equal = False -changedWrt so_far NotEqual = True +changedWrt _ Equal = False +changedWrt _ NotEqual = True changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids changedWrtNames :: OccSet -> IfaceEq -> Bool -changedWrtNames so_far Equal = False -changedWrtNames so_far NotEqual = True +changedWrtNames _ Equal = False +changedWrtNames _ NotEqual = True changedWrtNames so_far (EqBut kids) = so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids)) and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq Equal `and_occifeq` x = x -NotEqual `and_occifeq` x = NotEqual +NotEqual `and_occifeq` _ = NotEqual EqBut nms `and_occifeq` Equal = EqBut nms -EqBut nms `and_occifeq` NotEqual = NotEqual +EqBut _ `and_occifeq` NotEqual = NotEqual EqBut nms1 `and_occifeq` EqBut nms2 = EqBut (nms1 `unionOccSets` nms2) ---------------------- @@ -670,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 @@ -691,7 +813,7 @@ bump_unless False v = bumpVersion v \begin{code} mkUsageInfo :: HscEnv - -> ModuleEnv (Module, Bool, SrcSpan) + -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]) -> [(ModuleName, IsBootInterface)] -> NameSet -> IO [Usage] mkUsageInfo hsc_env dir_imp_mods dep_mods used_names @@ -703,6 +825,12 @@ mkUsageInfo hsc_env dir_imp_mods dep_mods used_names -- don't get evaluated for a while and we can end up hanging on to -- the entire collection of Ifaces. +mk_usage_info :: PackageIfaceTable + -> HscEnv + -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]) + -> [(ModuleName, IsBootInterface)] + -> NameSet + -> [Usage] mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names = mapCatMaybes mkUsage dep_mods -- ToDo: do we need to sort into canonical order? @@ -725,8 +853,8 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names add_item occs _ = occ:occs depend_on_exports mod = case lookupModuleEnv dir_imp_mods mod of - Just (_,no_imp,_) -> not no_imp - Nothing -> True + Just (_, xs) -> any (\(_, no_imp, _) -> not no_imp) xs + Nothing -> True -- We want to create a Usage for a home module if -- a) we used something from; has something in used_names @@ -792,23 +920,55 @@ mkIfaceExports exports | (mod, avails) <- fmToList groupFM ] where + -- Group by the module where the exported entities are defined + -- (which may not be the same for all Names in an Avail) -- Deliberately use FiniteMap rather than UniqFM so we -- get a canonical ordering groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) groupFM = foldl add emptyModuleEnv exports - add env avail - = extendModuleEnv_C add_avail env mod (unitFM avail_fs avail_occ) + add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + -> Module -> GenAvailInfo OccName + -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + add_one env mod avail + = extendModuleEnv_C plusFM env mod + (unitFM (occNameFS (availName avail)) avail) + + -- NB: we should not get T(X) and T(Y) in the export list + -- else the plusFM will simply discard one! They + -- should have been combined by now. + add env (Avail n) + = add_one env (nameModule n) (Avail (nameOccName n)) + + add env (AvailTC tc ns) + = foldl add_for_mod env mods where - avail_occ = availToOccs avail - mod = nameModule (availName avail) - avail_fs = occNameFS (availName avail_occ) - add_avail avail_fm _ = addToFM avail_fm avail_fs avail_occ - - availToOccs (Avail n) = Avail (nameOccName n) - availToOccs (AvailTC tc ns) = AvailTC (nameOccName tc) (map nameOccName ns) + tc_occ = nameOccName tc + mods = nub (map nameModule ns) + -- Usually just one, but see Note [Original module] + + add_for_mod env 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} +Note [Orignal module] +~~~~~~~~~~~~~~~~~~~~~ +Consider this: + module X where { data family T } + module Y( T(..) ) where { import X; data instance T Int = MkT Int } +The exported Avail from Y will look like + X.T{X.T, Y.MkT} +That is, in Y, + - only MkT is brought into scope by the data instance; + - but the parent (used for grouping and naming in T(..) exports) is X.T + - and in this case we export X.T too + +In the result of MkIfaceExports, the names are grouped by defining module, +so we may need to split up a single Avail into multiple ones. + %************************************************************************ %* * @@ -834,9 +994,11 @@ checkOldIface hsc_env mod_summary source_unchanged maybe_iface check_old_iface hsc_env mod_summary source_unchanged maybe_iface } +check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface + -> IfG (Bool, Maybe ModIface) check_old_iface hsc_env mod_summary source_unchanged maybe_iface = do -- CHECK WHETHER THE SOURCE HAS CHANGED - { ifM (not source_unchanged) + { when (not source_unchanged) (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) -- If the source has changed and we're in interactive mode, avoid reading @@ -848,7 +1010,7 @@ check_old_iface hsc_env mod_summary source_unchanged maybe_iface case maybe_iface of { Just old_iface -> do -- Use the one we already have { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) - ; recomp <- checkVersions hsc_env source_unchanged old_iface + ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface ; return (recomp, Just old_iface) } ; Nothing -> do @@ -867,9 +1029,10 @@ check_old_iface hsc_env mod_summary source_unchanged maybe_iface -- We have got the old iface; check its versions { traceIf (text "Read the interface file" <+> text iface_path) - ; recomp <- checkVersions hsc_env source_unchanged iface - ; returnM (recomp, Just iface) + ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface + ; return (recomp, Just iface) }}}}} + \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -879,20 +1042,25 @@ check their versions. \begin{code} type RecompileRequired = Bool +upToDate, outOfDate :: Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required checkVersions :: HscEnv -> Bool -- True <=> source unchanged + -> ModSummary -> ModIface -- Old interface -> IfG RecompileRequired -checkVersions hsc_env source_unchanged iface +checkVersions hsc_env source_unchanged mod_summary iface | not source_unchanged - = returnM outOfDate + = return outOfDate | otherwise = do { traceHiDiffs (text "Considering whether compilation is required for" <+> ppr (mi_module iface) <> colon) + ; recomp <- checkDependencies hsc_env mod_summary iface + ; if recomp then return outOfDate else do { + -- Source code unchanged and no errors yet... carry on -- First put the dependent-module info, read from the old interface, into the envt, @@ -905,16 +1073,63 @@ checkVersions hsc_env source_unchanged iface -- We do this regardless of compilation mode, although in --make mode -- all the dependent modules should be in the HPT already, so it's -- quite redundant - ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } ; let this_pkg = thisPackage (hsc_dflags hsc_env) ; checkList [checkModUsage this_pkg u | u <- mi_usages iface] - } + }} where -- This is a bit of a hack really mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) + +-- If the direct imports of this module are resolved to targets that +-- are not among the dependencies of the previous interface file, +-- then we definitely need to recompile. This catches cases like +-- - an exposed package has been upgraded +-- - we are compiling with different package flags +-- - a home module that was shadowing a package module has been removed +-- - a new home module has been added that shadows a package module +-- See bug #1372. +-- +-- Returns True if recompilation is required. +checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired +checkDependencies hsc_env summary iface + = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + where + prev_dep_mods = dep_mods (mi_deps iface) + prev_dep_pkgs = dep_pkgs (mi_deps iface) + + this_pkg = thisPackage (hsc_dflags hsc_env) + + orM = foldr f (return False) + where f m rest = do b <- m; if b then return True else rest + + dep_missing (L _ mod) = do + find_res <- liftIO $ findImportedModule hsc_env mod Nothing + case find_res of + Found _ mod + | pkg == this_pkg + -> if moduleName mod `notElem` map fst prev_dep_mods + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " not among previous dependencies" + return outOfDate + else + return upToDate + | otherwise + -> if pkg `notElem` prev_dep_pkgs + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " is from package " <> quotes (ppr pkg) <> + text ", which is not among previous dependencies" + return outOfDate + else + return upToDate + where pkg = modulePackageId mod + _otherwise -> return outOfDate + checkModUsage :: PackageId ->Usage -> IfG RecompileRequired -- Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out @@ -924,21 +1139,18 @@ checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers, usg_rules = old_rule_vers, usg_exports = maybe_old_export_vers, usg_entities = old_decl_vers }) - = -- Load the imported interface is possible - let - doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] - in - traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` + = do -- Load the imported interface is possible + let doc_str = sep [ptext (sLit "need version info for"), ppr mod_name] + traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) - let - mod = mkModule this_pkg mod_name - in - loadInterface doc_str mod ImportBySystem `thenM` \ mb_iface -> + let mod = mkModule this_pkg mod_name + + mb_iface <- loadInterface doc_str mod ImportBySystem -- Load the interface, but don't complain on failure; -- Instead, get an Either back which we can test case mb_iface of { - Failed exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), + Failed _ -> (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 @@ -952,72 +1164,79 @@ checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers, new_rule_vers = mi_rule_vers iface in -- CHECK MODULE - checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> + checkModuleVersion old_mod_vers new_mod_vers >>= \ recompile -> if not recompile then - returnM upToDate + return upToDate else -- CHECK EXPORT LIST if checkExportList maybe_old_export_vers new_export_vers then - out_of_date_vers (ptext SLIT(" Export list changed")) + out_of_date_vers (ptext (sLit " Export list changed")) (expectJust "checkModUsage" maybe_old_export_vers) new_export_vers else -- CHECK RULES if old_rule_vers /= new_rule_vers then - out_of_date_vers (ptext SLIT(" Rules changed")) + out_of_date_vers (ptext (sLit " Rules changed")) old_rule_vers new_rule_vers else -- CHECK ITEMS ONE BY ONE - checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile -> + checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] >>= \ recompile -> if recompile then - returnM outOfDate -- This one failed, so just bail out now + return outOfDate -- This one failed, so just bail out now else - up_to_date (ptext SLIT(" Great! The bits I use are up to date")) + up_to_date (ptext (sLit " Great! The bits I use are up to date")) } ------------------------ +checkModuleVersion :: Version -> Version -> IfG Bool checkModuleVersion old_mod_vers new_mod_vers | new_mod_vers == old_mod_vers - = up_to_date (ptext SLIT("Module version unchanged")) + = up_to_date (ptext (sLit "Module version unchanged")) | otherwise - = out_of_date_vers (ptext SLIT(" Module version has changed")) + = out_of_date_vers (ptext (sLit " Module version has changed")) old_mod_vers new_mod_vers ------------------------ -checkExportList Nothing new_vers = upToDate +checkExportList :: Maybe Version -> Version -> Bool +checkExportList Nothing _ = upToDate checkExportList (Just v) new_vers = v /= new_vers ------------------------ +checkEntityUsage :: (OccName -> Maybe (OccName, Version)) + -> (OccName, Version) + -> IfG Bool checkEntityUsage new_vers (name,old_vers) = case new_vers name of Nothing -> -- We used it before, but it ain't there now - out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) + out_of_date (sep [ptext (sLit "No longer exported:"), ppr name]) Just (_, new_vers) -- It's there, but is it up to date? - | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_` - returnM upToDate - | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name) + | new_vers == old_vers -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) + return upToDate + | otherwise -> out_of_date_vers (ptext (sLit " Out of date:") <+> ppr name) old_vers new_vers -up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate -out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate +up_to_date, out_of_date :: SDoc -> IfG Bool +up_to_date msg = traceHiDiffs msg >> return upToDate +out_of_date msg = traceHiDiffs msg >> return outOfDate + +out_of_date_vers :: SDoc -> Version -> Version -> IfG Bool out_of_date_vers msg old_vers new_vers - = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers]) + = out_of_date (hsep [msg, ppr old_vers, ptext (sLit "->"), ppr new_vers]) ---------------------- checkList :: [IfG RecompileRequired] -> IfG RecompileRequired -- This helper is used in two places -checkList [] = returnM upToDate -checkList (check:checks) = check `thenM` \ recompile -> - if recompile then - returnM outOfDate - else - checkList checks +checkList [] = return upToDate +checkList (check:checks) = do recompile <- check + if recompile + then return outOfDate + else checkList checks \end{code} %************************************************************************ @@ -1070,10 +1289,12 @@ tyThingToIfaceDecl (AClass clas) tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType syn_tyki } + ifSynRhs = toIfaceType syn_tyki, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon) + } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1113,7 +1334,7 @@ tyThingToIfaceDecl (ATyCon tycon) ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), - ifConCtxt = toIfaceContext (dataConTheta data_con), + ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con), ifConArgTys = map toIfaceType (dataConOrigArgTys data_con), ifConFields = map getOccName (dataConFieldLabels data_con), @@ -1129,12 +1350,13 @@ tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier +getFS :: NamedThing a => a -> FastString getFS x = occNameFS (getOccName x) -------------------------- instanceToIfaceInst :: Instance -> IfaceInst -instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, - is_cls = cls_name, is_tcs = mb_tcs }) +instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, + is_cls = cls_name, is_tcs = mb_tcs }) = ASSERT( cls_name == className cls ) IfaceInst { ifDFun = dfun_name, ifOFlag = oflag, @@ -1162,18 +1384,19 @@ instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, -- that is not in the "determined" arguments mb_ns | null fds = [choose_one arg_names] | otherwise = map do_one fds - do_one (ltvs,rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names - , not (tv `elem` rtvs)] + do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names + , not (tv `elem` rtvs)] choose_one :: [NameSet] -> Maybe OccName choose_one nss = case nameSetToList (unionManyNameSets nss) of - [] -> Nothing - (n:ns) -> Just (nameOccName n) + [] -> Nothing + (n : _) -> Just (nameOccName n) -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst -famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon, - fi_fam = fam, fi_tcs = mb_tcs }) +famInstToIfaceFamInst (FamInst { fi_tycon = tycon, + fi_fam = fam, + fi_tcs = mb_tcs }) = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon , ifFamInstFam = fam , ifFamInstTys = map do_rough mb_tcs } @@ -1182,6 +1405,7 @@ famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon, do_rough (Just n) = Just (toIfaceTyCon_name n) -------------------------- +toIfaceLetBndr :: Id -> IfaceLetBndr toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) (toIfaceType (idType id)) prag_info @@ -1222,7 +1446,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) @@ -1250,7 +1474,7 @@ toIfaceIdInfo id_info -------------------------- coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule -coreRuleToIfaceRule mod (BuiltinRule { ru_fn = fn}) +coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn}) = pprTrace "toHsRule: builtin" (ppr fn) $ bogusIfaceRule fn @@ -1279,12 +1503,12 @@ coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, -- exprsFreeNames finds only External names orph = case filter (nameIsLocalOrFrom mod) lhs_names of - (n:ns) -> Just (nameOccName n) - [] -> Nothing + (n : _) -> Just (nameOccName n) + [] -> Nothing bogusIfaceRule :: Name -> IfaceRule bogusIfaceRule id_name - = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, + = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } @@ -1301,18 +1525,23 @@ toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co) toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- +toIfaceNote :: Note -> IfaceNote toIfaceNote (SCC cc) = IfaceSCC cc toIfaceNote InlineMe = IfaceInlineMe toIfaceNote (CoreNote s) = IfaceCoreNote s --------------------- +toIfaceBind :: Bind Id -> IfaceBinding toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] --------------------- +toIfaceAlt :: (AltCon, [Var], CoreExpr) + -> (IfaceConAlt, [FastString], IfaceExpr) toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r) --------------------- +toIfaceCon :: AltCon -> IfaceConAlt toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) | otherwise = IfaceDataAlt (getName dc) where @@ -1322,6 +1551,7 @@ toIfaceCon (LitAlt l) = IfaceLitAlt l toIfaceCon DEFAULT = IfaceDefault --------------------- +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr toIfaceApp (App f a) as = toIfaceApp f (a:as) toIfaceApp (Var v) as = case isDataConWorkId_maybe v of @@ -1334,10 +1564,11 @@ toIfaceApp (Var v) as tup_args = map toIfaceExpr val_args tc = dataConTyCon dc - other -> mkIfaceApps (toIfaceVar v) as + _ -> mkIfaceApps (toIfaceVar v) as toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as --------------------- @@ -1346,6 +1577,8 @@ toIfaceVar v | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) -- Foreign calls have special syntax | isExternalName name = IfaceExt name + | Just (TickBox m ix) <- isTickBoxOp_maybe v + = IfaceTick m ix | otherwise = IfaceLcl (getFS name) where name = idName v