Update Cabal to HEAD, IPID renamed to Component ID.

This commit contains a Cabal submodule update which unifies installed
package IDs and package keys under a single notion, a Component ID.
We update GHC to keep follow this unification.  However, this commit
does NOT rename installed package ID to component ID and package key to
unit ID; the plan is to do that in a companion commit.

    - Compiler info now has "Requires unified installed package IDs"

    - 'exposed' is now expected to contain unit keys, not IPIDs.

    - Shadowing is no more.  We now just have a very simple strategy
      to deal with duplicate unit keys in combined package databases:
      if their ABIs are the same, use the latest one; otherwise error.
      Package databases maintain the invariant that there can only
      be one entry of a unit ID.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, bgamari, hvr, goldfire

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1184

GHC Trac Issues: #10714

1 files changed, 90 insertions, 170 deletions

diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index bb0aba241e..3b9526129f 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -18,7 +18,6 @@ module Packages (
 
         -- * Querying the package config
         lookupPackage,
-        resolveInstalledPackageId,
         searchPackageId,
         getPackageDetails,
         listVisibleModuleNames,
@@ -249,24 +248,17 @@ data PackageState = PackageState {
   -- | This is a full map from 'ModuleName' to all modules which may possibly
   -- be providing it.  These providers may be hidden (but we'll still want
   -- to report them in error messages), or it may be an ambiguous import.
-  moduleToPkgConfAll    :: ModuleToPkgConfAll,
-
-  -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
-  -- internally deals in package keys but the database may refer to installed
-  -- package IDs.
-  installedPackageIdMap :: InstalledPackageIdMap
+  moduleToPkgConfAll    :: ModuleToPkgConfAll
   }
 
 emptyPackageState :: PackageState
 emptyPackageState = PackageState {
     pkgIdMap = emptyUFM,
     preloadPackages = [],
-    moduleToPkgConfAll = Map.empty,
-    installedPackageIdMap = Map.empty
+    moduleToPkgConfAll = Map.empty
     }
 
-type InstalledPackageIdMap = Map InstalledPackageId PackageKey
-type InstalledPackageIndex = Map InstalledPackageId PackageConfig
+type InstalledPackageIndex = Map PackageKey PackageConfig
 
 -- | Empty package configuration map
 emptyPackageConfigMap :: PackageConfigMap
@@ -304,12 +296,6 @@ getPackageDetails dflags pid =
 listPackageConfigMap :: DynFlags -> [PackageConfig]
 listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))
 
--- | Looks up a 'PackageKey' given an 'InstalledPackageId'
-resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey
-resolveInstalledPackageId dflags ipid =
-    expectJust "resolveInstalledPackageId"
-        (Map.lookup ipid (installedPackageIdMap (pkgState dflags)))
-
 -- ----------------------------------------------------------------------------
 -- Loading the package db files and building up the package state
 
@@ -602,7 +588,7 @@ packageFlagErr dflags flag reasons
                       text "(use -v for more information)")
         ppr_reasons = vcat (map ppr_reason reasons)
         ppr_reason (p, reason) =
-            pprReason (ppr (installedPackageId p) <+> text "is") reason
+            pprReason (ppr (packageKey p) <+> text "is") reason
 
 pprFlag :: PackageFlag -> SDoc
 pprFlag flag = case flag of
@@ -628,11 +614,13 @@ pprFlag flag = case flag of
 wired_in_pkgids :: [String]
 wired_in_pkgids = map packageKeyString wiredInPackageKeys
 
+type WiredPackagesMap = Map PackageKey PackageKey
+
 findWiredInPackages
    :: DynFlags
    -> [PackageConfig]           -- database
    -> VisibilityMap             -- info on what packages are visible
-   -> IO ([PackageConfig], VisibilityMap)
+   -> IO ([PackageConfig], VisibilityMap, WiredPackagesMap)
 
 findWiredInPackages dflags pkgs vis_map = do
   --
@@ -686,14 +674,14 @@ findWiredInPackages dflags pkgs vis_map = do
                             ptext (sLit "wired-in package ")
                                  <> text wired_pkg
                                  <> ptext (sLit " mapped to ")
-                                 <> ppr (installedPackageId pkg)
+                                 <> ppr (packageKey pkg)
                         return (Just pkg)
 
 
   mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
   let
         wired_in_pkgs = catMaybes mb_wired_in_pkgs
-        wired_in_ids = map installedPackageId wired_in_pkgs
+        wired_in_ids = map packageKey wired_in_pkgs
 
         -- this is old: we used to assume that if there were
         -- multiple versions of wired-in packages installed that
