Make InstalledUnitId be ONLY a FastString.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Thu, 6 Oct 2016 20:40:10 +0000 (13:40 -0700)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 8 Oct 2016 08:37:56 +0000 (01:37 -0700)
It turns out that we don't really need to be able to
extract a ComponentId from UnitId, except in one case.
So compress UnitId into a single FastString.

The one case where we do need the ComponentId is when
we are compiling an instantiated version of a package;
we need the ComponentId to look up the indefinite
version of this package from the database.  So now we
just pass it in as an argument -this-component-id.

Also: ghc-pkg now no longer will unregister a package if
you register one with the same package name, if the
instantiations don't match.

Cabal submodule update which tracks the same data type
change.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
15 files changed:
compiler/backpack/DriverBkp.hs
compiler/basicTypes/Module.hs
compiler/basicTypes/Module.hs-boot
compiler/iface/LoadIface.hs
compiler/main/DynFlags.hs
compiler/main/Finder.hs
compiler/main/GhcMake.hs
compiler/main/HscTypes.hs
compiler/main/PackageConfig.hs
compiler/main/Packages.hs
compiler/main/Packages.hs-boot
compiler/typecheck/TcBackpack.hs
libraries/Cabal
libraries/ghc-boot/GHC/PackageDb.hs
utils/ghc-pkg/Main.hs

index 53a7e85..7b35b0c 100644 (file)
@@ -155,13 +155,14 @@ withBkpSession cid insts deps session_type do_this = do
         hscTarget   = case session_type of
                         TcSession -> HscNothing
                         _ -> hscTarget dflags,
-        thisUnitIdInsts = insts,
-        thisPackage =
+        thisUnitIdInsts_ = Just insts,
+        thisComponentId_ = Just cid,
+        thisInstalledUnitId =
             case session_type of
-                TcSession -> newUnitId cid insts
+                TcSession -> newInstalledUnitId cid Nothing
                 -- No hash passed if no instances
-                _ | null insts -> newSimpleUnitId cid
-                  | otherwise  -> newDefiniteUnitId cid (Just (hashUnitId cid insts)),
+                _ | null insts -> newInstalledUnitId cid Nothing
+                  | otherwise  -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
         -- Setup all of the output directories according to our hierarchy
         objectDir   = Just (outdir objectDir),
         hiDir       = Just (outdir hiDir),
@@ -186,7 +187,7 @@ withBkpSession cid insts deps session_type do_this = do
 
 withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
 withBkpExeSession deps do_this = do
-    withBkpSession (unitIdComponentId mainUnitId) [] deps ExeSession do_this
+    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
 
 getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
 getSource cid = do
@@ -282,6 +283,7 @@ buildUnit session cid insts lunit = do
             packageName = compat_pn,
             packageVersion = makeVersion [0],
             unitId = toInstalledUnitId (thisPackage dflags),
+            componentId = cid,
             instantiatedWith = insts,
             -- Slight inefficiency here haha
             exposedModules = map (\(m,n) -> (m,Just n)) mods,
@@ -366,8 +368,9 @@ compileInclude n (i, uid) = do
     case lookupPackage dflags uid of
         Nothing -> do
             case splitUnitIdInsts uid of
-                (_, Just insts) ->
-                    innerBkpM $ compileUnit (unitIdComponentId uid) insts
+                (_, Just indef) ->
+                    innerBkpM $ compileUnit (indefUnitIdComponentId indef)
+                                            (indefUnitIdInsts indef)
                 _ -> return ()
         Just _ -> return ()
 
@@ -778,3 +781,11 @@ hsModuleToModSummary pn hsc_src modname
             ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
             ms_iface_date = hi_timestamp
         }
+
+-- | Create a new, externally provided hashed unit id from
+-- a hash.
+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
+newInstalledUnitId (ComponentId cid_fs) (Just fs)
+    = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
+newInstalledUnitId (ComponentId cid_fs) Nothing
+    = InstalledUnitId cid_fs
index fd12c2b..98c30a9 100644 (file)
@@ -11,7 +11,6 @@ the keys.
 
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Module
     (
@@ -33,8 +32,8 @@ module Module
         UnitId(..),
         unitIdFS,
         unitIdKey,
-        unitIdComponentId,
         IndefUnitId(..),
+        IndefModule(..),
         InstalledUnitId(..),
         toInstalledUnitId,
         ShHoleSubst,
@@ -46,7 +45,6 @@ module Module
         newUnitId,
         newIndefUnitId,
         newSimpleUnitId,
-        newDefiniteUnitId,
         hashUnitId,
         fsToUnitId,
         stringToUnitId,
@@ -101,8 +99,8 @@ module Module
         installedModuleEq,
         installedUnitIdEq,
         installedUnitIdString,
-        newInstalledUnitId,
         fsToInstalledUnitId,
+        componentIdToInstalledUnitId,
         stringToInstalledUnitId,
         emptyInstalledModuleEnv,
         lookupInstalledModuleEnv,
@@ -111,9 +109,6 @@ module Module
         delInstalledModuleEnv,
         DefUnitId(..),
 
-        -- * Hole module
-        HoleModule,
-
         -- * The ModuleLocation type
         ModLocation(..),
         addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
@@ -172,7 +167,7 @@ import qualified FiniteMap as Map
 import System.FilePath
 
 import {-# SOURCE #-} DynFlags (DynFlags)
-import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap)
+import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId)
 
 -- Note [The identifier lexicon]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -482,13 +477,11 @@ class ContainsModule t where
 class HasModule m where
     getModule :: m Module
 
-instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where
-  fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
-  fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name
-  fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts })
-    = newUnitId cid insts
-  fromDbUnitId (DbInstalledUnitId cid hash) -- TODO rename this
-    = newDefiniteUnitId cid (fmap mkFastStringByteString hash)
+instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where
+  fromDbModule (DbModule uid mod_name)  = mkModule uid mod_name
+  fromDbModule (DbModuleVar mod_name)   = mkHoleModule mod_name
+  fromDbUnitId (DbUnitId cid insts)     = newUnitId cid insts
+  fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)
   -- GHC never writes to the database, so it's not needed
   toDbModule = error "toDbModule: not implemented"
   toDbUnitId = error "toDbUnitId: not implemented"
@@ -560,10 +553,6 @@ unitIdKey :: UnitId -> Unique
 unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x
 unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x
 
-unitIdComponentId :: UnitId -> ComponentId
-unitIdComponentId (IndefiniteUnitId x) = indefUnitIdComponentId x
-unitIdComponentId (DefiniteUnitId (DefUnitId x)) = installedUnitIdComponentId x
-
 -- | A unit identifier which identifies an indefinite
 -- library (with holes) that has been *on-the-fly* instantiated
 -- with a substitution 'indefUnitIdInsts'.  In fact, an indefinite
@@ -600,6 +589,45 @@ instance Eq IndefUnitId where
 instance Ord IndefUnitId where
   u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2
 
+instance Binary IndefUnitId where
+  put_ bh indef = do
+    put_ bh (indefUnitIdComponentId indef)
+    put_ bh (indefUnitIdInsts indef)
+  get bh = do
+    cid   <- get bh
+    insts <- get bh
+    let fs = hashUnitId cid insts
+    return IndefUnitId {
+            indefUnitIdComponentId = cid,
+            indefUnitIdInsts = insts,
+            indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+            indefUnitIdFS = fs,
+            indefUnitIdKey = getUnique fs
+           }
+
+-- | Create a new 'IndefUnitId' given an explicit module substitution.
+newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
+newIndefUnitId cid insts =
+    IndefUnitId {
+        indefUnitIdComponentId = cid,
+        indefUnitIdInsts = sorted_insts,
+        indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+        indefUnitIdFS = fs,
+        indefUnitIdKey = getUnique fs
+    }
+  where
+     fs = hashUnitId cid sorted_insts
+     sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
+
+data IndefModule = IndefModule {
+        indefModuleUnitId :: IndefUnitId,
+        indefModuleName   :: ModuleName
+    } deriving (Typeable, Eq, Ord)
+
+instance Outputable IndefModule where
+  ppr (IndefModule uid m) =
+    ppr uid <> char ':' <> ppr m
+
 -- | An installed unit identifier identifies a library which has
 -- been installed to the package database.  These strings are
 -- provided to us via the @-this-unit-id@ flag.  The library
@@ -610,47 +638,20 @@ instance Ord IndefUnitId where
 --
 -- Installed unit identifiers look something like @p+af23SAj2dZ219@,
 -- or maybe just @p@ if they don't use Backpack.
-data InstalledUnitId =
+newtype InstalledUnitId =
     InstalledUnitId {
       -- | The full hashed unit identifier, including the component id
       -- and the hash.
-      installedUnitIdFS :: FastString,
-      -- | Cached unique of 'unitIdFS'.
-      installedUnitIdKey :: Unique,
-      -- | The component identifier of the hashed unit identifier.
-      installedUnitIdComponentId :: !ComponentId
+      installedUnitIdFS :: FastString
     }
    deriving (Typeable)
 
--- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that
--- it only refers to a definite library; i.e., one we have generated
--- code for.
-newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
-    deriving (Eq, Ord, Outputable, Typeable)
-
 instance Binary InstalledUnitId where
-  put_ bh uid
-    | cid == ComponentId fs = do
-        putByte bh 0
-        put_ bh fs
-    | otherwise = do
-        putByte bh 2
-        put_ bh cid
-        put_ bh fs
-   where
-    cid = installedUnitIdComponentId uid
-    fs  = installedUnitIdFS uid
-  get bh = do b <- getByte bh
-              case b of
-                0 -> fmap fsToInstalledUnitId (get bh)
-                _ -> do
-                  cid <- get bh
-                  fs  <- get bh
-                  return (rawNewInstalledUnitId cid fs)
+  put_ bh (InstalledUnitId fs) = put_ bh fs
+  get bh = do fs <- get bh; return (InstalledUnitId fs)
 
 instance BinaryStringRep InstalledUnitId where
-  fromStringRep bs = rawNewInstalledUnitId (fromStringRep cid) (mkFastStringByteString bs)
-    where cid = BS.Char8.takeWhile (/='+') bs
+  fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)
   -- GHC doesn't write to database
   toStringRep   = error "BinaryStringRep InstalledUnitId: not implemented"
 
@@ -664,16 +665,21 @@ instance Uniquable InstalledUnitId where
     getUnique = installedUnitIdKey
 
 instance Outputable InstalledUnitId where
-    ppr uid =
-        if installedUnitIdComponentId uid == ComponentId (installedUnitIdFS uid)
-            then ppr (installedUnitIdComponentId uid)
-            else ftext (installedUnitIdFS uid)
+    ppr uid@(InstalledUnitId fs) =
+        getPprStyle $ \sty ->
+        sdocWithDynFlags $ \dflags ->
+          case displayInstalledUnitId dflags uid of
+            Just str | not (debugStyle sty) -> text str
+            _ -> ftext fs
+
+installedUnitIdKey :: InstalledUnitId -> Unique
+installedUnitIdKey = getUnique . installedUnitIdFS
 
 -- | Lossy conversion to the on-disk 'InstalledUnitId' for a component.
 toInstalledUnitId :: UnitId -> InstalledUnitId
 toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid
 toInstalledUnitId (IndefiniteUnitId indef) =
-    newInstalledUnitId (indefUnitIdComponentId indef) Nothing
+    componentIdToInstalledUnitId (indefUnitIdComponentId indef)
 
 installedUnitIdString :: InstalledUnitId -> String
 installedUnitIdString = unpackFS . installedUnitIdFS
