Library names, with Cabal submodule update

A library name is a package name, package version, and hash of the
version names of all textual dependencies (i.e. packages which were included.) A library
name is a coarse approximation of installed package IDs, which are suitable for
inclusion in package keys (you don't want to put an IPID in a package key, since
it means the key will change any time the source changes.)

    - We define ShPackageKey, which is the semantic object which
      is hashed into a PackageKey.  You can use 'newPackageKey'
      to hash a ShPackageKey to a PackageKey

    - Given a PackageKey, we can lookup its ShPackageKey with
      'lookupPackageKey'.  The way we can do this is by consulting
      the 'pkgKeyCache', which records a reverse mapping from
      every hash to the ShPackageKey.  This means that if you
      load in PackageKeys from external sources (e.g. interface
      files), you also need to load in a mapping of PackageKeys
      to their ShPackageKeys so we can populate the cache.

    - We define a 'LibraryName' which encapsulates the full
      depenency resolution that Cabal may have selected; this
      is opaque to GHC but can be used to distinguish different
      versions of a package.

    - Definite packages don't have an interesting PackageKey,
      so we rely on Cabal to pass them to us.

    - We can pretty-print package keys while displaying the
      instantiation, but it's not wired up to anything (e.g.
      the Outputable instance of PackageKey).

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

Test Plan: validate

Reviewers: austin, bgamari

Subscribers: thomie

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

GHC Trac Issues: #10566