@@ -708,14 +696,28 @@ findWiredInPackages dflags pkgs vis_map = do
                       && package p `notElem` map fst wired_in_ids
         -}
 
-        updateWiredInDependencies pkgs = map upd_pkg pkgs
+        wiredInMap :: Map PackageKey PackageKey
+        wiredInMap = foldl' add_mapping Map.empty pkgs
+          where add_mapping m pkg
+                  | let key = packageKey pkg
+                  , key `elem` wired_in_ids
+                  = Map.insert key (stringToPackageKey (packageNameString pkg)) m
+                  | otherwise = m
+
+        updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
           where upd_pkg pkg
-                  | installedPackageId pkg `elem` wired_in_ids
+                  | packageKey pkg `elem` wired_in_ids
                   = pkg {
                       packageKey = stringToPackageKey (packageNameString pkg)
                     }
                   | otherwise
                   = pkg
+                upd_deps pkg = pkg {
+                      depends = map upd_wired_in (depends pkg)
+                    }
+                upd_wired_in key
+                    | Just key' <- Map.lookup key wiredInMap = key'
+                    | otherwise = key
 
         updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
           where f vm p = case lookupUFM vis_map (packageConfigId p) of
@@ -724,16 +726,15 @@ findWiredInPackages dflags pkgs vis_map = do
                                                     (packageNameString p)) r
 
 
-  return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map)
+  return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map, wiredInMap)
 
 -- ----------------------------------------------------------------------------
 
 data UnusablePackageReason
   = IgnoredWithFlag
-  | MissingDependencies [InstalledPackageId]
-  | ShadowedBy InstalledPackageId
+  | MissingDependencies [PackageKey]
 
-type UnusablePackages = Map InstalledPackageId
+type UnusablePackages = Map PackageKey
                             (PackageConfig, UnusablePackageReason)
 
 pprReason :: SDoc -> UnusablePackageReason -> SDoc
@@ -744,8 +745,6 @@ pprReason pref reason = case reason of
       pref <+>
       ptext (sLit "unusable due to missing or recursive dependencies:") $$
         nest 2 (hsep (map ppr deps))
-  ShadowedBy ipid ->
-      pref <+> ptext (sLit "shadowed by package ") <> ppr ipid
 
 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
@@ -770,62 +769,31 @@ findBroken pkgs = go [] Map.empty pkgs
    go avail ipids not_avail =
      case partitionWith (depsAvailable ipids) not_avail of
         ([], not_avail) ->
-            Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))
+            Map.fromList [ (packageKey p, (p, MissingDependencies deps))
                          | (p,deps) <- not_avail ]
         (new_avail, not_avail) ->
             go (new_avail ++ avail) new_ipids (map fst not_avail)
             where new_ipids = Map.insertList
-                                [ (installedPackageId p, p) | p <- new_avail ]
+                                [ (packageKey p, p) | p <- new_avail ]
                                 ipids
 
    depsAvailable :: InstalledPackageIndex
                  -> PackageConfig
-                 -> Either PackageConfig (PackageConfig, [InstalledPackageId])
+                 -> Either PackageConfig (PackageConfig, [PackageKey])
    depsAvailable ipids pkg
         | null dangling = Left pkg
         | otherwise     = Right (pkg, dangling)
         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.  Additionally, a package may be preferred if
--- it is in the transitive closure of packages selected using -package-id
--- flags.
-type UnusablePackage = (PackageConfig, UnusablePackageReason)
-shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
-shadowPackages pkgs preferred
- = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
-   in  Map.fromList shadowed
- where
- check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
-       -> PackageConfig
-       -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
- check (shadowed,pkgmap) pkg
-      | Just oldpkg <- lookupUFM pkgmap pkgid
-      , let
-            ipid_new = installedPackageId pkg
-            ipid_old = installedPackageId oldpkg
-        --
-      , ipid_old /= ipid_new
-      = if ipid_old `elem` preferred
-           then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
-           else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
-      | otherwise
-      = (shadowed, pkgmap')
-      where
-        pkgid = packageKeyFS (packageKey pkg)
-        pkgmap' = addToUFM pkgmap pkgid pkg
-
--- -----------------------------------------------------------------------------
+-- Ignore packages
 
 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
   where
   doit (IgnorePackage str) =
      case partition (matchingStr str) pkgs of
-         (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
+         (ps, _) -> [ (packageKey p, (p, IgnoredWithFlag))
                     | p <- ps ]
         -- missing package is not an error for -ignore-package,
         -- because a common usage is to -ignore-package P as
@@ -833,20 +801,6 @@ ignorePackages flags pkgs = Map.fromList (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.
 
@@ -868,80 +822,66 @@ mkPackageState dflags0 pkgs0 preload0 = do
 {-
    Plan.
 
-   1. P = transitive closure of packages selected by -package-id
-
-   2. Apply shadowing.  When there are multiple packages with the same
-      packageKey,
-        * 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 packageKey
-       in the same program, because packageKey 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
+   1. When there are multiple packages with the same
+      installed package ID, if they have the same ABI hash, use the one
+      highest in the package stack.  Otherwise, error.
+
+   2. remove packages selected by -ignore-package
+
+   3. remove any packages with missing dependencies, or mutually recursive
       dependencies.
 
-   5. report (with -v) any packages that were removed by steps 2-4
+   4. report (with -v) any packages that were removed by steps 2-4
 
-   6. apply flags to set exposed/hidden on the resulting packages
+   5. 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
+   6. hide any packages which are superseded by later exposed packages
 -}
 
   let
-      flags = reverse (packageFlags dflags)
-
       -- 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.
+      -- DB to have the same key as a package in the user DB, and
+      -- we want the latter to take precedence.
       --
-      -- #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 (mkFastString i)
-                                 | ExposePackage (PackageIdArg i) _ <- flags ]
-
+      -- NB: We have to check that the ABIs of the old and new packages
+      -- are equal; if they are not that's a fatal error.
+      --
+      -- TODO: might be useful to report when this shadowing occurs
+      (_, pkgs0_unique, abis) = foldr del (Set.empty,[],Map.empty) pkgs0
+          where del p (s,ps,a)
+                  | key `Set.member` s = (s,ps,a')
+                  | otherwise          = (Set.insert key s, p:ps, a')
+                  where key = packageKey p
+                        a' = Map.insertWith Set.union key
+                                            (Set.singleton (abiHash p)) a
+      failed_abis = [ (key, Set.toList as)
+                    | (key, as) <- Map.toList abis
+                    , Set.size as > 1 ]
+
+  unless (null failed_abis) $ do
+    throwGhcException (CmdLineError (showSDoc dflags
+        (text "package db: duplicate packages with incompatible ABIs:" $$
+         nest 4 (vcat [ ppr key <+> text "has ABIs" <> colon <+>
+                        hsep (punctuate comma (map text as))
+                      | (key, as) <- failed_abis]))))
+
+  let flags = reverse (packageFlags dflags)
       (ignore_flags, other_flags) = partition is_ignore flags
       is_ignore IgnorePackage{} = True
       is_ignore _ = False
 
-      shadowed = shadowPackages pkgs0_unique ipid_selected
       ignored  = ignorePackages ignore_flags pkgs0_unique
 
-      isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId
+      isBroken = (`Map.member` ignored).packageKey
       pkgs0' = filter (not . isBroken) pkgs0_unique
 
       broken   = findBroken pkgs0'
 
-      unusable = shadowed `Map.union` ignored `Map.union` broken
-      pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0'
+      unusable = ignored `Map.union` broken
+      pkgs1 = filter (not . (`Map.member` unusable) . packageKey) pkgs0'
 
   reportUnusable dflags unusable
 
@@ -980,7 +920,7 @@ mkPackageState dflags0 pkgs0 preload0 = do
   -- package arguments we need to key against the old versions.  We also
   -- have to update the visibility map in the process.
   --
-  (pkgs3, vis_map) <- findWiredInPackages dflags pkgs2 vis_map2
+  (pkgs3, vis_map, wired_map) <- findWiredInPackages dflags pkgs2 vis_map2
 
   --
   -- Here we build up a set of the packages mentioned in -package
@@ -989,7 +929,9 @@ mkPackageState dflags0 pkgs0 preload0 = do
   -- should contain at least rts & base, which is why we pretend that
   -- the command line contains -package rts & -package base.
   --
-  let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
+  let preload1 = [ let key = packageKey p
+                   in fromMaybe key (Map.lookup key wired_map)
+                 | f <- flags, p <- get_exposed f ]
 
       get_exposed (ExposePackage a _) = take 1 . sortByVersion
                                       . filter (matching a)
@@ -998,14 +940,7 @@ mkPackageState dflags0 pkgs0 preload0 = do
 
   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
 
-      ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
-                              | p <- pkgs3 ]
-
-      lookupIPID ipid
-         | Just pid <- Map.lookup ipid ipid_map = return pid
-         | otherwise                            = missingPackageErr dflags ipid
-
-  preload2 <- mapM lookupIPID preload1
+  let preload2 = preload1
 
   let
       -- add base & rts to the preload packages
@@ -1021,14 +956,13 @@ mkPackageState dflags0 pkgs0 preload0 = do
                      $ (basicLinkedPackages ++ preload2)
 
   -- Close the preload packages with their dependencies
-  dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
+  dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
   let pstate = PackageState{
     preloadPackages     = dep_preload,
     pkgIdMap            = pkg_db,
-    moduleToPkgConfAll  = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
-    installedPackageIdMap = ipid_map
+    moduleToPkgConfAll  = mkModuleToPkgConfAll dflags pkg_db vis_map
     }
   return (pstate, new_dep_preload, this_package)
 
@@ -1039,10 +973,9 @@ mkPackageState dflags0 pkgs0 preload0 = do
 mkModuleToPkgConfAll
   :: DynFlags
   -> PackageConfigMap
-  -> InstalledPackageIdMap
   -> VisibilityMap
   -> ModuleToPkgConfAll
-mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
+mkModuleToPkgConfAll dflags pkg_db vis_map =
     foldl' extend_modmap emptyMap (eltsUFM pkg_db)
  where
   emptyMap = Map.empty
@@ -1078,9 +1011,8 @@ mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
      let (pk', m', pkg', origin') =
           case exposedReexport of
            Nothing -> (pk, m, pkg, fromExposedModules e)
-           Just (OriginalModule ipid' m') ->
-            let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
-                pkg' = pkg_lookup pk'
+           Just (OriginalModule pk' m') ->
+            let pkg' = pkg_lookup pk'
             in (pk', m', pkg', fromReexportedModules e pkg')
      return (m, sing pk' m' pkg' origin')
 
@@ -1298,22 +1230,20 @@ getPreloadPackagesAnd dflags pkgids =
   let
       state   = pkgState dflags
       pkg_map = pkgIdMap state
-      ipid_map = installedPackageIdMap state
       preload = preloadPackages state
       pairs = zip pkgids (repeat Nothing)
   in do
-  all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
+  all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs)
   return (map (getPackageDetails dflags) all_pkgs)
 
 -- 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 :: DynFlags
           -> PackageConfigMap
-          -> Map InstalledPackageId PackageKey
           -> [(PackageKey, Maybe PackageKey)]
           -> IO [PackageKey]
-closeDeps dflags pkg_map ipid_map ps
-    = throwErr dflags (closeDepsErr pkg_map ipid_map ps)
+closeDeps dflags pkg_map ps
+    = throwErr dflags (closeDepsErr pkg_map ps)
 
 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
 throwErr dflags m
@@ -1322,18 +1252,16 @@ throwErr dflags m
                 Succeeded r -> return r
 
 closeDepsErr :: PackageConfigMap
-             -> Map InstalledPackageId PackageKey
              -> [(PackageKey,Maybe PackageKey)]
              -> MaybeErr MsgDoc [PackageKey]
-closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
+closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
 
 -- internal helper
 add_package :: PackageConfigMap
-            -> Map InstalledPackageId PackageKey
             -> [PackageKey]
             -> (PackageKey,Maybe PackageKey)
             -> MaybeErr MsgDoc [PackageKey]
-add_package pkg_db ipid_map ps (p, mb_parent)
+add_package pkg_db ps (p, mb_parent)
   | p `elem` ps = return ps     -- Check if we've already added this package
   | otherwise =
       case lookupPackage' pkg_db p of
@@ -1341,19 +1269,11 @@ add_package pkg_db ipid_map ps (p, mb_parent)
                            missingDependencyMsg mb_parent)
         Just pkg -> do
            -- Add the package's dependents also
-           ps' <- foldM add_package_ipid ps (depends pkg)
+           ps' <- foldM add_unit_key ps (depends pkg)
            return (p : ps')
           where
-            add_package_ipid ps ipid
-              | Just pid <- Map.lookup ipid ipid_map
-              = add_package pkg_db ipid_map ps (pid, Just p)
-              | otherwise
-              = Failed (missingPackageMsg ipid
-                          <> missingDependencyMsg mb_parent)
-
-missingPackageErr :: Outputable pkgid => DynFlags -> pkgid -> IO a
-missingPackageErr dflags p
-    = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
+            add_unit_key ps key
+              = add_package pkg_db ps (key, Just p)
 
 missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
 missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p
@@ -1420,7 +1340,7 @@ pprPackagesWith pprIPI dflags =
 -- be different from the package databases (exposure, trust)
 pprPackagesSimple :: DynFlags -> SDoc
 pprPackagesSimple = pprPackagesWith pprIPI
-    where pprIPI ipi = let InstalledPackageId i = installedPackageId ipi
+    where pprIPI ipi = let i = packageKeyFS (packageKey ipi)
                            e = if exposed ipi then text "E" else text " "
                            t = if trusted ipi then text "T" else text " "
                        in e <> t <> text "  " <> ftext i