@@ -716,7 +722,10 @@ instance Outputable InstalledModule where
     ppr p <> char ':' <> pprModuleName n
 
 fsToInstalledUnitId :: FastString -> InstalledUnitId
-fsToInstalledUnitId fs = rawNewInstalledUnitId (ComponentId fs) fs
+fsToInstalledUnitId fs = InstalledUnitId fs
+
+componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId
+componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs
 
 stringToInstalledUnitId :: String -> InstalledUnitId
 stringToInstalledUnitId = fsToInstalledUnitId . mkFastString
@@ -733,6 +742,19 @@ installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool
 installedUnitIdEq iuid uid =
     fst (splitUnitIdInsts uid) == iuid
 
+-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that
+-- it only refers to a definite library; i.e., one we have generated
+-- code for.
+newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
+    deriving (Eq, Ord, Typeable)
+
+instance Outputable DefUnitId where
+    ppr (DefUnitId uid) = ppr uid
+
+instance Binary DefUnitId where
+    put_ bh (DefUnitId uid) = put_ bh uid
+    get bh = do uid <- get bh; return (DefUnitId uid)
+
 -- | A map keyed off of 'InstalledModule'
 newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)
 
@@ -752,12 +774,6 @@ filterInstalledModuleEnv f (InstalledModuleEnv e) =
 delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a
 delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)
 
--- | A hole module is a 'Module' representing a required
--- signature that we are going to merge in.  The unit id
--- of such a hole module is guaranteed to be equipped with
--- an instantiation.
-type HoleModule = (IndefUnitId, ModuleName)
-
 -- Note [UnitId to InstalledUnitId improvement]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Just because a UnitId is definite (has no holes) doesn't
@@ -829,52 +845,11 @@ fingerprintUnitId prefix (Fingerprint a b)
       , BS.Char8.pack (toBase62Padded a)
       , BS.Char8.pack (toBase62Padded b) ]
 
--- | Create a new, externally provided hashed unit id from
--- a hash.
-newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
-newInstalledUnitId cid@(ComponentId cid_fs) (Just fs)
-    = rawNewInstalledUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
-newInstalledUnitId cid@(ComponentId cid_fs) Nothing
-    = rawNewInstalledUnitId cid cid_fs
-
-rawNewDefiniteUnitId :: ComponentId -> FastString -> UnitId
-rawNewDefiniteUnitId cid fs =
-    DefiniteUnitId (DefUnitId (rawNewInstalledUnitId cid fs))
-
--- | Create a new 'UnitId' for an instantiated unit id.
-newDefiniteUnitId :: ComponentId -> Maybe FastString -> UnitId
-newDefiniteUnitId cid mb_fs =
-    DefiniteUnitId (DefUnitId (newInstalledUnitId cid mb_fs))
-
--- | Smart constructor for 'InstalledUnitId'; input 'FastString'
--- is assumed to be the FULL identifying string for this
--- UnitId (e.g., it contains the 'ComponentId').
-rawNewInstalledUnitId :: ComponentId -> FastString -> InstalledUnitId
-rawNewInstalledUnitId cid fs = InstalledUnitId {
-        installedUnitIdFS = fs,
-        installedUnitIdKey = getUnique fs,
-        installedUnitIdComponentId = cid
-    }
-
 -- | Create a new, un-hashed unit identifier.
 newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId
 newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug...
 newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts
 
--- | Create a new 'IndefUnitId' given an explicit module substitution.
-newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId
-newIndefUnitId cid insts =
-    IndefUnitId {
-        indefUnitIdComponentId = cid,
-        indefUnitIdInsts = sorted_insts,
-        indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
-        indefUnitIdFS = fs,
-        indefUnitIdKey = getUnique fs
-    }
-  where
-     fs = hashUnitId cid sorted_insts
-     sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
-
 pprUnitId :: UnitId -> SDoc
 pprUnitId (DefiniteUnitId uid) = ppr uid
 pprUnitId (IndefiniteUnitId uid) = ppr uid
@@ -906,35 +881,16 @@ instance Outputable UnitId where
 
 -- Performance: would prefer to have a NameCache like thing
 instance Binary UnitId where
-  put_ bh (DefiniteUnitId (DefUnitId uid))
-    | cid == ComponentId fs = do
-        putByte bh 0
-        put_ bh fs
-    | otherwise = do
-        putByte bh 2
-        put_ bh cid
-        put_ bh fs
-   where
-    cid = installedUnitIdComponentId uid
-    fs  = installedUnitIdFS uid
-  put_ bh (IndefiniteUnitId uid) = do
+  put_ bh (DefiniteUnitId def_uid) = do
+    putByte bh 0
+    put_ bh def_uid
+  put_ bh (IndefiniteUnitId indef_uid) = do
     putByte bh 1
-    put_ bh cid
-    put_ bh insts
-   where
-    cid   = indefUnitIdComponentId uid
-    insts = indefUnitIdInsts uid
+    put_ bh indef_uid
   get bh = do b <- getByte bh
               case b of
-                0 -> fmap fsToUnitId (get bh)
-                1 -> do
-                  cid   <- get bh
-                  insts <- get bh
-                  return (newUnitId cid insts)
-                _ -> do
-                  cid <- get bh
-                  fs  <- get bh
-                  return (rawNewDefiniteUnitId cid fs)
+                0 -> fmap DefiniteUnitId   (get bh)
+                _ -> fmap IndefiniteUnitId (get bh)
 
 instance Binary ComponentId where
   put_ bh (ComponentId fs) = put_ bh fs
@@ -947,7 +903,7 @@ newSimpleUnitId (ComponentId fs) = fsToUnitId fs
 -- | Create a new simple unit identifier from a 'FastString'.  Internally,
 -- this is primarily used to specify wired-in unit identifiers.
 fsToUnitId :: FastString -> UnitId
-fsToUnitId fs = rawNewDefiniteUnitId (ComponentId fs) fs
+fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId
 
 stringToUnitId :: String -> UnitId
 stringToUnitId = fsToUnitId . mkFastString
@@ -1016,15 +972,16 @@ renameHoleUnitId' pkg_map env uid =
 -- a 'Module' that we definitely can find on-disk, as well as an
 -- instantiation if we need to instantiate it on the fly.  If the
 -- instantiation is @Nothing@ no on-the-fly renaming is needed.
-splitModuleInsts :: Module -> (InstalledModule, Maybe [(ModuleName, Module)])
+splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule)
 splitModuleInsts m =
-    let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m)
-    in (InstalledModule uid (moduleName m), mb_insts)
+    let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m)
+    in (InstalledModule uid (moduleName m),
+        fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid)
 
 -- | See 'splitModuleInsts'.
-splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe [(ModuleName, Module)])
+splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId)
 splitUnitIdInsts (IndefiniteUnitId iuid) =
-    (newInstalledUnitId (indefUnitIdComponentId iuid) Nothing, Just (indefUnitIdInsts iuid))
+    (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid)
 splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing)
 
 generalizeIndefUnitId :: IndefUnitId -> IndefUnitId
@@ -1044,10 +1001,8 @@ parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId
         insts <- parseModSubst
         return (newUnitId cid insts)
     parseDefiniteUnitId = do
-        cid <- parseComponentId
-        _ <- Parse.char '+'
-        hash <- Parse.munch1 isAlphaNum
-        return (newDefiniteUnitId cid (Just (mkFastString hash)))
+        s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")
+        return (stringToUnitId s)
     parseSimpleUnitId = do
         cid <- parseComponentId
         return (newSimpleUnitId cid)
index 4cb35ca..734855a 100644 (file)
@@ -4,6 +4,7 @@ import FastString
 data Module
 data ModuleName
 data UnitId
+data InstalledUnitId
 newtype ComponentId = ComponentId FastString
 
 moduleName :: Module -> ModuleName
index ca11c6f..6005ba5 100644 (file)
@@ -533,12 +533,12 @@ computeInterface doc_str hi_boot_file mod0 = do
     MASSERT( not (isHoleModule mod0) )
     dflags <- getDynFlags
     case splitModuleInsts mod0 of
-        (imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do
+        (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do
             r <- findAndReadIface doc_str imod hi_boot_file
             case r of
                 Succeeded (iface0, path) -> do
                     hsc_env <- getTopEnv
-                    r <- liftIO (rnModIface hsc_env insts Nothing iface0)
+                    r <- liftIO (rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) Nothing iface0)
                     return (Succeeded (r, path))
                 Failed err -> return (Failed err)
         (mod, _) ->
@@ -560,7 +560,8 @@ moduleFreeHolesPrecise doc_str mod
  | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
  | otherwise =
    case splitModuleInsts mod of
-    (imod, Just insts) -> do
+    (imod, Just indef) -> do
+        let insts = indefUnitIdInsts (indefModuleUnitId indef)
         traceIf (text "Considering whether to load" <+> ppr mod <+>
                  text "to compute precise free module holes")
         (eps, hpt) <- getEpsAndHpt
index 69fb8b8..cb28664 100644 (file)
@@ -54,11 +54,12 @@ module DynFlags (
         dynFlagDependencies,
         tablesNextToCode, mkTablesNextToCode,
         makeDynFlagsConsistent,
-        thisUnitIdComponentId,
 
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
 
+        thisPackage, thisComponentId, thisUnitIdInsts,
+
         -- ** Safe Haskell
         SafeHaskellMode(..),
         safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
@@ -688,9 +689,9 @@ data DynFlags = DynFlags {
   solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver
                                          --   Typically only 1 is needed
 
-  thisPackage           :: UnitId,   -- ^ unit id of package currently being compiled.
-                                     --   Not properly initialized until initPackages
-  thisUnitIdInsts       :: [(ModuleName, Module)],
+  thisInstalledUnitId   :: InstalledUnitId,
+  thisComponentId_      :: Maybe ComponentId,
+  thisUnitIdInsts_      :: Maybe [(ModuleName, Module)],
 
   -- ways
   ways                  :: [Way],       -- ^ Way flags from the command line
@@ -1487,8 +1488,9 @@ defaultDynFlags mySettings =
         reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,
         solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,
 
-        thisPackage             = mainUnitId,
-        thisUnitIdInsts         = [],
+        thisInstalledUnitId     = toInstalledUnitId mainUnitId,
+        thisUnitIdInsts_        = Nothing,
+        thisComponentId_        = Nothing,
 
         objectDir               = Nothing,
         dylibInstallName        = Nothing,
@@ -2003,6 +2005,34 @@ setOutputFile f d = d { outputFile = f}
 setDynOutputFile f d = d { dynOutputFile = f}
 setOutputHi   f d = d { outputHi   = f}
 
+thisComponentId :: DynFlags -> ComponentId
+thisComponentId dflags =
+  case thisComponentId_ dflags of
+    Just cid -> cid
+    Nothing  ->
+      case thisUnitIdInsts_ dflags of
+        Just _  ->
+          throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
+        Nothing -> ComponentId (unitIdFS (thisPackage dflags))
+
+thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)]
+thisUnitIdInsts dflags =
+    case thisUnitIdInsts_ dflags of
+        Just insts -> insts
+        Nothing    -> []
+
+thisPackage :: DynFlags -> UnitId
+thisPackage dflags =
+    case thisUnitIdInsts_ dflags of
+        Nothing -> default_uid
+        Just insts
+          | all (\(x,y) -> mkHoleModule x == y) insts
+          -> newUnitId (thisComponentId dflags) insts
+          | otherwise
+          -> default_uid
+  where
+    default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags))
+
 parseUnitIdInsts :: String -> [(ModuleName, Module)]
 parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
     [(r, "")] -> r
