X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=f6ba7c192da08a90426cf67b33ec3afe923831ec;hb=b84ba676034763b3082bbd9405794a4fde499d14;hp=2e91ac8ade3c02228af5ec15540ff9a860c3c149;hpb=03bb97e0a29fe3f414c17e6b4074f2c9e8e8012e;p=ghc-hetmet.git diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 2e91ac8..f6ba7c1 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -36,7 +36,6 @@ where #include "HsVersions.h" import PackageConfig -import ParsePkgConf ( loadPackageConfig ) import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) import StaticFlags import Config ( cProjectVersion ) @@ -51,6 +50,7 @@ import Maybes import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo +import Distribution.InstalledPackageInfo.Binary import Distribution.Package hiding (PackageId,depends) import FastString import ErrUtils ( debugTraceMsg, putMsg, Message ) @@ -127,6 +127,8 @@ type PackageConfigMap = UniqFM PackageConfig type InstalledPackageIdMap = FiniteMap InstalledPackageId PackageId +type InstalledPackageIndex = FiniteMap InstalledPackageId PackageConfig + emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM @@ -204,44 +206,41 @@ getSystemPackageConfigs dflags = do -- System one always comes first let system_pkgconf = systemPackageConfig dflags - -- allow package.conf.d to contain a bunch of .conf files - -- containing package specifications. This is an easier way - -- to maintain the package database on systems with a package - -- management system, or systems that don't want to run ghc-pkg - -- to register or unregister packages. Undocumented feature for now. - let system_pkgconf_dir = system_pkgconf <.> "d" - system_pkgconf_dir_exists <- doesDirectoryExist system_pkgconf_dir - system_pkgconfs <- - if system_pkgconf_dir_exists - then do files <- getDirectoryContents system_pkgconf_dir - return [ system_pkgconf_dir file - | file <- files - , takeExtension file == ".conf" ] - else return [] - -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) -- unless the -no-user-package-conf flag was given. - -- We only do this when getAppUserDataDirectory is available - -- (GHC >= 6.3). user_pkgconf <- do + if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do appdir <- getAppUserDataDirectory "ghc" let - pkgconf = appdir - (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) - "package.conf" - flg <- doesFileExist pkgconf - if (flg && dopt Opt_ReadUserPackageConf dflags) - then return [pkgconf] - else return [] + dir = appdir (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + pkgconf = dir "package.conf.d" + -- + exist <- doesDirectoryExist pkgconf + if exist then return [pkgconf] else return [] `catchIO` (\_ -> return []) - return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf]) - + return (user_pkgconf ++ [system_pkgconf]) readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do - debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) - proto_pkg_configs <- loadPackageConfig dflags conf_file + isdir <- doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then do let filename = conf_file "package.cache" + debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename) + conf <- readBinPackageDB filename + return (map installedPackageInfoToPackageConfig conf) + + else do + isfile <- doesFileExist conf_file + when (not isfile) $ + ghcError $ InstallationError $ + "can't find a package database at " ++ conf_file + debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) + str <- readFile conf_file + return (map installedPackageInfoToPackageConfig $ read str) + let top_dir = topDir dflags pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs @@ -536,7 +535,7 @@ findBroken pkgs = go [] emptyFM pkgs where new_ipids = addListToFM ipids [ (installedPackageId p, p) | p <- new_avail ] - depsAvailable :: FiniteMap InstalledPackageId PackageConfig + depsAvailable :: InstalledPackageIndex -> PackageConfig -> Either PackageConfig (PackageConfig, [InstalledPackageId]) depsAvailable ipids pkg @@ -548,21 +547,28 @@ findBroken pkgs = go [] emptyFM pkgs -- Eliminate shadowed packages, giving the user some feedback -- later packages in the list should shadow earlier ones with the same --- package name/version. -shadowPackages :: [PackageConfig] -> UnusablePackages -shadowPackages pkgs - = let (_,shadowed) = foldl check (emptyUFM,[]) pkgs +-- package name/version. Additionally, a package may be preferred if +-- it is in the transitive closure of packages selected using -package-id +-- flags. +shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages +shadowPackages pkgs preferred + = let (shadowed,_) = foldl check ([],emptyUFM) pkgs in listToFM shadowed where - check (pkgmap,shadowed) pkg - = (addToUFM pkgmap (packageConfigId pkg) pkg, shadowed') - where - shadowed' + check (shadowed,pkgmap) pkg | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg) - = (installedPackageId oldpkg, ShadowedBy (installedPackageId pkg)) - :shadowed + , let + ipid_new = installedPackageId pkg + ipid_old = installedPackageId oldpkg + -- + , ipid_old /= ipid_new + = if ipid_old `elem` preferred + then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap ) + else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' ) | otherwise - = shadowed + = (shadowed, pkgmap') + where + pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg -- ----------------------------------------------------------------------------- @@ -579,6 +585,20 @@ ignorePackages flags pkgs = listToFM (concatMap doit flags) doit _ = panic "ignorePackages" -- ----------------------------------------------------------------------------- + +depClosure :: InstalledPackageIndex + -> [InstalledPackageId] + -> [InstalledPackageId] +depClosure index ipids = closure emptyFM ipids + where + closure set [] = keysFM set + closure set (ipid : ipids) + | ipid `elemFM` set = closure set ipids + | Just p <- lookupFM index ipid = closure (addToFM set ipid p) + (depends p ++ ipids) + | otherwise = closure set ipids + +-- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our package -- settings and populate the package state. @@ -595,16 +615,69 @@ mkPackageState mkPackageState dflags pkgs0 preload0 this_package = do +{- + Plan. + + 1. P = transitive closure of packages selected by -package-id + + 2. Apply shadowing. When there are multiple packages with the same + sourcePackageId, + * if one is in P, use that one + * otherwise, use the one highest in the package stack + [ + rationale: we cannot use two packages with the same sourcePackageId + in the same program, because sourcePackageId is the symbol prefix. + Hence we must select a consistent set of packages to use. We have + a default algorithm for doing this: packages higher in the stack + shadow those lower down. This default algorithm can be overriden + by giving explicit -package-id flags; then we have to take these + preferences into account when selecting which other packages are + made available. + + Our simple algorithm throws away some solutions: there may be other + consistent sets that would satisfy the -package flags, but it's + not GHC's job to be doing constraint solving. + ] + + 3. remove packages selected by -ignore-package + + 4. remove any packages with missing dependencies, or mutually recursive + dependencies. + + 5. report (with -v) any packages that were removed by steps 2-4 + + 6. apply flags to set exposed/hidden on the resulting packages + - if any flag refers to a package which was removed by 2-4, then + we can give an error message explaining why + + 7. hide any packages which are superseded by later exposed packages +-} + let flags = reverse (packageFlags dflags) + + ipid_map = listToFM [ (installedPackageId p, p) | p <- pkgs0 ] + + -- pkgs0 with duplicate packages filtered out. This is + -- important: it is possible for a package in the user package + -- DB to have the same IPID as a package in the global DB, and + -- we want the former to take precedence. This is not the same + -- as shadowing (below), since in this case the two packages + -- have the same ABI and are interchangeable. + pkgs0_unique = eltsFM ipid_map + + ipid_selected = depClosure ipid_map [ InstalledPackageId i + | ExposePackageId i <- flags ] + (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False - shadowed = shadowPackages pkgs0 - ignored = ignorePackages ignore_flags pkgs0 + shadowed = shadowPackages pkgs0_unique ipid_selected + + ignored = ignorePackages ignore_flags pkgs0_unique - pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0 + pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0_unique broken = findBroken pkgs0' unusable = shadowed `plusFM` ignored `plusFM` broken @@ -614,7 +687,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). -- - pkgs1 <- foldM (applyPackageFlag unusable) pkgs0 other_flags + pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags let pkgs2 = filter (not . (`elemFM` unusable) . installedPackageId) pkgs1 -- Here we build up a set of the packages mentioned in -package @@ -737,12 +810,20 @@ collectLinkOpts dflags ps = concat (map all_opts ps) packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) where - non_dyn_ways = filter ((/= WayDyn) . wayName) (ways dflags) + ways0 = ways dflags + + ways1 = filter ((/= WayDyn) . wayName) ways0 -- the name of a shared library is libHSfoo-ghc.so -- we leave out the _dyn, because it is superfluous - tag = mkBuildTag (filter (not . wayRTSOnly) non_dyn_ways) - rts_tag = mkBuildTag non_dyn_ways + -- debug RTS includes support for -eventlog + ways2 | WayDebug `elem` map wayName ways1 + = filter ((/= WayEventLog) . wayName) ways1 + | otherwise + = ways1 + + tag = mkBuildTag (filter (not . wayRTSOnly) ways2) + rts_tag = mkBuildTag ways2 mkDynName | opt_Static = id | otherwise = (++ ("-ghc" ++ cProjectVersion))