3 files changed, 67 insertions, 4 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ad604c8cfc..74e9bf303d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -100,6 +100,10 @@ module DynFlags (
         parseDynamicFilePragma,
         parseDynamicFlagsFull,
 
+        -- ** Package key cache
+        PackageKeyCache,
+        ShPackageKey(..),
+
         -- ** Available DynFlags
         allFlags,
         flagsAll,
@@ -177,6 +181,8 @@ import Foreign.C        ( CInt(..) )
 import System.IO.Unsafe ( unsafeDupablePerformIO )
 #endif
 import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
+import UniqFM
+import UniqSet
 
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.IORef
@@ -654,6 +660,29 @@ type SigOf = Map ModuleName Module
 getSigOf :: DynFlags -> ModuleName -> Maybe Module
 getSigOf dflags n = Map.lookup n (sigOf dflags)
 
+-- NameCache updNameCache
+type PackageKeyEnv = UniqFM
+type PackageKeyCache = PackageKeyEnv ShPackageKey
+
+-- | An elaborated representation of a 'PackageKey', which records
+-- all of the components that go into the hashed 'PackageKey'.
+data ShPackageKey
+    = ShPackageKey {
+          shPackageKeyUnitName          :: !UnitName,
+          shPackageKeyLibraryName       :: !LibraryName,
+          shPackageKeyInsts             :: ![(ModuleName, Module)],
+          shPackageKeyFreeHoles         :: UniqSet ModuleName
+      }
+    | ShDefinitePackageKey {
+          shPackageKey :: !PackageKey
+      }
+    deriving Eq
+
+instance Outputable ShPackageKey where
+    ppr (ShPackageKey pn vh insts fh)
+        = ppr pn <+> ppr vh <+> ppr insts <+> parens (ppr fh)
+    ppr (ShDefinitePackageKey pk) = ppr pk
+
 -- | Contains not only a collection of 'GeneralFlag's but also a plethora of
 -- information relating to the compilation of a single file or GHC session
 data DynFlags = DynFlags {
@@ -698,7 +727,10 @@ data DynFlags = DynFlags {
   solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver
                                          --   Typically only 1 is needed
 
-  thisPackage           :: PackageKey,   -- ^ name of package currently being compiled
+  thisPackage           :: PackageKey,   -- ^ key of package currently being compiled
+  thisLibraryName       :: LibraryName,
+                            -- ^ the version hash which identifies the textual
+                            --   package being compiled.
 
   -- ways
   ways                  :: [Way],       -- ^ Way flags from the command line
@@ -785,6 +817,7 @@ data DynFlags = DynFlags {
   -- Packages.initPackages
   pkgDatabase           :: Maybe [PackageConfig],
   pkgState              :: PackageState,
+  pkgKeyCache           :: {-# UNPACK #-} !(IORef PackageKeyCache),
 
   -- Temporary files
   -- These have to be IORefs, because the defaultCleanupHandler needs to
@@ -1437,6 +1470,7 @@ defaultDynFlags mySettings =
         solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,
 
         thisPackage             = mainPackageKey,
+        thisLibraryName         = LibraryName nilFS,
 
         objectDir               = Nothing,
         dylibInstallName        = Nothing,
@@ -1482,6 +1516,7 @@ defaultDynFlags mySettings =
         pkgDatabase             = Nothing,
         -- This gets filled in with GHC.setSessionDynFlags
         pkgState                = emptyPackageState,
+        pkgKeyCache             = v_unsafePkgKeyCache,
         ways                    = defaultWays mySettings,
         buildTag                = mkBuildTag (defaultWays mySettings),
         rtsBuildTag             = mkBuildTag (defaultWays mySettings),
@@ -2730,6 +2765,7 @@ package_flags = [
                                       upd (setPackageKey name)
                                       deprecate "Use -this-package-key instead")
   , defGhcFlag "this-package-key"   (hasArg setPackageKey)
+  , defGhcFlag "library-name"       (hasArg setLibraryName)
   , defFlag "package-id"            (HasArg exposePackageId)
   , defFlag "package"               (HasArg exposePackage)
   , defFlag "package-key"           (HasArg exposePackageKey)
@@ -3725,6 +3761,9 @@ exposePackage' p dflags
 setPackageKey :: String -> DynFlags -> DynFlags
 setPackageKey p s =  s{ thisPackage = stringToPackageKey p }
 
+setLibraryName :: String -> DynFlags -> DynFlags
+setLibraryName v s = s{ thisLibraryName = LibraryName (mkFastString v) }
+
 -- -----------------------------------------------------------------------------
 -- | Find the package environment (if one exists)
 --
@@ -4179,6 +4218,8 @@ unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags
 setUnsafeGlobalDynFlags :: DynFlags -> IO ()
 setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags
 
+GLOBAL_VAR(v_unsafePkgKeyCache, emptyUFM, PackageKeyCache)
+
 -- -----------------------------------------------------------------------------
 -- SSE and AVX
 
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 3c41151c11..71a84d8622 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -12,13 +12,18 @@ module PackageConfig (
         -- * PackageKey
         packageConfigId,
 
+        -- * LibraryName
+        LibraryName(..),
+
         -- * The PackageConfig type: information about a package
         PackageConfig,
         InstalledPackageInfo(..),
         InstalledPackageId(..),
         SourcePackageId(..),
         PackageName(..),
+        UnitName(..),
         Version(..),
+        packageUnitName,
         defaultPackageConfig,
         installedPackageIdString,
         sourcePackageIdString,
@@ -54,6 +59,8 @@ type PackageConfig = InstalledPackageInfo
 newtype InstalledPackageId = InstalledPackageId FastString deriving (Eq, Ord)
 newtype SourcePackageId    = SourcePackageId    FastString deriving (Eq, Ord)
 newtype PackageName        = PackageName        FastString deriving (Eq, Ord)
+newtype UnitName           = UnitName           FastString deriving (Eq, Ord)
+newtype LibraryName        = LibraryName        FastString deriving (Eq, Ord)
 
 instance BinaryStringRep InstalledPackageId where
   fromStringRep = InstalledPackageId . mkFastStringByteString
@@ -67,6 +74,10 @@ instance BinaryStringRep PackageName where
   fromStringRep = PackageName . mkFastStringByteString
   toStringRep (PackageName s) = fastStringToByteString s
 
+instance BinaryStringRep LibraryName where
+  fromStringRep = LibraryName . mkFastStringByteString
+  toStringRep (LibraryName s) = fastStringToByteString s
+
 instance Uniquable InstalledPackageId where
   getUnique (InstalledPackageId n) = getUnique n
 
@@ -79,6 +90,12 @@ instance Uniquable PackageName where
 instance Outputable InstalledPackageId where
   ppr (InstalledPackageId str) = ftext str
 
+instance Outputable UnitName where
+  ppr (UnitName str) = ftext str
+
+instance Outputable LibraryName where
+  ppr (LibraryName str) = ftext str
+
 instance Outputable SourcePackageId where
   ppr (SourcePackageId str) = ftext str
 
@@ -172,3 +189,6 @@ pprPackageConfig InstalledPackageInfo {..} =
 packageConfigId :: PackageConfig -> PackageKey
 packageConfigId = packageKey
 
+packageUnitName :: PackageConfig -> UnitName
+packageUnitName pkg = let PackageName fs = packageName pkg
+                      in UnitName fs
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 16ee352243..20822476cd 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -363,7 +363,7 @@ initPackages dflags = do
                 Nothing -> readPackageConfigs dflags
                 Just db -> return $ setBatchPackageFlags dflags db
   (pkg_state, preload, this_pkg)
-        <- mkPackageState dflags pkg_db [] (thisPackage dflags)
+        <- mkPackageState dflags pkg_db []
   return (dflags{ pkgDatabase = Just pkg_db,
                   pkgState = pkg_state,
                   thisPackage = this_pkg },
@@ -885,15 +885,17 @@ mkPackageState
     :: DynFlags
     -> [PackageConfig]          -- initial database
     -> [PackageKey]              -- preloaded packages
-    -> PackageKey                -- this package
     -> IO (PackageState,
            [PackageKey],         -- new packages to preload
            PackageKey) -- this package, might be modified if the current
                       -- package is a wired-in package.
 
-mkPackageState dflags0 pkgs0 preload0 this_package = do
+mkPackageState dflags0 pkgs0 preload0 = do
   dflags <- interpretPackageEnv dflags0
 
+  -- Compute the package key
+  let this_package = thisPackage dflags
+
 {-
    Plan.