@@ -2015,17 +2045,12 @@ parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of
             return (n, m)
 
 setUnitIdInsts :: String -> DynFlags -> DynFlags
-setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d
-
-updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags
-updateWithInsts insts d =
-    -- Overwrite the instances, the instances are "indefinite"
-    d { thisPackage     =
-          if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts
-            then newUnitId (unitIdComponentId (thisPackage d)) insts
-            else thisPackage d
-      , thisUnitIdInsts = insts
-      }
+setUnitIdInsts s d =
+    d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) }
+
+setComponentId :: String -> DynFlags -> DynFlags
+setComponentId s d =
+    d { thisComponentId_ = Just (ComponentId (fsLit s)) }
 
 addPluginModuleName :: String -> DynFlags -> DynFlags
 addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
@@ -2368,6 +2393,7 @@ dynamic_flags_deps = [
                  -- parallel builds is equal to the
                  -- result of getNumProcessors
   , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitIdInsts)
+  , make_ord_flag defFlag "this-component-id"   (sepArg setComponentId)
 
     -- RTS options -------------------------------------------------------------
   , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->
@@ -4357,18 +4383,8 @@ parseUnitIdArg :: ReadP PackageArg
 parseUnitIdArg =
     fmap UnitIdArg parseUnitId
 
-
-thisUnitIdComponentId :: DynFlags -> ComponentId
-thisUnitIdComponentId = unitIdComponentId . thisPackage
-
 setUnitId :: String -> DynFlags -> DynFlags
-setUnitId p d =
-    updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid }
-  where
-    uid =
-        case filter ((=="").snd) (readP_to_S parseUnitId p) of
-            [(r, "")] -> r
-            _ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ p)
+setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p }
 
 -- | Given a 'ModuleName' of a signature in the home library, find
 -- out how it is instantiated.  E.g., the canonical form of
index 2bcdd33..d1bf1c8 100644 (file)
@@ -335,7 +335,7 @@ findPackageModule hsc_env mod = do
 -- for the appropriate config.
 findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
 findPackageModule_ hsc_env mod pkg_conf =
-  ASSERT( installedModuleUnitId mod == installedPackageConfigId pkg_conf )
+  ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
   modLocationCache hsc_env mod $
 
   -- special case for GHC.Prim; we won't find it in the filesystem.
index 0921a58..cd9fb15 100644 (file)
@@ -1264,7 +1264,9 @@ unitIdsToCheck dflags =
  where
   goUnitId uid =
     case splitUnitIdInsts uid of
-      (_, Just insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts
+      (_, Just indef) ->
+        let insts = indefUnitIdInsts indef
+        in uid : concatMap (goUnitId . moduleUnitId . snd) insts
       _ -> []
 
 maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
index 1320a57..7a585f3 100644 (file)
@@ -959,10 +959,10 @@ mi_semantic_module iface = case mi_sig_of iface of
 mi_free_holes :: ModIface -> UniqDSet ModuleName
 mi_free_holes iface =
   case splitModuleInsts (mi_module iface) of
-    (_, Just insts)
+    (_, Just indef)
         -- A mini-hack: we rely on the fact that 'renameFreeHoles'
         -- drops things that aren't holes.
-        -> renameFreeHoles (mkUniqDSet cands) insts
+        -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef))
     _   -> emptyUniqDSet
   where
     cands = map fst (dep_mods (mi_deps iface))
@@ -1596,7 +1596,8 @@ extendInteractiveContextWithIds ictxt new_ids
 setInteractivePackage :: HscEnv -> HscEnv
 -- Set the 'thisPackage' DynFlag to 'interactive'
 setInteractivePackage hsc_env
-   = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactiveUnitId } }
+   = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
+                { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } }
 
 setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
 setInteractivePrintName ic n = ic{ic_int_print = n}
index 6e3e2f1..bff8cc3 100644 (file)
@@ -37,7 +37,6 @@ import FastString
 import Outputable
 import Module
 import Unique
-import UniqDSet
 
 -- -----------------------------------------------------------------------------
 -- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,
@@ -138,12 +137,12 @@ installedPackageConfigId = unitId
 packageConfigId :: PackageConfig -> UnitId
 packageConfigId p =
     if indefinite p
-        then newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+        then newUnitId (componentId p) (instantiatedWith p)
         else DefiniteUnitId (DefUnitId (unitId p))
 
 expandedPackageConfigId :: PackageConfig -> UnitId
 expandedPackageConfigId p =
-    newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p)
+    newUnitId (componentId p) (instantiatedWith p)
 
 definitePackageConfigId :: PackageConfig -> Maybe DefUnitId
 definitePackageConfigId p =
