X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=12316713d6122f59386d8a27f032b3ef11da8079;hp=0cfd00f9ff7eda6f8084905c2f2f88e7ebbab7a9;hb=091fceaeb313c2d2504c005ddc1067ad6f9c60c6;hpb=930421d4ed09e5389e0ef4c5eef36075a6809cc0 diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 0cfd00f..1231671 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -14,7 +14,7 @@ module Packages ( PackageState(..), initPackages, getPackageDetails, - lookupModuleInAllPackages, + lookupModuleInAllPackages, lookupModuleWithSuggestions, -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -36,13 +36,11 @@ where #include "HsVersions.h" import PackageConfig -import ParsePkgConf ( loadPackageConfig ) -import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) +import DynFlags import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM -import FiniteMap import Module import Util import Panic @@ -58,9 +56,14 @@ import ErrUtils ( debugTraceMsg, putMsg, Message ) import Exception import System.Directory -import System.FilePath +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix import Control.Monad import Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map +import qualified Data.Set as Set -- --------------------------------------------------------------------------- -- The Package state @@ -126,7 +129,9 @@ data PackageState = PackageState { -- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig' type PackageConfigMap = UniqFM PackageConfig -type InstalledPackageIdMap = FiniteMap InstalledPackageId PackageId +type InstalledPackageIdMap = Map InstalledPackageId PackageId + +type InstalledPackageIndex = Map InstalledPackageId PackageConfig emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM @@ -166,7 +171,7 @@ initPackages :: DynFlags -> IO (DynFlags, [PackageId]) initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags - Just db -> return db + Just db -> return $ maybeHidePackages dflags db (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, @@ -192,7 +197,7 @@ readPackageConfigs dflags = do -- the we tack on the system paths. pkgs <- mapM (readPackageConfig dflags) - (reverse pkgconfs ++ reverse (extraPkgConfs dflags)) + (pkgconfs ++ reverse (extraPkgConfs dflags)) -- later packages shadow earlier ones. extraPkgConfs -- is in the opposite order to the flags on the -- command line. @@ -218,7 +223,7 @@ getSystemPackageConfigs dflags = do if exist then return [pkgconf] else return [] `catchIO` (\_ -> return []) - return (user_pkgconf ++ [system_pkgconf]) + return (system_pkgconf : user_pkgconf) readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do @@ -237,11 +242,13 @@ readPackageConfig dflags conf_file = do ghcError $ InstallationError $ "can't find a package database at " ++ conf_file debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) - loadPackageConfig dflags conf_file + str <- readFile conf_file + return (map installedPackageInfoToPackageConfig $ read str) let top_dir = topDir dflags - pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs + pkgroot = takeDirectory conf_file + pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs pkg_configs2 = maybeHidePackages dflags pkg_configs1 -- return pkg_configs2 @@ -253,27 +260,54 @@ maybeHidePackages dflags pkgs where hide pkg = pkg{ exposed = False } -mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig] --- Replace the string "$topdir" at the beginning of a path --- with the current topdir (obtained from the -B option). -mungePackagePaths top_dir ps = map munge_pkg ps - where - munge_pkg p = p{ importDirs = munge_paths (importDirs p), - includeDirs = munge_paths (includeDirs p), - libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p), - haddockInterfaces = munge_paths (haddockInterfaces p), - haddockHTMLs = munge_paths (haddockHTMLs p) - } - - munge_paths = map munge_path - - munge_path p - | Just p' <- stripPrefix "$topdir" p = top_dir ++ p' - | Just p' <- stripPrefix "$httptopdir" p = toHttpPath top_dir ++ p' - | otherwise = p - - toHttpPath p = "file:///" ++ p +-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs +mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + haddockHTMLs = munge_urls (haddockHTMLs pkg) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing -- ----------------------------------------------------------------------------- @@ -328,7 +362,7 @@ selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] selectPackages matches pkgs unusable = let (ps,rest) = partition matches pkgs - reasons = [ (p, lookupFM unusable (installedPackageId p)) + reasons = [ (p, Map.lookup (installedPackageId p) unusable) | p <- ps ] in if all (isJust.snd) reasons @@ -354,6 +388,15 @@ comparing f a b = f a `compare` f b packageFlagErr :: PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a + +-- for missing DPH package we emit a more helpful error message, because +-- this may be the result of using -fdph-par or -fdph-seq. +packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg + = ghcError (CmdLineError (showSDoc $ dph_err)) + where dph_err = text "the " <> text pkg <> text " package is not installed." + $$ text "To install it: \"cabal install dph\"." + is_dph_package pkg = "dph" `isPrefixOf` pkg + packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) where err = text "cannot satisfy " <> ppr_flag <> (if null reasons then empty else text ": ") $$ @@ -414,7 +457,6 @@ findWiredInPackages dflags pkgs = do integerPackageId, basePackageId, rtsPackageId, - haskell98PackageId, thPackageId, dphSeqPackageId, dphParPackageId ] @@ -490,7 +532,7 @@ data UnusablePackageReason | MissingDependencies [InstalledPackageId] | ShadowedBy InstalledPackageId -type UnusablePackages = FiniteMap InstalledPackageId UnusablePackageReason +type UnusablePackages = Map InstalledPackageId UnusablePackageReason pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of @@ -504,7 +546,7 @@ pprReason pref reason = case reason of pref <+> ptext (sLit "shadowed by package ") <> text (display ipid) reportUnusable :: DynFlags -> UnusablePackages -> IO () -reportUnusable dflags pkgs = mapM_ report (fmToList pkgs) +reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) where report (ipid, reason) = debugTraceMsg dflags 2 $ @@ -521,50 +563,58 @@ reportUnusable dflags pkgs = mapM_ report (fmToList pkgs) -- satisfied until no more can be added. -- findBroken :: [PackageConfig] -> UnusablePackages -findBroken pkgs = go [] emptyFM pkgs +findBroken pkgs = go [] Map.empty pkgs where go avail ipids not_avail = case partitionWith (depsAvailable ipids) not_avail of ([], not_avail) -> - listToFM [ (installedPackageId p, MissingDependencies deps) - | (p,deps) <- not_avail ] + Map.fromList [ (installedPackageId p, MissingDependencies deps) + | (p,deps) <- not_avail ] (new_avail, not_avail) -> go (new_avail ++ avail) new_ipids (map fst not_avail) - where new_ipids = addListToFM ipids + where new_ipids = Map.insertList [ (installedPackageId p, p) | p <- new_avail ] + ipids - depsAvailable :: FiniteMap InstalledPackageId PackageConfig + depsAvailable :: InstalledPackageIndex -> PackageConfig -> Either PackageConfig (PackageConfig, [InstalledPackageId]) depsAvailable ipids pkg | null dangling = Left pkg | otherwise = Right (pkg, dangling) - where dangling = filter (not . (`elemFM` ipids)) (depends pkg) + where dangling = filter (not . (`Map.member` ipids)) (depends pkg) -- ----------------------------------------------------------------------------- -- 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 - in listToFM shadowed +-- 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 Map.fromList 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 -- ----------------------------------------------------------------------------- ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages -ignorePackages flags pkgs = listToFM (concatMap doit flags) +ignorePackages flags pkgs = Map.fromList (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of @@ -576,6 +626,20 @@ ignorePackages flags pkgs = listToFM (concatMap doit flags) doit _ = panic "ignorePackages" -- ----------------------------------------------------------------------------- + +depClosure :: InstalledPackageIndex + -> [InstalledPackageId] + -> [InstalledPackageId] +depClosure index ipids = closure Map.empty ipids + where + closure set [] = Map.keys set + closure set (ipid : ipids) + | ipid `Map.member` set = closure set ipids + | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) + (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. @@ -587,23 +651,89 @@ mkPackageState -> IO (PackageState, [PackageId], -- new packages to preload PackageId) -- this package, might be modified if the current - -- package is a wired-in package. 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) + flags = reverse (packageFlags dflags) ++ dphPackage + -- expose the appropriate DPH backend library + dphPackage = case dphBackend dflags of + DPHPar -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"] + DPHSeq -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"] + DPHThis -> [] + DPHNone -> [] + + -- pkgs0 with duplicate packages filtered out. This is + -- important: it is possible for a package in the global package + -- DB to have the same IPID as a package in the user DB, and + -- we want the latter 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. + -- + -- #4072: note that we must retain the ordering of the list here + -- so that shadowing behaves as expected when we apply it later. + pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0 + where del p (s,ps) + | pid `Set.member` s = (s,ps) + | otherwise = (Set.insert pid s, p:ps) + where pid = installedPackageId p + -- XXX this is just a variant of nub + + ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ] + + 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 . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique broken = findBroken pkgs0' - unusable = shadowed `plusFM` ignored `plusFM` broken + unusable = shadowed `Map.union` ignored `Map.union` broken reportUnusable dflags unusable @@ -611,8 +741,8 @@ 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 - let pkgs2 = filter (not . (`elemFM` unusable) . installedPackageId) pkgs1 + pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags + let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" @@ -634,12 +764,12 @@ mkPackageState dflags pkgs0 preload0 this_package = do let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4 - ipid_map = listToFM [ (installedPackageId p, packageConfigId p) - | p <- pkgs4 ] + ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p) + | p <- pkgs4 ] lookupIPID ipid@(InstalledPackageId str) - | Just pid <- lookupFM ipid_map ipid = return pid - | otherwise = missingPackageErr str + | Just pid <- Map.lookup ipid ipid_map = return pid + | otherwise = missingPackageErr str preload2 <- mapM lookupIPID preload1 @@ -654,19 +784,19 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- set up preloaded package when we are just building it preload3 = nub $ filter (/= this_package) $ (basicLinkedPackages ++ preload2) - + -- Close the preload packages with their dependencies dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleMap pkg_db, + pkgIdMap = pkg_db, + moduleToPkgConfAll = mkModuleMap pkg_db, installedPackageIdMap = ipid_map - } + } return (pstate, new_dep_preload, this_package) - + -- ----------------------------------------------------------------------------- -- Make the mapping from module to package info @@ -734,12 +864,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)) @@ -775,10 +913,32 @@ getPackageFrameworks dflags pkgs = do -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is @True@ if the package exposes the module. lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] -lookupModuleInAllPackages dflags m = - case lookupUFM (moduleToPkgConfAll (pkgState dflags)) m of - Nothing -> [] - Just ps -> ps +lookupModuleInAllPackages dflags m + = case lookupModuleWithSuggestions dflags m of + Right pbs -> pbs + Left _ -> [] + +lookupModuleWithSuggestions + :: DynFlags -> ModuleName + -> Either [Module] [(PackageConfig,Bool)] + -- Lookup module in all packages + -- Right pbs => found in pbs + -- Left ms => not found; but here are sugestions +lookupModuleWithSuggestions dflags m + = case lookupUFM (moduleToPkgConfAll pkg_state) m of + Nothing -> Left suggestions + Just ps -> Right ps + where + pkg_state = pkgState dflags + suggestions + | dopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods + | otherwise = [] + + all_mods :: [(String, Module)] -- All modules + all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm) + | pkg_config <- eltsUFM (pkgIdMap pkg_state) + , let pkg_id = packageConfigId pkg_config + , mod_nm <- exposedModules pkg_config ] -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's @@ -797,7 +957,7 @@ getPreloadPackagesAnd dflags pkgids = -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). closeDeps :: PackageConfigMap - -> FiniteMap InstalledPackageId PackageId + -> Map InstalledPackageId PackageId -> [(PackageId, Maybe PackageId)] -> IO [PackageId] closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) @@ -808,14 +968,14 @@ throwErr m = case m of Succeeded r -> return r closeDepsErr :: PackageConfigMap - -> FiniteMap InstalledPackageId PackageId + -> Map InstalledPackageId PackageId -> [(PackageId,Maybe PackageId)] -> MaybeErr Message [PackageId] closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper add_package :: PackageConfigMap - -> FiniteMap InstalledPackageId PackageId + -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) -> MaybeErr Message [PackageId] @@ -831,7 +991,7 @@ add_package pkg_db ipid_map ps (p, mb_parent) return (p : ps') where add_package_ipid ps ipid@(InstalledPackageId str) - | Just pid <- lookupFM ipid_map ipid + | Just pid <- Map.lookup ipid ipid_map = add_package pkg_db ipid_map ps (pid, Just p) | otherwise = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent) @@ -851,6 +1011,9 @@ missingDependencyMsg (Just parent) -- | Will the 'Name' come from a dynamically linked library? isDllName :: PackageId -> Name -> Bool +-- Despite the "dll", I think this function just means that +-- the synbol comes from another dynamically-linked package, +-- and applies on all platforms, not just Windows isDllName this_pkg name | opt_Static = False | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg