X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=ff316aa02104678e4fd1ff0fbda295a9d4302b9e;hp=4c22b34108c96c7ff98bd056feb2307968fd4539;hb=8c8dc051ba58e394650ae3579a7d2eb67189b297;hpb=45a8d0ceac35f657e8f367a0e0870f2df0acde93 diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 4c22b34..ff316aa 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -41,7 +41,6 @@ import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM -import FiniteMap import Module import Util import Panic @@ -60,6 +59,10 @@ import System.Directory import System.FilePath 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 @@ -125,9 +128,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 = FiniteMap InstalledPackageId PackageConfig +type InstalledPackageIndex = Map InstalledPackageId PackageConfig emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM @@ -193,7 +196,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. @@ -219,7 +222,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 @@ -330,7 +333,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 @@ -356,6 +359,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 ": ") $$ @@ -492,7 +504,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 @@ -506,7 +518,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 $ @@ -523,17 +535,18 @@ 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 :: InstalledPackageIndex -> PackageConfig @@ -541,7 +554,7 @@ findBroken pkgs = go [] emptyFM pkgs 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 @@ -553,15 +566,15 @@ findBroken pkgs = go [] emptyFM pkgs shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages shadowPackages pkgs preferred = let (shadowed,_) = foldl check ([],emptyUFM) pkgs - in listToFM shadowed + in Map.fromList shadowed where check (shadowed,pkgmap) pkg - | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg), - let + | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg) + , let ipid_new = installedPackageId pkg - ipid_old = installedPackageId oldpkg, + ipid_old = installedPackageId oldpkg -- - ipid_old /= ipid_new + , 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' ) @@ -573,7 +586,7 @@ shadowPackages pkgs preferred -- ----------------------------------------------------------------------------- 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 @@ -589,13 +602,13 @@ ignorePackages flags pkgs = listToFM (concatMap doit flags) depClosure :: InstalledPackageIndex -> [InstalledPackageId] -> [InstalledPackageId] -depClosure index ipids = closure emptyFM ipids +depClosure index ipids = closure Map.empty ipids where - closure set [] = keysFM set + closure set [] = Map.keys set closure set (ipid : ipids) - | ipid `elemFM` set = closure set ipids - | Just p <- lookupFM index ipid = closure (addToFM set ipid p) - (depends p ++ 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 -- ----------------------------------------------------------------------------- @@ -656,7 +669,23 @@ mkPackageState dflags pkgs0 preload0 this_package = do 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 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 ] @@ -665,13 +694,13 @@ mkPackageState dflags pkgs0 preload0 this_package = do is_ignore IgnorePackage{} = True is_ignore _ = False - shadowed = shadowPackages pkgs0 ipid_selected + shadowed = shadowPackages pkgs0_unique ipid_selected - ignored = ignorePackages ignore_flags pkgs0 + 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 @@ -679,8 +708,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" @@ -702,12 +731,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 @@ -808,9 +837,9 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) -- the name of a shared library is libHSfoo-ghc.so -- we leave out the _dyn, because it is superfluous - -- debug RTS includes support for -ticky and -eventlog + -- debug RTS includes support for -eventlog ways2 | WayDebug `elem` map wayName ways1 - = filter ((`notElem` [WayTicky,WayEventLog]) . wayName) ways1 + = filter ((/= WayEventLog) . wayName) ways1 | otherwise = ways1 @@ -873,7 +902,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) @@ -884,14 +913,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] @@ -907,7 +936,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) @@ -927,6 +956,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