From 4ef18ea237ee070678970dbdd49714014dd9efbf Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 25 Oct 2002 15:23:07 +0000 Subject: [PATCH] [project @ 2002-10-25 15:23:03 by simonpj] ------------------------ More dependency fiddling ------------------------ WARNING: Interface file format has changed (again) You need to 'make clean' in all library code * Orphan modules are now kept separately Home-package dependencies now contain only home-package dependencies! See HscTypes.Dependencies * Linker now uses the dependencies to do dynamic linking Result: Template Haskell should work even without --make (not yet tested) --- ghc/compiler/compMan/CompManager.lhs | 24 +----- ghc/compiler/deSugar/Desugar.lhs | 6 +- ghc/compiler/deSugar/DsMeta.hs | 6 +- ghc/compiler/ghci/Linker.lhs | 132 +++++++++++++++++++++------------ ghc/compiler/main/BinIface.hs | 10 +++ ghc/compiler/main/HscTypes.lhs | 22 +++--- ghc/compiler/main/MkIface.lhs | 21 +++--- ghc/compiler/parser/Parser.y | 6 +- ghc/compiler/rename/RnHiFiles.lhs | 22 +++--- ghc/compiler/rename/RnIfaces.lhs | 6 +- ghc/compiler/rename/RnNames.lhs | 37 +++++---- ghc/compiler/typecheck/TcRnDriver.lhs | 10 +-- ghc/compiler/typecheck/TcRnTypes.lhs | 51 ++++++------- 13 files changed, 193 insertions(+), 160 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index ad580a1..313da96 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -88,12 +88,12 @@ import DATA_IOREF ( readIORef ) import HscMain ( hscThing, hscStmt, hscTcExpr ) import Module ( moduleUserString ) import TcRnDriver ( mkGlobalContext, getModuleContents ) -import Name ( Name, NamedThing(..), isExternalName ) +import Name ( Name, NamedThing(..), isExternalName, nameModule ) import Id ( idType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) import BasicTypes ( Fixity, FixitySig(..), defaultFixity ) -import Linker ( HValue, unload, extendLinkEnv ) +import Linker ( HValue, unload, extendLinkEnv, findLinkable ) import GHC.Exts ( unsafeCoerce# ) import Foreign import Control.Exception as Exception ( Exception, try ) @@ -267,7 +267,7 @@ cmInfoThing cmstate dflags id getFixity :: PersistentCompilerState -> Name -> Fixity getFixity pcs name | isExternalName name, - Just iface <- lookupIface hpt pit name, + Just iface <- lookupIface hpt pit (nameModule name), Just (FixitySig _ fixity _) <- lookupNameEnv (mi_fixities iface) name = fixity | otherwise @@ -801,9 +801,7 @@ getValidLinkable old_linkables objects_allowed new_linkables summary <- if (not objects_allowed) then return Nothing - else case ml_obj_file (ms_location summary) of - Just obj_fn -> maybe_getFileLinkable mod_name obj_fn - Nothing -> return Nothing + else findLinkable mod_name (ms_location summary) let old_linkable = findModuleLinkable_maybe old_linkables mod_name @@ -847,20 +845,6 @@ getValidLinkable old_linkables objects_allowed new_linkables summary return (new_linkables' ++ new_linkables) -maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable) -maybe_getFileLinkable mod obj_fn - = do obj_exist <- doesFileExist obj_fn - if not obj_exist - then return Nothing - else - do let stub_fn = case splitFilename3 obj_fn of - (dir, base, ext) -> dir ++ "/" ++ base ++ ".stub_o" - stub_exist <- doesFileExist stub_fn - obj_time <- getModificationTime obj_fn - if stub_exist - then return (Just (LM obj_time mod [DotO obj_fn, DotO stub_fn])) - else return (Just (LM obj_time mod [DotO obj_fn])) - hptLinkables :: HomePackageTable -> [Linkable] -- Get all the linkables from the home package table, one for each module -- Once the HPT is up to date, these are the ones we should link diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index a918590..5880de0 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -10,7 +10,7 @@ module Desugar ( deSugar, deSugarExpr ) where import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), ExternalPackageState(..), - PersistentCompilerState(..), + PersistentCompilerState(..), Dependencies(..), lookupType, unQualInScope ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) @@ -89,7 +89,9 @@ deSugar hsc_env pcs (printDump (ppr_ds_rules ds_rules)) ; let - deps = (moduleEnvElts (dep_mods imports), dep_pkgs imports) + deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), + dep_pkgs = imp_dep_pkgs imports, + dep_orphs = imp_orphs imports } mod_guts = ModGuts { mg_module = mod, mg_exports = exports, diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index caea804..f6f0522 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -52,8 +52,10 @@ import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- ws previously used in this file. import qualified OccName( varName, tcName ) -import Module ( moduleUserString ) +import Module ( Module, mkThPkgModule, moduleUserString ) import Id ( Id, idType ) +import Name ( mkKnownKeyExternalName ) +import OccName ( mkOccFS ) import NameEnv import NameSet import Type ( Type, TyThing(..), mkGenTyConApp ) @@ -976,7 +978,7 @@ thModule :: Module -- NB: the THSyntax module comes from the "haskell-src" package thModule = mkThPkgModule mETA_META_Name -mk_known_key_name space mod str uniq +mk_known_key_name space str uniq = mkKnownKeyExternalName thModule (mkOccFS space str) uniq intLName = varQual FSLIT("intL") intLIdKey diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 2b45436..7f34acb 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -16,7 +16,7 @@ necessary. {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} module Linker ( HValue, initLinker, showLinkerState, - linkPackages, linkLibraries, + linkPackages, linkLibraries, findLinkable, linkModules, unload, extendLinkEnv, linkExpr, LibrarySpec(..) ) where @@ -33,16 +33,19 @@ import ByteCodeAsm ( CompiledByteCode(..), bcosFreeNames, import Packages ( PackageConfig(..), PackageName, PackageConfigMap, lookupPkg, packageDependents, packageNameString ) import DriverState ( v_Library_paths, v_Cmdline_libraries, getPackageConfigMap ) - +import DriverUtil ( splitFilename3 ) +import Finder ( findModule ) import HscTypes ( Linkable(..), isObjectLinkable, nameOfObject, byteCodeOfObject, - Unlinked(..), isInterpretable, isObject, + Unlinked(..), isInterpretable, isObject, Dependencies(..), HscEnv(..), PersistentCompilerState(..), ExternalPackageState(..), - HomePackageTable, PackageIfaceTable, ModIface(..), HomeModInfo(..) ) + HomePackageTable, PackageIfaceTable, ModIface(..), HomeModInfo(..), + lookupIface ) import Name ( Name, nameModule, isExternalName ) import NameEnv import NameSet ( nameSetToList ) -import Module ( Module, ModuleName, moduleName, lookupModuleEnvByName ) +import Module ( ModLocation(..), Module, ModuleName, moduleName, lookupModuleEnvByName ) import FastString ( FastString(..), unpackFS ) +import ListSetOps ( minusList ) import CmdLineOpts ( DynFlags(verbosity) ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable @@ -54,10 +57,10 @@ import ErrUtils ( Message ) import Control.Monad ( when, filterM, foldM ) import Data.IORef ( IORef, readIORef, writeIORef ) -import Data.List ( partition ) +import Data.List ( partition, nub ) import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) -import System.Directory ( doesFileExist ) +import System.Directory ( doesFileExist, getModificationTime ) import Control.Exception ( block, throwDyn ) @@ -176,11 +179,11 @@ linkExpr :: HscEnv -> PersistentCompilerState -- dependents to link. linkExpr hsc_env pcs (root_ul_bco, aux_ul_bcos) - = -- Find what packages and linkables are required - case getLinkDeps hpt pit needed_mods of { - Left msg -> dieWith (msg $$ ptext SLIT("When linking an expression")) ; - Right (lnks, pkgs) -> do { + = do { + -- Find what packages and linkables are required + (lnks, pkgs) <- getLinkDeps hpt pit needed_mods ; + -- Link the packages and modules required linkPackages dflags pkgs ; ok <- linkModules dflags lnks ; if failed ok then @@ -195,7 +198,7 @@ linkExpr hsc_env pcs (root_ul_bco, aux_ul_bcos) -- Link the necessary packages and linkables ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce all_bcos ; return root_hval - }}} + }} where pit = eps_PIT (pcs_EPS pcs) hpt = hsc_HPT hsc_env @@ -209,45 +212,62 @@ linkExpr hsc_env pcs (root_ul_bco, aux_ul_bcos) dieWith msg = throwDyn (UsageError (showSDoc msg)) getLinkDeps :: HomePackageTable -> PackageIfaceTable - -> [Module] -- If you need these - -> Either Message - ([Linkable], [PackageName]) -- ... then link these first + -> [Module] -- If you need these + -> IO ([Linkable], [PackageName]) -- ... then link these first +-- Fails with an IO exception if it can't find enough files +getLinkDeps hpt pit mods -- Find all the packages and linkables that a set of modules depends on + = do { pls <- readIORef v_PersistentLinkerState ; + let { + -- 1. Find the iface for each module (must exist), + -- and extract its dependencies + deps = [ mi_deps (get_iface mod) | mod <- mods ] ; + + -- 2. Find the dependent home-pkg-modules/packages from each iface + -- Include mods themselves; and exclude ones already linked + mods_needed = nub (map moduleName mods ++ [m | dep <- deps, (m,_) <- dep_mods dep]) + `minusList` + linked_mods ; + linked_mods = map linkableModName (objs_loaded pls ++ bcos_loaded pls) ; + + pkgs_needed = nub (concatMap dep_pkgs deps) + `minusList` + pkgs_loaded pls } ; + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot compilation) + -- we may need to use maybe_getFileLinkable + lnks_needed <- mapM get_linkable mods_needed ; -getLinkDeps hpt pit mods - = go [] -- Linkables so far - [] -- Packages so far - [] -- Modules dealt with - (map moduleName mods) -- The usage info that we use for - -- dependencies has ModuleNames not Modules + return (lnks_needed, pkgs_needed) } where - go lnks pkgs _ [] = Right (lnks,pkgs) - go lnks pkgs mods_done (mod:mods) - | mod `elem` mods_done - = -- Already dealt with - go lnks pkgs mods_done mods - - | Just mod_info <- lookupModuleEnvByName hpt mod - = -- OK, so it's a home module - let - mod_deps = [m | (m,_,_,_) <- mi_usages (hm_iface mod_info)] - -- Get the modules that this one depends on - in - go (hm_linkable mod_info : lnks) pkgs (mod : mods_done) (mod_deps ++ mods) - - | Just pkg_iface <- lookupModuleEnvByName pit mod - = -- It's a package module, so add it to the package list - let - pkg_name = mi_package pkg_iface - pkgs' | pkg_name `elem` pkgs = pkgs - | otherwise = pkg_name : pkgs - in - go lnks pkgs' (mod : mods_done) mods - - | otherwise - = -- Not in either table - Left (ptext SLIT("Can't find compiled code for dependent module") <+> ppr mod) + get_iface mod = case lookupIface hpt pit mod of + Just iface -> iface + Nothing -> pprPanic "getLinkDeps" (no_iface mod) + no_iface mod = ptext SLIT("No iface for") <+> ppr mod + -- This one is a GHC bug + + no_obj mod = dieWith (ptext SLIT("No compiled code for for") <+> ppr mod) + -- This one is a build-system bug + + get_linkable mod_name -- A home-package module + | Just mod_info <- lookupModuleEnvByName hpt mod_name + = return (hm_linkable mod_info) + | otherwise + = -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + do { mb_stuff <- findModule mod_name ; + case mb_stuff of { + Nothing -> no_obj mod_name ; + Just (_, loc) -> do { + + -- ...and then find the linkable for it + mb_lnk <- findLinkable mod_name loc ; + case mb_lnk of { + Nothing -> no_obj mod_name ; + Just lnk -> return lnk + }}}} \end{code} @@ -761,6 +781,24 @@ findFile mk_file_path (dir:dirs) return (Just file_path) else findFile mk_file_path dirs } + + +findLinkable :: ModuleName -> ModLocation -> IO (Maybe Linkable) +findLinkable mod locn + | Just obj_fn <- ml_obj_file locn + = do obj_exist <- doesFileExist obj_fn + if not obj_exist + then return Nothing + else + do let stub_fn = case splitFilename3 obj_fn of + (dir, base, ext) -> dir ++ "/" ++ base ++ ".stub_o" + stub_exist <- doesFileExist stub_fn + obj_time <- getModificationTime obj_fn + if stub_exist + then return (Just (LM obj_time mod [DotO obj_fn, DotO stub_fn])) + else return (Just (LM obj_time mod [DotO obj_fn])) + | otherwise + = return Nothing \end{code} \begin{code} diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index c993257..8915ef2 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -393,6 +393,16 @@ instance Binary ParsedIface where -- Imported from other files :- +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) + instance (Binary name) => Binary (GenAvailInfo name) where put_ bh (Avail aa) = do putByte bh 0 diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 586a4bd..fdd66c7 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -32,7 +32,8 @@ module HscTypes ( extendTypeEnvList, extendTypeEnvWithIds, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - WhetherHasOrphans, IsBootInterface, DeclsMap, Usage(..), Dependencies, + WhetherHasOrphans, IsBootInterface, DeclsMap, Usage(..), + Dependencies(..), noDependencies, IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availName, availNames, @@ -146,14 +147,12 @@ data HomeModInfo = HomeModInfo { hm_iface :: ModIface, Simple lookups in the symbol table. \begin{code} -lookupIface :: HomePackageTable -> PackageIfaceTable -> Name -> Maybe ModIface +lookupIface :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface -- We often have two IfaceTables, and want to do a lookup -lookupIface hpt pit name +lookupIface hpt pit mod = case lookupModuleEnv hpt mod of Just mod_info -> Just (hm_iface mod_info) Nothing -> lookupModuleEnv pit mod - where - mod = nameModule name lookupIfaceByModName :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface -- We often have two IfaceTables, and want to do a lookup @@ -328,7 +327,7 @@ emptyModIface mod mi_package = basePackage, -- XXX fully bogus mi_version = initialVersionInfo, mi_usages = [], - mi_deps = ([], []), + mi_deps = noDependencies, mi_orphan = False, mi_boot = False, mi_exports = [], @@ -618,9 +617,14 @@ type IsBootInterface = Bool -- in the import hierarchy. See TcRnTypes.ImportAvails for details. -- -- Invariant: the dependencies of a module M never includes M -type Dependencies - = ([(ModuleName, WhetherHasOrphans, IsBootInterface)], [PackageName]) - +data Dependencies + = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies + dep_pkgs :: [PackageName], -- External package dependencies + dep_orphs :: [ModuleName] } -- Orphan modules (whether home or external pkg) + +noDependencies :: Dependencies +noDependencies = Deps [] [] [] + data Usage name = Usage { usg_name :: ModuleName, -- Name of the module usg_mod :: Version, -- Module version diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 4317be4..b4178db 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -26,10 +26,10 @@ import TcRnTypes ( ImportAvails(..) ) import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) import HscTypes ( VersionInfo(..), ModIface(..), HomeModInfo(..), ModGuts(..), ModGuts, - GhciMode(..), HscEnv(..), + GhciMode(..), HscEnv(..), Dependencies(..), FixityEnv, lookupFixity, collectFixities, IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, Dependencies, + TyThing(..), DFunId, Avails, AvailInfo, GenAvailInfo(..), availName, ExternalPackageState(..), ParsedIface(..), Usage(..), @@ -476,7 +476,7 @@ mkUsageInfo :: HscEnv -> ExternalPackageState mkUsageInfo hsc_env eps (ImportAvails { imp_mods = dir_imp_mods, - dep_mods = dep_mods }) + imp_dep_mods = dep_mods }) 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 @@ -484,7 +484,7 @@ mkUsageInfo hsc_env eps usages `seqList` usages where usages = catMaybes [ mkUsage mod_name - | (mod_name,_,_) <- moduleEnvElts dep_mods] + | (mod_name,_) <- moduleEnvElts dep_mods] hpt = hsc_HPT hsc_env pit = eps_PIT eps @@ -781,16 +781,15 @@ pprUsage getOcc usage pprDeps :: Dependencies -> SDoc -pprDeps (mods, pkgs) +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), - ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs)] + ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), + ptext SLIT("orphans:") <+> fsep (map ppr orphs) + ] where - ppr_mod (mod_name, orph, boot) - = ppr mod_name <+> ppr_orphan orph <+> ppr_boot boot + ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot - ppr_orphan True = char '!' - ppr_orphan False = empty - ppr_boot True = char '@' + ppr_boot True = text "[boot]" ppr_boot False = empty \end{code} diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index d434747..f5993d1 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.112 2002/10/24 14:17:50 simonpj Exp $ +$Id: Parser.y,v 1.113 2002/10/25 15:23:06 simonpj Exp $ Haskell grammar. @@ -17,7 +17,7 @@ import HsSyn import HsTypes ( mkHsTupCon ) import RdrHsSyn -import HscTypes ( ParsedIface(..), IsBootInterface ) +import HscTypes ( ParsedIface(..), IsBootInterface, noDependencies ) import Lex import RdrName import PrelNames ( mAIN_Name, funTyConName, listTyConName, @@ -295,7 +295,7 @@ iface :: { ParsedIface } pi_vers = 1, -- Module version pi_orphan = False, pi_exports = (1,[($2,mkIfaceExports $4)]), - pi_deps = ([],[]), + pi_deps = noDependencies, pi_usages = [], pi_fixity = [], pi_insts = [], diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index bdab40a..39226b7 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -18,10 +18,10 @@ import DriverUtil ( splitFilename, replaceFilenameSuffix ) import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Parser ( parseIface ) import HscTypes ( ModIface(..), emptyModIface, - ExternalPackageState(..), + ExternalPackageState(..), noDependencies, VersionInfo(..), Usage(..), lookupIfaceByModName, RdrExportItem, - WhetherHasOrphans, IsBootInterface, + IsBootInterface, DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls, AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs, Avails, availNames, availName, Deprecations(..) @@ -135,18 +135,16 @@ loadInterface doc_str mod_name from -- before we got to real imports. other -> - traceRn (vcat [text "loadInterface" <+> brackets doc_str, - ppr (dep_mods import_avails)]) `thenM_` let - mod_map = dep_mods import_avails + mod_map = imp_dep_mods import_avails mod_info = lookupModuleEnvByName mod_map mod_name hi_boot_file = case (from, mod_info) of - (ImportByUser is_boot, _) -> is_boot - (ImportForUsage is_boot, _) -> is_boot - (ImportBySystem, Just (_, _, is_boot)) -> is_boot - (ImportBySystem, Nothing) -> False + (ImportByUser is_boot, _) -> is_boot + (ImportForUsage is_boot, _) -> is_boot + (ImportBySystem, Just (_, is_boot)) -> is_boot + (ImportBySystem, Nothing) -> False -- We're importing a module we know absolutely -- nothing about, so we assume it's from -- another package, where we aren't doing @@ -154,8 +152,8 @@ loadInterface doc_str mod_name from redundant_source_import = case (from, mod_info) of - (ImportByUser True, Just (_, _, False)) -> True - other -> False + (ImportByUser True, Just (_, False)) -> True + other -> False in -- Issue a warning for a redundant {- SOURCE -} import @@ -685,7 +683,7 @@ ghcPrimIface :: ParsedIface ghcPrimIface = ParsedIface { pi_mod = gHC_PRIM_Name, pi_pkg = basePackage, - pi_deps = ([],[]), + pi_deps = noDependencies, pi_vers = 1, pi_orphan = False, pi_usages = [], diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 260981a..76dd8da 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -498,7 +498,7 @@ getImportedInstDecls gates old_gates = eps_inst_gates eps new_gates = gates `minusNameSet` old_gates all_gates = new_gates `unionNameSets` old_gates - orphan_mods = [mod | (mod, True, _) <- moduleEnvElts (dep_mods imports)] + orphan_mods = imp_orphs imports in loadOrphanModules orphan_mods `thenM_` @@ -599,7 +599,7 @@ checkVersions source_unchanged iface -- Source code unchanged and no errors yet... carry on -- First put the dependent-module info in the envt, just temporarily, - -- so that when we look for interfaces we look for the right one. + -- 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). @@ -609,7 +609,7 @@ checkVersions source_unchanged iface where -- This is a bit of a hack really - mod_deps = emptyImportAvails { dep_mods = mkModDeps (fst (mi_deps iface)) } + mod_deps = emptyImportAvails { imp_dep_mods = mkModDeps (dep_mods (mi_deps iface)) } checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired checkList [] = returnM upToDate diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 5a1a743..60044be 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -35,9 +35,9 @@ import NameEnv import OccName ( OccName, dataName, isTcOcc ) import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, GenAvailInfo(..), AvailInfo, Avails, - IsBootInterface, WhetherHasOrphans, + IsBootInterface, availName, availNames, availsToNameSet, - Deprecations(..), ModIface(..), + Deprecations(..), ModIface(..), Dependencies(..), GlobalRdrElt(..), unQualInScope, isLocalGRE ) import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, @@ -140,6 +140,7 @@ importsFromImportDecl this_mod avails_by_module = mi_exports iface deprecs = mi_deprecs iface is_orph = mi_orphan iface + deps = mi_deps iface avails :: Avails avails = [ avail | (mod_name, avails) <- avails_by_module, @@ -168,10 +169,10 @@ importsFromImportDecl this_mod filterImports imp_mod is_boot imp_spec avails `thenM` \ (filtered_avails, explicits) -> let - (sub_dep_mods, sub_dep_pkgs) = mi_deps iface + -- Compute new transitive dependencies + orphans | is_orph = insert imp_mod_name (dep_orphs deps) + | otherwise = dep_orphs deps - -- Compute new transitive dependencies: take the ones in - -- the interface and add (dependent_mods, dependent_pkgs) | isHomeModule imp_mod = -- Imported module is from the home package @@ -179,19 +180,16 @@ importsFromImportDecl this_mod -- (a) remove this_mod (might be there as a hi-boot) -- (b) add imp_mod itself -- Take its dependent packages unchanged - ((imp_mod_name, is_orph, is_boot) : filter not_self sub_dep_mods, - sub_dep_pkgs) + ((imp_mod_name, is_boot) : filter not_self (dep_mods deps), dep_pkgs deps) + | otherwise = -- Imported module is from another package - -- Take only the orphan modules from its dependent modules - -- (sigh! it would be better to dump them entirely) + -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages -- from imp_mod - (filter sub_is_orph sub_dep_mods, - insert (mi_package iface) sub_dep_pkgs) + ([], insert (mi_package iface) (dep_pkgs deps)) - not_self (m, _, _) = m /= this_mod_name - sub_is_orph (_, orph, _) = orph + not_self (m, _) = m /= this_mod_name import_all = case imp_spec of (Just (False, _)) -> False -- Imports are spec'd explicitly @@ -201,7 +199,7 @@ importsFromImportDecl this_mod qual_mod_name = case as_mod of Nothing -> imp_mod_name Just another_name -> another_name - + -- unqual_avails is the Avails that are visible in *unqualified* form -- We need to know this so we know what to export when we see -- module M ( module P ) where ... @@ -217,8 +215,9 @@ importsFromImportDecl this_mod imp_unqual = unitModuleEnvByName qual_mod_name unqual_avails, imp_env = avail_env, imp_mods = unitModuleEnv imp_mod (imp_mod, import_all), - dep_mods = mkModDeps dependent_mods, - dep_pkgs = dependent_pkgs } + imp_orphs = orphans, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = dependent_pkgs } in -- Complain if we import a deprecated module @@ -231,11 +230,11 @@ importsFromImportDecl this_mod returnM (gbl_env, imports) } -mkModDeps :: [(ModuleName, WhetherHasOrphans, IsBootInterface)] - -> ModuleEnv (ModuleName, WhetherHasOrphans, IsBootInterface) +mkModDeps :: [(ModuleName, IsBootInterface)] + -> ModuleEnv (ModuleName, IsBootInterface) mkModDeps deps = foldl add emptyModuleEnv deps where - add env elt@(m,_,_) = extendModuleEnvByName env m elt + add env elt@(m,_) = extendModuleEnvByName env m elt \end{code} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 1210d3c..3755249 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -100,7 +100,7 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), ModIface, ModDetails(..), ModGuts(..), HscEnv(..), ModIface(..), ModDetails(..), IfaceDecls(..), - GhciMode(..), + GhciMode(..), Dependencies(..), noDependencies, Deprecations(..), plusDeprecs, emptyGlobalRdrEnv, GenAvailInfo(Avail), availsToNameSet, @@ -147,7 +147,7 @@ tcRnModule hsc_env pcs updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports }) $ do { - traceRn (text "rn1" <+> ppr (dep_mods imports)) ; + traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ; -- Fail if there are any errors so far -- The error printing (if needed) takes advantage -- of the tcg_env we have now set @@ -556,7 +556,7 @@ tcRnExtCore hsc_env pcs mod_guts = ModGuts { mg_module = this_mod, mg_usages = [], -- ToDo: compute usage mg_dir_imps = [], -- ?? - mg_deps = ([],[]), -- ?? + mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, @@ -1172,8 +1172,8 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_insts dfun_ids , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) - , ppr (moduleEnvElts (dep_mods imports)) - , ppr (dep_pkgs imports)] + , ppr (moduleEnvElts (imp_dep_mods imports)) + , ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env, diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index beff457..e81813e 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -49,7 +49,7 @@ import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo ) import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv, TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo, availName, - IsBootInterface, Deprecations, WhetherHasOrphans ) + IsBootInterface, Deprecations ) import Packages ( PackageName ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) @@ -76,7 +76,7 @@ import UNSAFE_IO ( unsafeInterleaveIO ) import FIX_IO ( fixIO ) import EXCEPTION ( Exception ) import Maybe ( mapMaybe ) -import List ( nub ) +import ListSetOps ( unionLists ) import Panic ( tryMost ) \end{code} @@ -483,11 +483,8 @@ data ImportAvails -- need to recompile if the module version changes -- (b) to specify what child modules to initialise - dep_mods :: ModuleEnv (ModuleName, WhetherHasOrphans, IsBootInterface), - -- For a given import or set of imports, - -- there's an entry here for - -- (a) modules below the one being compiled, in the current package - -- (b) orphan modules below the one being compiled, regardless of package + imp_dep_mods :: ModuleEnv (ModuleName, IsBootInterface), + -- Home-package modules needed by the module being compiled -- -- It doesn't matter whether any of these dependencies are actually -- *used* when compiling the module; they are listed if they are below @@ -495,40 +492,40 @@ data ImportAvails -- compiling M might not need to consult X.hi, but X is still listed -- in M's dependencies. - dep_pkgs :: [PackageName] + imp_dep_pkgs :: [PackageName], -- Packages needed by the module being compiled, whether -- directly, or via other modules in this package, or via -- modules imported from other packages. + + imp_orphs :: [ModuleName] + -- Orphan modules below us in the import tree } emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, - imp_unqual = emptyModuleEnv, - imp_mods = emptyModuleEnv, - dep_mods = emptyModuleEnv, - dep_pkgs = [] } +emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, + imp_unqual = emptyModuleEnv, + imp_mods = emptyModuleEnv, + imp_dep_mods = emptyModuleEnv, + imp_dep_pkgs = [], + imp_orphs = [] } plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_env = env1, imp_unqual = unqual1, imp_mods = mods1, - dep_mods = dmods1, dep_pkgs = dpkgs1 }) + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 }) (ImportAvails { imp_env = env2, imp_unqual = unqual2, imp_mods = mods2, - dep_mods = dmods2, dep_pkgs = dpkgs2 }) + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 }) = ImportAvails { imp_env = env1 `plusAvailEnv` env2, imp_unqual = plusModuleEnv_C plusAvailEnv unqual1 unqual2, imp_mods = mods1 `plusModuleEnv` mods2, - dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2, - dep_pkgs = nub (dpkgs1 ++ dpkgs2) } + imp_dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, + imp_orphs = orphs1 `unionLists` orphs2 } where - plus_mod_dep (m1, orphan1, boot1) (m2, orphan2, boot2) - = WARN( not (m1 == m2 && (boot1 || boot2 || orphan1 == orphan2)), - (ppr m1 <+> ppr m2) $$ (ppr orphan1 <+> ppr orphan2) $$ (ppr boot1 <+> ppr boot2) ) - -- Check mod-names match, and orphan-hood matches; but a boot interface - -- might not know about orphan hood, so only check the orphan match - -- if both are non-boot interfaces - (m1, orphan1 || orphan2, boot1 && boot2) - -- If either side can "see" a non-hi-boot interface, use that - -- Similarly orphan-hood (see note about about why orphan1 and 2 might differ) + plus_mod_dep (m1, boot1) (m2, boot2) + = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) + -- Check mod-names match + (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that \end{code} %************************************************************************ @@ -539,7 +536,7 @@ v%************************************************************************ \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) +plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2) -- Added SOF 4/97 #ifdef DEBUG plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) -- 1.7.10.4