index 566d998..e0563da 100644 (file)
@@ -27,6 +27,7 @@ module Packages (
         getPackageDetails,
         getInstalledPackageDetails,
         componentIdString,
+        displayInstalledUnitId,
         listVisibleModuleNames,
         lookupModuleInAllPackages,
         lookupModuleWithSuggestions,
@@ -268,7 +269,7 @@ data UnitVisibility = UnitVisibility
       -- ^ The package name is associated with the 'UnitId'.  This is used
       -- to implement legacy behavior where @-package foo-0.1@ implicitly
       -- hides any packages named @foo@
-    , uv_requirements :: Map ModuleName (Set HoleModule)
+    , uv_requirements :: Map ModuleName (Set IndefModule)
       -- ^ The signatures which are contributed to the requirements context
       -- from this unit ID.
     , uv_explicit :: Bool
@@ -351,7 +352,7 @@ data PackageState = PackageState {
   -- and @r[C=<A>]:C@.
   --
   -- There's an entry in this map for each hole in our home library.
-  requirementContext :: Map ModuleName [HoleModule]
+  requirementContext :: Map ModuleName [IndefModule]
   }
 
 emptyPackageState :: PackageState
@@ -384,8 +385,8 @@ lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
 lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid
 lookupPackage' True m@(PackageConfigMap pkg_map _) uid =
     case splitUnitIdInsts uid of
-        (iuid, Just insts) ->
-            fmap (renamePackage m insts)
+        (iuid, Just indef) ->
+            fmap (renamePackage m (indefUnitIdInsts indef))
                  (lookupUDFM pkg_map iuid)
         (_, Nothing) -> lookupUDFM pkg_map uid
 
@@ -689,15 +690,14 @@ applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag =
                 | otherwise                 = Map.empty
 
            collectHoles uid = case splitUnitIdInsts uid of
-                (_, Just insts) ->
-                  let cid = unitIdComponentId uid
-                      local = [ Map.singleton
+                (_, Just indef) ->
+                  let local = [ Map.singleton
                                   (moduleName mod)
-                                  (Set.singleton $ (newIndefUnitId cid insts, mod_name))
-                              | (mod_name, mod) <- insts
+                                  (Set.singleton $ IndefModule indef mod_name)
+                              | (mod_name, mod) <- indefUnitIdInsts indef
                               , isHoleModule mod ]
                       recurse = [ collectHoles (moduleUnitId mod)
-                                | (_, mod) <- insts ]
+                                | (_, mod) <- indefUnitIdInsts indef ]
                   in Map.unionsWith Set.union $ local ++ recurse
                 -- Other types of unit identities don't have holes
                 (_, Nothing) -> Map.empty
@@ -764,11 +764,11 @@ findPackages pkg_db arg pkgs unusable
           then Just p
           else Nothing
     finder (UnitIdArg uid) p
-      = let (iuid, mb_insts) = splitUnitIdInsts uid
+      = let (iuid, mb_indef) = splitUnitIdInsts uid
         in if iuid == installedPackageConfigId p
-              then Just (case mb_insts of
+              then Just (case mb_indef of
                             Nothing    -> p
-                            Just insts -> renamePackage pkg_db insts p)
+                            Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
               else Nothing
 
 selectPackages :: PackageArg -> [PackageConfig]
@@ -968,9 +968,10 @@ findWiredInPackages dflags pkgs vis_map = do
           where upd_pkg pkg
                   | Just def_uid <- definitePackageConfigId pkg
                   , def_uid `elem` wired_in_ids
-                  = pkg {
-                      unitId = let PackageName fs = packageName pkg
-                               in fsToInstalledUnitId fs
+                  = let PackageName fs = packageName pkg
+                    in pkg {
+                      unitId = fsToInstalledUnitId fs,
+                      componentId = ComponentId fs
                     }
                   | otherwise
                   = pkg
@@ -1313,7 +1314,7 @@ mkPackageState dflags dbs preload0 = do
 
   let pkgname_map = foldl add Map.empty pkgs2
         where add pn_map p
-                = Map.insert (packageName p) (unitIdComponentId (packageConfigId p)) pn_map
+                = Map.insert (packageName p) (componentId p) pn_map
 
   -- The explicitPackages accurately reflects the set of packages we have turned
   -- on; as such, it also is the only way one can come up with requirements.
@@ -1713,7 +1714,12 @@ missingDependencyMsg (Just parent)
 
 componentIdString :: DynFlags -> ComponentId -> Maybe String
 componentIdString dflags cid =
-    fmap sourcePackageIdString (lookupInstalledPackage dflags (newInstalledUnitId cid Nothing))
+    fmap sourcePackageIdString (lookupInstalledPackage dflags
+        (componentIdToInstalledUnitId cid))
+
+displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
+displayInstalledUnitId dflags uid =
+    fmap sourcePackageIdString (lookupInstalledPackage dflags uid)
 
 -- | Will the 'Name' come from a dynamically linked library?
 isDllName :: DynFlags -> UnitId {- not used -} -> Module -> Name -> Bool
index c05d392..0ed59db 100644 (file)
@@ -1,9 +1,10 @@
 module Packages where
 import {-# SOURCE #-} DynFlags(DynFlags)
-import {-# SOURCE #-} Module(ComponentId, UnitId)
+import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId)
 data PackageState
 data PackageConfigMap
 emptyPackageState :: PackageState
 componentIdString :: DynFlags -> ComponentId -> Maybe String
+displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
 improveUnitId :: PackageConfigMap -> UnitId -> UnitId
 getPackageConfigMap :: DynFlags -> PackageConfigMap
index 9b4f774..afa2e50 100644 (file)
@@ -190,7 +190,7 @@ check_inst sig_inst = do
 
 -- | Return this list of requirement interfaces that need to be merged
 -- to form @mod_name@, or @[]@ if this is not a requirement.
-requirementMerges :: DynFlags -> ModuleName -> [HoleModule]
+requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
 requirementMerges dflags mod_name =
     fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
 
@@ -219,7 +219,7 @@ findExtraSigImports' :: HscEnv
                      -> ModuleName
                      -> IO (UniqDSet ModuleName)
 findExtraSigImports' hsc_env HsigFile modname =
-    fmap unionManyUniqDSets (forM reqs $ \(iuid, mod_name) ->
+    fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
         (initIfaceLoad hsc_env
             . withException
             $ moduleFreeHolesPrecise (text "findExtraSigImports")
@@ -273,7 +273,8 @@ implicitRequirements' hsc_env normal_imports
 checkUnitId :: UnitId -> TcM ()
 checkUnitId uid = do
     case splitUnitIdInsts uid of
-      (_, Just insts) ->
+      (_, Just indef) ->
+        let insts = indefUnitIdInsts indef in
         forM_ insts $ \(mod_name, mod) ->
             -- NB: direct hole instantiations are well-typed by construction
             -- (because we FORCE things to be merged in), so don't check them
@@ -282,7 +283,7 @@ checkUnitId uid = do
                 _ <- addErrCtxt (text "while checking that" <+> ppr mod
                         <+> text "implements signature" <+> ppr mod_name <+> text "in"
                         <+> ppr uid) $
-                    mod `checkImplements` (newIndefUnitId (unitIdComponentId uid) insts, mod_name)
+                    mod `checkImplements` IndefModule indef mod_name
                 return ()
       _ -> return () -- if it's hashed, must be well-typed
 
@@ -350,7 +351,7 @@ mergeSignatures lcl_iface0 = do
     let reqs = requirementMerges dflags (moduleName (tcg_mod tcg_env))
 
     -- STEP 2: Read in the RAW forms of all of these interfaces
-    ireq_ifaces <- forM reqs $ \(iuid, mod_name) ->
+    ireq_ifaces <- forM reqs $ \(IndefModule iuid mod_name) ->
            fmap fst
          . withException
          . flip (findAndReadIface (text "mergeSignatures")) False
@@ -359,7 +360,7 @@ mergeSignatures lcl_iface0 = do
     -- STEP 3: Get the unrenamed exports of all these interfaces, and
     -- dO shaping on them.
     let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
-        gen_subst nsubst ((iuid, _), ireq_iface) = do
+        gen_subst nsubst ((IndefModule iuid _), ireq_iface) = do
             let insts = indefUnitIdInsts iuid
             as1 <- liftIO $ rnModExports hsc_env insts ireq_iface
             mb_r <- extend_ns nsubst as1
@@ -376,7 +377,7 @@ mergeSignatures lcl_iface0 = do
         }
 
     -- STEP 4: Rename the interfaces
-    ext_ifaces <- forM (zip reqs ireq_ifaces) $ \((iuid, _), ireq_iface) ->
+    ext_ifaces <- forM (zip reqs ireq_ifaces) $ \((IndefModule iuid _), ireq_iface) ->
         liftIO (rnModIface hsc_env (indefUnitIdInsts iuid) (Just nsubst) ireq_iface)
     lcl_iface <- liftIO $ rnModIface hsc_env (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
     let ifaces = lcl_iface : ext_ifaces
@@ -474,8 +475,8 @@ tcRnInstantiateSignature hsc_env this_mod real_loc =
 -- | Check if module implements a signature.  (The signature is
 -- always un-hashed, which is why its components are specified
 -- explicitly.)
-checkImplements :: Module -> HoleModule -> TcRn TcGblEnv
-checkImplements impl_mod (uid, mod_name) = do
+checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
+checkImplements impl_mod (IndefModule uid mod_name) = do
     let insts = indefUnitIdInsts uid
 
     -- STEP 1: Load the implementing interface, and make a RdrEnv
@@ -545,5 +546,7 @@ instantiateSignature = do
     -- the local one just to get the information?  Hmm...
     MASSERT( moduleUnitId outer_mod == thisPackage dflags )
     inner_mod `checkImplements`
-        (newIndefUnitId (thisUnitIdComponentId dflags)
-                        (thisUnitIdInsts dflags), moduleName outer_mod)
+        IndefModule
+            (newIndefUnitId (thisComponentId dflags)
+                            (thisUnitIdInsts dflags))
+            (moduleName outer_mod)
index 8fa4d2e..579fd67 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 8fa4d2ea2be385e715a10c77d6381d78e1421f7f
+Subproject commit 579fd676a6f066775dcce9427c8463d0dbae101f
index eda1a69..f0333d4 100644 (file)
@@ -71,6 +71,7 @@ import System.Directory
 data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod
    = InstalledPackageInfo {
        unitId             :: instunitid,
+       componentId        :: compid,
        instantiatedWith   :: [(modulename, mod)],
        sourcePackageId    :: srcpkgid,
        packageName        :: srcpkgname,
@@ -104,24 +105,25 @@ type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid module
     (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
      BinaryStringRep modulename, BinaryStringRep compid,
      BinaryStringRep instunitid,
-     DbUnitIdModuleRep compid unitid modulename mod)
+     DbUnitIdModuleRep instunitid compid unitid modulename mod)
 
 -- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'.
 -- There is only one type class because these types are mutually recursive.
 -- NB: The functional dependency helps out type inference in cases
 -- where types would be ambiguous.
-class DbUnitIdModuleRep compid unitid modulename mod
-    | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid where
-  fromDbModule :: DbModule compid unitid modulename mod -> mod
-  toDbModule :: mod -> DbModule compid unitid modulename mod
-  fromDbUnitId :: DbUnitId compid unitid modulename mod -> unitid
-  toDbUnitId :: unitid -> DbUnitId compid unitid modulename mod
+class DbUnitIdModuleRep instunitid compid unitid modulename mod
+    | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid, unitid -> instunitid
+    where
+  fromDbModule :: DbModule instunitid compid unitid modulename mod -> mod
+  toDbModule :: mod -> DbModule instunitid compid unitid modulename mod
+  fromDbUnitId :: DbUnitId instunitid compid unitid modulename mod -> unitid
+  toDbUnitId :: unitid -> DbUnitId instunitid compid unitid modulename mod
 
 -- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
 -- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'.
 -- It has phantom type parameters as this is the most convenient way
 -- to avoid undecidable instances.
-data DbModule compid unitid modulename mod
+data DbModule instunitid compid unitid modulename mod
    = DbModule {
        dbModuleUnitId :: unitid,
        dbModuleName :: modulename
@@ -135,15 +137,9 @@ data DbModule compid unitid modulename mod
 -- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'.
 -- It has phantom type parameters as this is the most convenient way
 -- to avoid undecidable instances.
-data DbUnitId compid unitid modulename mod
-   = DbUnitId {
-       dbUnitIdComponentId :: compid,
-       dbUnitIdInsts :: [(modulename, mod)]
-     }
-   | DbInstalledUnitId {
-       dbUnitIdComponentId :: compid,
-       dbUnitIdHash :: Maybe BS.ByteString
-     }
+data DbUnitId instunitid compid unitid modulename mod
+   = DbUnitId compid [(modulename, mod)]
+   | DbInstalledUnitId instunitid
   deriving (Eq, Show)
 
 class BinaryStringRep a where
@@ -155,6 +151,7 @@ emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g
 emptyInstalledPackageInfo =
   InstalledPackageInfo {
        unitId             = fromStringRep BS.empty,
+       componentId        = fromStringRep BS.empty,
        instantiatedWith   = [],
        sourcePackageId    = fromStringRep BS.empty,
        packageName        = fromStringRep BS.empty,
@@ -306,7 +303,7 @@ writeFileAtomic targetPath content = do
 instance (RepInstalledPackageInfo a b c d e f g) =>
          Binary (InstalledPackageInfo a b c d e f g) where
   put (InstalledPackageInfo
-         unitId instantiatedWith sourcePackageId
+         unitId componentId instantiatedWith sourcePackageId
          packageName packageVersion
          abiHash depends importDirs
          hsLibraries extraLibraries extraGHCiLibraries libraryDirs
@@ -320,6 +317,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
     put (toStringRep packageName)
     put packageVersion
     put (toStringRep unitId)
+    put (toStringRep componentId)
     put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))
              instantiatedWith)
     put abiHash
@@ -349,6 +347,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
     packageName        <- get
     packageVersion     <- get
     unitId             <- get
+    componentId        <- get
     instantiatedWith   <- get
     abiHash            <- get
     depends            <- get
@@ -372,6 +371,7 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
     trusted            <- get
     return (InstalledPackageInfo
               (fromStringRep unitId)
+              (fromStringRep componentId)
               (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))
                 instantiatedWith)
               (fromStringRep sourcePackageId)
@@ -391,8 +391,9 @@ instance (RepInstalledPackageInfo a b c d e f g) =>
               indefinite exposed trusted)
 
 instance (BinaryStringRep modulename, BinaryStringRep compid,
-          DbUnitIdModuleRep compid unitid modulename mod) =>
-         Binary (DbModule compid unitid modulename mod) where
+          BinaryStringRep instunitid,
+          DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
+         Binary (DbModule instunitid compid unitid modulename mod) where
   put (DbModule dbModuleUnitId dbModuleName) = do
     putWord8 0
     put (toDbUnitId dbModuleUnitId)
@@ -411,12 +412,12 @@ instance (BinaryStringRep modulename, BinaryStringRep compid,
               return (DbModuleVar (fromStringRep dbModuleVarName))
 
 instance (BinaryStringRep modulename, BinaryStringRep compid,
-          DbUnitIdModuleRep compid unitid modulename mod) =>
-         Binary (DbUnitId compid unitid modulename mod) where
-  put (DbInstalledUnitId cid hash) = do
+          BinaryStringRep instunitid,
+          DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
+         Binary (DbUnitId instunitid compid unitid modulename mod) where
+  put (DbInstalledUnitId instunitid) = do
     putWord8 0
-    put (toStringRep cid)
-    put hash
+    put (toStringRep instunitid)
   put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do
     putWord8 1
     put (toStringRep dbUnitIdComponentId)
@@ -425,9 +426,8 @@ instance (BinaryStringRep modulename, BinaryStringRep compid,
     b <- getWord8
     case b of
       0 -> do
-        cid <- get
-        hash <- get
-        return (DbInstalledUnitId (fromStringRep cid) hash)
+        instunitid <- get
+        return (DbInstalledUnitId (fromStringRep instunitid))
       _ -> do
         dbUnitIdComponentId <- get
         dbUnitIdInsts <- get
index c047442..4466f58 100644 (file)
@@ -998,7 +998,9 @@ registerPackage input verbosity my_flags multi_instance
      removes = [ RemovePackage p
                | not multi_instance,
                  p <- packages db_to_operate_on,
-                 sourcePackageId p == sourcePackageId pkg ]
+                 sourcePackageId p == sourcePackageId pkg,
+                 -- Only remove things that were instantiated the same way!
+                 instantiatedWith p == instantiatedWith pkg ]
   --
   changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
 
@@ -1098,6 +1100,7 @@ convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
 convertPackageInfoToCacheFormat pkg =
     GhcPkg.InstalledPackageInfo {
        GhcPkg.unitId             = installedUnitId pkg,
+       GhcPkg.componentId        = installedComponentId pkg,
        GhcPkg.instantiatedWith   = instantiatedWith pkg,
        GhcPkg.sourcePackageId    = sourcePackageId pkg,
        GhcPkg.packageName        = packageName pkg,
@@ -1147,22 +1150,20 @@ instance GhcPkg.BinaryStringRep String where
   toStringRep   = BS.pack . toUTF8
 
 instance GhcPkg.BinaryStringRep UnitId where
-  fromStringRep = fromMaybe (error "BinaryStringRep UnitId")
-                . simpleParse . fromStringRep
+  fromStringRep = mkUnitId . fromStringRep
   toStringRep   = toStringRep . display
 
-instance GhcPkg.DbUnitIdModuleRep ComponentId OpenUnitId ModuleName OpenModule where
+instance GhcPkg.DbUnitIdModuleRep UnitId ComponentId OpenUnitId ModuleName OpenModule where
   fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name
   fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name
   toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name
   toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name
   fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts)
-  fromDbUnitId (GhcPkg.DbInstalledUnitId cid bs)
-    = DefiniteUnitId (unsafeMkDefUnitId (UnitId cid (fmap fromStringRep bs)))
+  fromDbUnitId (GhcPkg.DbInstalledUnitId uid)
+    = DefiniteUnitId (unsafeMkDefUnitId uid)
   toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts)
   toDbUnitId (DefiniteUnitId def_uid)
-    | UnitId cid mb_hash <- unDefUnitId def_uid
-    = GhcPkg.DbInstalledUnitId cid (fmap toStringRep mb_hash)
+    = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid)
 
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar