diff options
author | Edward Z. Yang <ezyang@cs.stanford.edu> | 2016-10-06 00:17:15 -0700 |
---|---|---|
committer | Edward Z. Yang <ezyang@cs.stanford.edu> | 2016-10-08 01:37:33 -0700 |
commit | 4e8a0607140b23561248a41aeaf837224aa6315b (patch) | |
tree | 8e03945afe5c40c13b41667e0175f14db15d0780 | |
parent | 00b530d5402aaa37e4085ecdcae0ae54454736c1 (diff) | |
download | haskell-4e8a0607140b23561248a41aeaf837224aa6315b.tar.gz |
Distinguish between UnitId and InstalledUnitId.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
42 files changed, 700 insertions, 432 deletions
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs index 25d2d9252a..53a7e85812 100644 --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -161,7 +161,7 @@ withBkpSession cid insts deps session_type do_this = do TcSession -> newUnitId cid insts -- No hash passed if no instances _ | null insts -> newSimpleUnitId cid - | otherwise -> newHashedUnitId cid (Just (hashUnitId cid insts)), + | otherwise -> newDefiniteUnitId cid (Just (hashUnitId cid insts)), -- Setup all of the output directories according to our hierarchy objectDir = Just (outdir objectDir), hiDir = Just (outdir hiDir), @@ -207,7 +207,7 @@ compileUnit cid insts = do lunit <- getSource cid buildUnit CompSession cid insts lunit --- Invariant: this NEVER returns HashedUnitId +-- Invariant: this NEVER returns InstalledUnitId hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)] hsunitDeps unit = concatMap get_dep (hsunitBody unit) where @@ -281,7 +281,7 @@ buildUnit session cid insts lunit = do sourcePackageId = SourcePackageId compat_fs, packageName = compat_pn, packageVersion = makeVersion [0], - unitId = thisPackage dflags, + unitId = toInstalledUnitId (thisPackage dflags), instantiatedWith = insts, -- Slight inefficiency here haha exposedModules = map (\(m,n) -> (m,Just n)) mods, @@ -293,7 +293,7 @@ buildUnit session cid insts lunit = do -- really used for anything, so we leave it -- blank for now. TcSession -> [] - _ -> map (unwireUnitId dflags) + _ -> map (toInstalledUnitId . unwireUnitId dflags) $ deps ++ [ moduleUnitId mod | (_, mod) <- insts , not (isHoleModule mod) ], @@ -302,6 +302,9 @@ buildUnit session cid insts lunit = do _ -> obj_files, importDirs = [ hi_dir ], exposed = False, + indefinite = case session of + TcSession -> True + _ -> False, -- nope hsLibraries = [], extraLibraries = [], @@ -353,7 +356,7 @@ addPackage pkg = do -- liftIO $ setUnsafeGlobalDynFlags dflags return () --- Precondition: UnitId is NOT HashedUnitId +-- Precondition: UnitId is NOT InstalledUnitId compileInclude :: Int -> (Int, UnitId) -> BkpM () compileInclude n (i, uid) = do hsc_env <- getSession diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs index 7057db019f..fd12c2bb2f 100644 --- a/compiler/basicTypes/Module.hs +++ b/compiler/basicTypes/Module.hs @@ -11,6 +11,7 @@ the keys. {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Module ( @@ -34,7 +35,8 @@ module Module unitIdKey, unitIdComponentId, IndefUnitId(..), - HashedUnitId(..), + InstalledUnitId(..), + toInstalledUnitId, ShHoleSubst, unitIdIsDefinite, @@ -44,7 +46,7 @@ module Module newUnitId, newIndefUnitId, newSimpleUnitId, - newHashedUnitId, + newDefiniteUnitId, hashUnitId, fsToUnitId, stringToUnitId, @@ -93,10 +95,21 @@ module Module HasModule(..), ContainsModule(..), - -- * Virgin modules - VirginModule, - VirginUnitId, - VirginModuleEnv, + -- * Installed unit ids and modules + InstalledModule(..), + InstalledModuleEnv, + installedModuleEq, + installedUnitIdEq, + installedUnitIdString, + newInstalledUnitId, + fsToInstalledUnitId, + stringToInstalledUnitId, + emptyInstalledModuleEnv, + lookupInstalledModuleEnv, + extendInstalledModuleEnv, + filterInstalledModuleEnv, + delInstalledModuleEnv, + DefUnitId(..), -- * Hole module HoleModule, @@ -180,10 +193,9 @@ import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigM -- 'ComponentId's. -- - Same as Distribution.Package.ComponentId -- --- UnitId: A ComponentId + a mapping from hole names (ModuleName) to --- Modules. This is how the compiler identifies instantatiated --- components, and also is the main identifier by which GHC identifies --- things. +-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names +-- (ModuleName) to Modules. This is how the compiler identifies instantatiated +-- components, and also is the main identifier by which GHC identifies things. -- - When Backpack is not being used, UnitId = ComponentId. -- this means a useful fiction for end-users is that there are -- only ever ComponentIds, and some ComponentIds happen to have @@ -193,9 +205,13 @@ import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigM -- - The same as PackageKey in GHC 7.10 (we renamed it because -- they don't necessarily identify packages anymore.) -- - Same as -this-package-key/-package-name flags +-- - An InstalledUnitId corresponds to an actual package which +-- we have installed on disk. It could be definite or indefinite, +-- but if it's indefinite, it has nothing instantiated (we +-- never install partially instantiated units.) -- --- Module: A UnitId + ModuleName. This is how the compiler identifies --- modules (e.g. a Name is a Module + OccName) +-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how +-- the compiler identifies modules (e.g. a Name is a Module + OccName) -- - Same as Language.Haskell.TH.Syntax:Module -- -- THE LESS IMPORTANT ONES @@ -471,8 +487,8 @@ instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts }) = newUnitId cid insts - fromDbUnitId (DbHashedUnitId cid hash) - = newHashedUnitId cid (fmap mkFastStringByteString hash) + fromDbUnitId (DbInstalledUnitId cid hash) -- TODO rename this + = newDefiniteUnitId cid (fmap mkFastStringByteString hash) -- GHC never writes to the database, so it's not needed toDbModule = error "toDbModule: not implemented" toDbUnitId = error "toDbUnitId: not implemented" @@ -518,36 +534,43 @@ instance Outputable ComponentId where ************************************************************************ -} --- | A unit identifier uniquely identifies a library (e.g., --- a package) in GHC. In the absence of Backpack, unit identifiers --- are just strings ('SimpleUnitId'); however, if a library is --- parametrized over some signatures, these identifiers need --- more structure. +-- | A unit identifier identifies a (possibly partially) instantiated +-- library. It is primarily used as part of 'Module', which in turn +-- is used in 'Name', which is used to give names to entities when +-- typechecking. +-- +-- There are two possible forms for a 'UnitId'. It can be a +-- 'DefiniteUnitId', in which case we just have a string that uniquely +-- identifies some fully compiled, installed library we have on disk. +-- However, when we are typechecking a library with missing holes, +-- we may need to instantiate a library on the fly (in which case +-- we don't have any on-disk representation.) In that case, you +-- have an 'IndefiniteUnitId', which explicitly records the +-- instantiation, so that we can substitute over it. data UnitId - = AnIndefUnitId {-# UNPACK #-} !IndefUnitId - | AHashedUnitId {-# UNPACK #-} !HashedUnitId + = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId + | DefiniteUnitId {-# UNPACK #-} !DefUnitId deriving (Typeable) unitIdFS :: UnitId -> FastString -unitIdFS (AnIndefUnitId x) = indefUnitIdFS x -unitIdFS (AHashedUnitId x) = hashedUnitIdFS x +unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x +unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x unitIdKey :: UnitId -> Unique -unitIdKey (AnIndefUnitId x) = indefUnitIdKey x -unitIdKey (AHashedUnitId x) = hashedUnitIdKey x +unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x +unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x unitIdComponentId :: UnitId -> ComponentId -unitIdComponentId (AnIndefUnitId x) = indefUnitIdComponentId x -unitIdComponentId (AHashedUnitId x) = hashedUnitIdComponentId x - --- | A non-hashed unit identifier identifies an indefinite --- library (with holes) which has been *on-the-fly* instantiated --- with a substitution 'unitIdInsts_'. These unit identifiers --- are recorded in interface files and installed package --- database entries for indefinite libraries. We can substitute --- over these identifiers. +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 +-- unit identifier could have no holes, but we haven't gotten +-- around to compiling the actual library yet. -- --- A non-hashed unit identifier pretty-prints to something like +-- An indefinite unit identifier pretty-prints to something like -- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the -- brackets enclose the module substitution). data IndefUnitId @@ -571,44 +594,89 @@ data IndefUnitId indefUnitIdFreeHoles :: UniqDSet ModuleName } deriving (Typeable) --- | A hashed unit identifier identifies an indefinite library which has --- been fully instantiated, compiled and installed to the package database. --- The ONLY source of hashed unit identifiers is the package database and --- the @-this-unit-id@ flag: if a non-hashed unit id is substituted into one --- with no holes, you don't necessarily get a hashed unit id: a hashed unit --- id means *you have actual code*. To promote a fully instantiated unit --- identifier into a hashed unit identifier, you have to look it up in the --- package database. --- --- Hashed unit identifiers don't record the full instantiation tree, --- making them a bit more efficient to work with. This is possible --- because substituting over a hashed unit id is always a no-op --- (no free module variables) +instance Eq IndefUnitId where + u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 + +instance Ord IndefUnitId where + u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 + +-- | 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 +-- in question may be definite or indefinite; if it is indefinite, +-- none of the holes have been filled (we never install partially +-- instantiated libraries.) Put another way, an installed unit id +-- is either fully instantiated, or not instantiated at all. -- --- Hashed unit identifiers look something like @p+af23SAj2dZ219@ -data HashedUnitId = - HashedUnitId { +-- Installed unit identifiers look something like @p+af23SAj2dZ219@, +-- or maybe just @p@ if they don't use Backpack. +data InstalledUnitId = + InstalledUnitId { -- | The full hashed unit identifier, including the component id -- and the hash. - hashedUnitIdFS :: FastString, + installedUnitIdFS :: FastString, -- | Cached unique of 'unitIdFS'. - hashedUnitIdKey :: Unique, + installedUnitIdKey :: Unique, -- | The component identifier of the hashed unit identifier. - hashedUnitIdComponentId :: !ComponentId + installedUnitIdComponentId :: !ComponentId } deriving (Typeable) -instance Eq IndefUnitId where - u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 +-- | 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 Ord IndefUnitId where - u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 +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) -instance Outputable HashedUnitId where +instance BinaryStringRep InstalledUnitId where + fromStringRep bs = rawNewInstalledUnitId (fromStringRep cid) (mkFastStringByteString bs) + where cid = BS.Char8.takeWhile (/='+') bs + -- GHC doesn't write to database + toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" + +instance Eq InstalledUnitId where + uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 + +instance Ord InstalledUnitId where + u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 + +instance Uniquable InstalledUnitId where + getUnique = installedUnitIdKey + +instance Outputable InstalledUnitId where ppr uid = - if hashedUnitIdComponentId uid == ComponentId (hashedUnitIdFS uid) - then ppr (hashedUnitIdComponentId uid) - else ftext (hashedUnitIdFS uid) + if installedUnitIdComponentId uid == ComponentId (installedUnitIdFS uid) + then ppr (installedUnitIdComponentId uid) + else ftext (installedUnitIdFS uid) + +-- | 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 + +installedUnitIdString :: InstalledUnitId -> String +installedUnitIdString = unpackFS . installedUnitIdFS instance Outputable IndefUnitId where ppr uid = @@ -636,25 +704,53 @@ instance Outputable IndefUnitId where cid = indefUnitIdComponentId uid insts = indefUnitIdInsts uid -{- -newtype DefiniteUnitId = DefiniteUnitId HashedUnitId - deriving (Eq, Ord, Outputable, Typeable) +-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. +data InstalledModule = InstalledModule { + installedModuleUnitId :: !InstalledUnitId, + installedModuleName :: !ModuleName + } + deriving (Eq, Ord) -newtype InstalledUnitId = InstalledUnitId HashedUnitId - deriving (Eq, Ord, Outputable, Typeable) --} +instance Outputable InstalledModule where + ppr (InstalledModule p n) = + ppr p <> char ':' <> pprModuleName n + +fsToInstalledUnitId :: FastString -> InstalledUnitId +fsToInstalledUnitId fs = rawNewInstalledUnitId (ComponentId fs) fs + +stringToInstalledUnitId :: String -> InstalledUnitId +stringToInstalledUnitId = fsToInstalledUnitId . mkFastString + +-- | Test if a 'Module' corresponds to a given 'InstalledModule', +-- modulo instantiation. +installedModuleEq :: InstalledModule -> Module -> Bool +installedModuleEq imod mod = + fst (splitModuleInsts mod) == imod + +-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', +-- modulo instantiation. +installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool +installedUnitIdEq iuid uid = + fst (splitUnitIdInsts uid) == iuid + +-- | A map keyed off of 'InstalledModule' +newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) + +emptyInstalledModuleEnv :: InstalledModuleEnv a +emptyInstalledModuleEnv = InstalledModuleEnv Map.empty --- | A 'VirginModule' is a 'Module' which contains a 'VirginUnitId'. -type VirginModule = Module +lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a +lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e --- | A virgin unit id is either a 'HashedUnitId', --- or a 'UnitId' whose instantiation all have the form @A=<A>@. --- Intuitively, virgin unit identifiers are those which are recorded --- in the installed package database and can be read off disk. -type VirginUnitId = UnitId +extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a +extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) --- | A map keyed off of 'VirginModule' -type VirginModuleEnv elt = ModuleEnv elt +filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a +filterInstalledModuleEnv f (InstalledModuleEnv e) = + InstalledModuleEnv (Map.filterWithKey f 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 @@ -662,10 +758,10 @@ type VirginModuleEnv elt = ModuleEnv elt -- an instantiation. type HoleModule = (IndefUnitId, ModuleName) --- Note [UnitId to HashedUnitId improvement] +-- Note [UnitId to InstalledUnitId improvement] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Just because a UnitId is definite (has no holes) doesn't --- mean it's necessarily a HashedUnitId; it could just be +-- mean it's necessarily a InstalledUnitId; it could just be -- that over the course of renaming UnitIds on the fly -- while typechecking an indefinite library, we -- ended up with a fully instantiated unit id with no hash, @@ -678,21 +774,19 @@ type HoleModule = (IndefUnitId, ModuleName) -- (the unitIdFS for a UnitId never corresponds to a Cabal-provided -- hash of a compiled instantiated library). -- --- There is one last niggle which is not currently fixed: --- improvement based on the package database means that --- we might end up developing on a package that is not transitively --- depended upon by the packages the user specified directly --- via command line flags. This could lead to strange and --- difficult to understand bugs if those instantiations are --- out of date. The fix is that GHC has to be a bit more --- careful about what instantiated packages get put in the package database. --- I haven't implemented this yet. +-- There is one last niggle: improvement based on the package database means +-- that we might end up developing on a package that is not transitively +-- depended upon by the packages the user specified directly via command line +-- flags. This could lead to strange and difficult to understand bugs if those +-- instantiations are out of date. The solution is to only improve a +-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the +-- closure of all the packages which were explicitly specified. -- | Retrieve the set of free holes of a 'UnitId'. unitIdFreeHoles :: UnitId -> UniqDSet ModuleName -unitIdFreeHoles (AnIndefUnitId x) = indefUnitIdFreeHoles x +unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x -- Hashed unit ids are always fully instantiated -unitIdFreeHoles (AHashedUnitId _) = emptyUniqDSet +unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet instance Show UnitId where show = unitIdString @@ -707,14 +801,12 @@ unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles -- coincides with its 'ComponentId'. This hash is completely internal -- to GHC and is not used for symbol names or file paths. hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString -hashUnitId (ComponentId fs_cid) sorted_holes - -- Make the special-case work. - | all (\(mod_name, m) -> mkHoleModule mod_name == m) sorted_holes = fs_cid hashUnitId cid sorted_holes = mkFastStringByteString . fingerprintUnitId (toStringRep cid) $ rawHashUnitId sorted_holes +-- | Generate a hash for a sorted module substitution. rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint rawHashUnitId sorted_holes = fingerprintByteString @@ -739,27 +831,37 @@ fingerprintUnitId prefix (Fingerprint a b) -- | Create a new, externally provided hashed unit id from -- a hash. -newHashedUnitId :: ComponentId -> Maybe FastString -> UnitId -newHashedUnitId cid@(ComponentId cid_fs) (Just fs) - = rawNewHashedUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs) -newHashedUnitId cid@(ComponentId cid_fs) Nothing - = rawNewHashedUnitId cid cid_fs - --- | Smart constructor for 'HashedUnitId'; input 'FastString' +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'). -rawNewHashedUnitId :: ComponentId -> FastString -> UnitId -rawNewHashedUnitId cid fs = AHashedUnitId $ HashedUnitId { - hashedUnitIdFS = fs, - hashedUnitIdKey = getUnique fs, - hashedUnitIdComponentId = cid +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 = AnIndefUnitId $ newIndefUnitId cid insts +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 { @@ -773,10 +875,9 @@ newIndefUnitId cid insts = fs = hashUnitId cid sorted_insts sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts - pprUnitId :: UnitId -> SDoc -pprUnitId (AHashedUnitId uid) = ppr uid -pprUnitId (AnIndefUnitId uid) = ppr uid +pprUnitId (DefiniteUnitId uid) = ppr uid +pprUnitId (IndefiniteUnitId uid) = ppr uid instance Eq UnitId where uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 @@ -805,7 +906,7 @@ instance Outputable UnitId where -- Performance: would prefer to have a NameCache like thing instance Binary UnitId where - put_ bh (AHashedUnitId uid) + put_ bh (DefiniteUnitId (DefUnitId uid)) | cid == ComponentId fs = do putByte bh 0 put_ bh fs @@ -814,9 +915,9 @@ instance Binary UnitId where put_ bh cid put_ bh fs where - cid = hashedUnitIdComponentId uid - fs = hashedUnitIdFS uid - put_ bh (AnIndefUnitId uid) = do + cid = installedUnitIdComponentId uid + fs = installedUnitIdFS uid + put_ bh (IndefiniteUnitId uid) = do putByte bh 1 put_ bh cid put_ bh insts @@ -833,13 +934,7 @@ instance Binary UnitId where _ -> do cid <- get bh fs <- get bh - return (rawNewHashedUnitId cid fs) - -instance BinaryStringRep UnitId where - fromStringRep bs = rawNewHashedUnitId (fromStringRep cid) (mkFastStringByteString bs) - where cid = BS.Char8.takeWhile (/='+') bs - -- GHC doesn't write to database - toStringRep = error "BinaryStringRep UnitId: not implemented" + return (rawNewDefiniteUnitId cid fs) instance Binary ComponentId where put_ bh (ComponentId fs) = put_ bh fs @@ -852,7 +947,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 = rawNewHashedUnitId (ComponentId fs) fs +fsToUnitId fs = rawNewDefiniteUnitId (ComponentId fs) fs stringToUnitId :: String -> UnitId stringToUnitId = fsToUnitId . mkFastString @@ -902,7 +997,7 @@ renameHoleModule' pkg_map env m renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId renameHoleUnitId' pkg_map env uid = case uid of - (AnIndefUnitId + (IndefiniteUnitId IndefUnitId{ indefUnitIdComponentId = cid , indefUnitIdInsts = insts , indefUnitIdFreeHoles = fh }) @@ -911,7 +1006,7 @@ renameHoleUnitId' pkg_map env uid = -- Functorially apply the substitution to the instantiation, -- then check the 'PackageConfigMap' to see if there is -- a compiled version of this 'UnitId' we can improve to. - -- See Note [UnitId to HashedUnitId] improvement + -- See Note [UnitId to InstalledUnitId] improvement else improveUnitId pkg_map $ newUnitId cid (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) @@ -921,16 +1016,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 -> (VirginModule, Maybe [(ModuleName, Module)]) +splitModuleInsts :: Module -> (InstalledModule, Maybe [(ModuleName, Module)]) splitModuleInsts m = let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m) - in (mkModule uid (moduleName m), mb_insts) + in (InstalledModule uid (moduleName m), mb_insts) -- | See 'splitModuleInsts'. -splitUnitIdInsts :: UnitId -> (VirginUnitId, Maybe [(ModuleName, Module)]) -splitUnitIdInsts (AnIndefUnitId iuid) = - (AnIndefUnitId (generalizeIndefUnitId iuid), Just (indefUnitIdInsts iuid)) -splitUnitIdInsts uid = (uid, Nothing) +splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe [(ModuleName, Module)]) +splitUnitIdInsts (IndefiniteUnitId iuid) = + (newInstalledUnitId (indefUnitIdComponentId iuid) Nothing, Just (indefUnitIdInsts iuid)) +splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) generalizeIndefUnitId :: IndefUnitId -> IndefUnitId generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid @@ -942,17 +1037,20 @@ parseModuleName = fmap mkModuleName $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") parseUnitId :: ReadP UnitId -parseUnitId = parseFullUnitId <++ parseHashedUnitId <++ parseSimpleUnitId +parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId where - parseFullUnitId = do cid <- parseComponentId - insts <- parseModSubst - return (newUnitId cid insts) - parseHashedUnitId = do cid <- parseComponentId - _ <- Parse.char '+' - hash <- Parse.munch1 isAlphaNum - return (newHashedUnitId cid (Just (mkFastString hash))) - parseSimpleUnitId = do cid <- parseComponentId - return (newSimpleUnitId cid) + parseFullUnitId = do + cid <- parseComponentId + insts <- parseModSubst + return (newUnitId cid insts) + parseDefiniteUnitId = do + cid <- parseComponentId + _ <- Parse.char '+' + hash <- Parse.munch1 isAlphaNum + return (newDefiniteUnitId cid (Just (mkFastString hash))) + parseSimpleUnitId = do + cid <- parseComponentId + return (newSimpleUnitId cid) parseComponentId :: ReadP ComponentId parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 72d2f9b2ec..1f589a98eb 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -92,12 +92,12 @@ mkDependencies -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - pkgs | th_used = insertList thUnitId (imp_dep_pkgs imports) + pkgs | th_used = insertList (toInstalledUnitId thUnitId) (imp_dep_pkgs imports) | otherwise = imp_dep_pkgs imports -- Set the packages required to be Safe according to Safe Haskell. -- See Note [RnNames . Tracking Trust Transitively] - sorted_pkgs = sortBy stableUnitIdCmp pkgs + sorted_pkgs = sort pkgs trust_pkgs = imp_trust_pkgs imports dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 251d9a8700..0b3fd94449 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -116,7 +116,7 @@ data PersistentLinkerState -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important - pkgs_loaded :: ![UnitId], + pkgs_loaded :: ![LinkerUnitId], -- we need to remember the name of previous temporary DLL/.so -- libraries so we can link them (see #10322) @@ -137,10 +137,10 @@ emptyPLS _ = PersistentLinkerState { -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = [rtsUnitId] + where init_pkgs = map toInstalledUnitId [rtsUnitId] -extendLoadedPkgs :: [UnitId] -> IO () +extendLoadedPkgs :: [InstalledUnitId] -> IO () extendLoadedPkgs pkgs = modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } @@ -566,7 +566,7 @@ getLinkDeps :: HscEnv -> HomePackageTable -> Maybe FilePath -- replace object suffices? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [UnitId]) -- ... then link these first + -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods @@ -604,8 +604,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow -> UniqDSet ModuleName -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([ModuleName], [UnitId]) -- result + -> UniqDSet InstalledUnitId -- accum. package dependencies + -> IO ([ModuleName], [InstalledUnitId]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -632,7 +632,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps -- if pkg /= this_pkg - then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' pkg) + then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg)) else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs' where @@ -1126,12 +1126,15 @@ showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm +-- TODO: Make this type more precise +type LinkerUnitId = InstalledUnitId + -- | Link exactly the specified packages, and their dependents (unless of -- course they are already linked). The dependents are linked -- automatically, and it doesn't matter what order you specify the input -- packages. -- -linkPackages :: HscEnv -> [UnitId] -> IO () +linkPackages :: HscEnv -> [LinkerUnitId] -> IO () -- NOTE: in fact, since each module tracks all the packages it depends on, -- we don't really need to use the package-config dependencies. -- @@ -1147,7 +1150,7 @@ linkPackages hsc_env new_pkgs = do modifyPLS_ $ \pls -> do linkPackages' hsc_env new_pkgs pls -linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState +linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState -> IO PersistentLinkerState linkPackages' hsc_env new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks @@ -1155,7 +1158,7 @@ linkPackages' hsc_env new_pks pls = do where dflags = hsc_dflags hsc_env - link :: [UnitId] -> [UnitId] -> IO [UnitId] + link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId] link pkgs new_pkgs = foldM link_one pkgs new_pkgs @@ -1163,7 +1166,7 @@ linkPackages' hsc_env new_pks pls = do | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupPackage dflags new_pkg + | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg = do { -- Link dependents first pkgs' <- link pkgs (depends pkg_cfg) -- Now link the package itself @@ -1171,7 +1174,7 @@ linkPackages' hsc_env new_pks pls = do ; return (new_pkg : pkgs') } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unitIdString new_pkg)) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg))) linkPackage :: HscEnv -> PackageConfig -> IO () diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 4e1fea068e..ca11c6f59b 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -276,7 +276,8 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg ; case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) - err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) } + -- TODO: Make sure this error message is good + err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) } -- | Load interface directly for a fully qualified 'Module'. (This is a fairly -- rare operation, but in particular it is used to load orphan modules @@ -572,7 +573,7 @@ moduleFreeHolesPrecise doc_str mod tryEpsAndHpt dflags eps hpt = fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod) tryDepsCache eps imod insts = - case lookupModuleEnv (eps_free_holes eps) imod of + case lookupInstalledModuleEnv (eps_free_holes eps) imod of Just ifhs -> Just (renameFreeHoles ifhs insts) _otherwise -> Nothing readAndCache imod insts = do @@ -582,7 +583,7 @@ moduleFreeHolesPrecise doc_str mod let ifhs = mi_free_holes iface -- Cache it updateEps_ (\eps -> - eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs }) + eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs }) return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) @@ -769,7 +770,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings. See Trac #8320. -} -findAndReadIface :: SDoc -> VirginModule +findAndReadIface :: SDoc -> InstalledModule -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) @@ -788,7 +789,8 @@ findAndReadIface doc_str mod hi_boot_file nest 4 (text "reason:" <+> doc_str)]) -- Check for GHC.Prim, and return its static interface - if mod == gHC_PRIM + -- TODO: make this check a function + if mod `installedModuleEq` gHC_PRIM then do iface <- getHooked ghcPrimIfaceHook ghcPrimIface return (Succeeded (iface, @@ -799,13 +801,13 @@ findAndReadIface doc_str mod hi_boot_file hsc_env <- getTopEnv mb_found <- liftIO (findExactModule hsc_env mod) case mb_found of - Found loc mod -> do + InstalledFound loc mod -> do -- Found file, so read it let file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) -- See Note [Home module load error] - if thisPackage dflags == moduleUnitId mod && + if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path @@ -815,14 +817,14 @@ findAndReadIface doc_str mod hi_boot_file traceIf (text "...not found") dflags <- getDynFlags return (Failed (cannotFindInterface dflags - (moduleName mod) err)) + (installedModuleName mod) err)) where read_file file_path = do traceIf (text "readIFace" <+> text file_path) read_result <- readIface mod file_path case read_result of Failed err -> return (Failed (badIfaceFile file_path err)) Succeeded iface - | mi_module iface /= mod -> + | not (mod `installedModuleEq` mi_module iface) -> return (Failed (wrongIfaceModErr iface mod file_path)) | otherwise -> return (Succeeded (iface, file_path)) @@ -852,7 +854,7 @@ findAndReadIface doc_str mod hi_boot_file -- @readIface@ tries just the one file. -readIface :: VirginModule -> FilePath +readIface :: InstalledModule -> FilePath -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -862,8 +864,10 @@ readIface wanted_mod file_path readBinIface CheckHiWay QuietBinIFaceReading file_path ; case res of Right iface - | wanted_mod == actual_mod -> return (Succeeded iface) - | otherwise -> return (Failed err) + -- Same deal + | wanted_mod `installedModuleEq` actual_mod + -> return (Succeeded iface) + | otherwise -> return (Failed err) where actual_mod = mi_module iface err = hiModuleNameMismatchWarn wanted_mod actual_mod @@ -884,7 +888,7 @@ initExternalPackageState = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, - eps_free_holes = emptyModuleEnv, + eps_free_holes = emptyInstalledModuleEnv, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv, @@ -1114,7 +1118,7 @@ badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc +hiModuleNameMismatchWarn :: InstalledModule -> Module -> MsgDoc hiModuleNameMismatchWarn requested_mod read_mod = -- ToDo: This will fail to have enough qualification when the package IDs -- are the same @@ -1127,11 +1131,11 @@ hiModuleNameMismatchWarn requested_mod read_mod = , ppr read_mod ] -wrongIfaceModErr :: ModIface -> Module -> String -> SDoc -wrongIfaceModErr iface mod_name file_path +wrongIfaceModErr :: ModIface -> InstalledModule -> String -> SDoc +wrongIfaceModErr iface mod file_path = sep [text "Interface file" <+> iface_file, text "contains module" <+> quotes (ppr (mi_module iface)) <> comma, - text "but we were expecting module" <+> quotes (ppr mod_name), + text "but we were expecting module" <+> quotes (ppr mod), sep [text "Probable cause: the source code which generated", nest 2 iface_file, text "has an incompatible module name" @@ -1139,7 +1143,7 @@ wrongIfaceModErr iface mod_name file_path ] where iface_file = doubleQuotes (text file_path) -homeModError :: Module -> ModLocation -> SDoc +homeModError :: InstalledModule -> ModLocation -> SDoc -- See Note [Home module load error] homeModError mod location = text "attempting to use module " <> quotes (ppr mod) diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 3ab898e682..7cff9463ac 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -651,7 +651,7 @@ getOrphanHashes hsc_env mods = do sortDependencies :: Dependencies -> Dependencies sortDependencies d = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), - dep_pkgs = sortBy (stableUnitIdCmp `on` fst) (dep_pkgs d), + dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d) } @@ -1009,7 +1009,7 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface loadIface = do let iface_path = msHiFilePath mod_summary - read_result <- readIface (ms_mod mod_summary) iface_path + read_result <- readIface (ms_installed_mod mod_summary) iface_path case read_result of Failed err -> do traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) @@ -1107,7 +1107,7 @@ checkHsig mod_summary iface = do dflags <- getDynFlags let outer_mod = ms_mod mod_summary inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) - MASSERT( thisPackage dflags == moduleUnitId outer_mod ) + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) case inner_mod == mi_semantic_module iface of True -> up_to_date (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed") @@ -1158,7 +1158,7 @@ checkDependencies hsc_env summary iface else return UpToDate | otherwise - -> if pkg `notElem` (map fst prev_dep_pkgs) + -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 024cd7b732..0794a9ee67 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -378,7 +378,7 @@ tcHiBootIface hsc_src mod -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { read_result <- findAndReadIface - need mod + need (fst (splitModuleInsts mod)) True -- Hi-boot file ; case read_result of { diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index f172cf1259..f4681dcd27 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -50,7 +50,7 @@ codeOutput :: DynFlags -> FilePath -> ModLocation -> ForeignStubs - -> [UnitId] + -> [InstalledUnitId] -> Stream IO RawCmmGroup () -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) @@ -107,7 +107,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action outputC :: DynFlags -> FilePath -> Stream IO RawCmmGroup () - -> [UnitId] + -> [InstalledUnitId] -> IO () outputC dflags filenm cmm_stream packages @@ -131,7 +131,7 @@ outputC dflags filenm cmm_stream packages '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" - let pkg_names = map unitIdString packages + let pkg_names = map installedUnitIdString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 30493f123e..b1f1f6c2e6 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -402,7 +402,7 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit @@ -424,7 +424,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. let pkg_hslibs = [ (libraryDirs c, lib) - | Just c <- map (lookupPackage dflags) pkg_deps, + | Just c <- map (lookupInstalledPackage dflags) pkg_deps, lib <- packageHsLibs dflags c ] pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs @@ -438,7 +438,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool checkLinkInfo dflags pkg_deps exe_file | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) -- ToDo: Windows and OS X do not use the ELF binary format, so @@ -1652,7 +1652,7 @@ mkExtraObjToLinkIntoBinary dflags = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath] mkNoteObjsToLinkIntoBinary dflags dep_packages = do link_info <- getLinkInfo dflags dep_packages @@ -1677,7 +1677,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do -- | Return the "link info" string -- -- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [UnitId] -> IO String +getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String getLinkInfo dflags dep_packages = do package_link_opts <- getPackageLinkOpts dflags dep_packages pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) @@ -1714,13 +1714,13 @@ not follow the specified record-based format (see #11022). ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file -getHCFilePackages :: FilePath -> IO [UnitId] +getHCFilePackages :: FilePath -> IO [InstalledUnitId] getHCFilePackages filename = Exception.bracket (openFile filename ReadMode) hClose $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToUnitId (words rest)) + return (map stringToInstalledUnitId (words rest)) _other -> return [] @@ -1737,10 +1737,10 @@ getHCFilePackages filename = -- read any interface files), so the user must explicitly specify all -- the packages. -linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO () +linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO () +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags mySettings = settings dflags @@ -1987,7 +1987,7 @@ maybeCreateManifest dflags exe_filename | otherwise = return [] -linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () +linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do @@ -1997,7 +1997,7 @@ linkDynLibCheck dflags o_files dep_packages linkDynLib dflags o_files dep_packages -linkStaticLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () +linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () linkStaticLibCheck dflags o_files dep_packages = do when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ @@ -2229,7 +2229,7 @@ haveRtsOptsFlags dflags = -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> IO FilePath getGhcVersionPathName dflags = do - dirs <- getPackageIncludePath dflags [rtsUnitId] + dirs <- getPackageIncludePath dflags [toInstalledUnitId rtsUnitId] found <- filterM doesFileExist (map (</> "ghcversion.h") dirs) case found of diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index e813e9e52c..2bcdd3360c 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -71,25 +71,25 @@ type BaseName = String -- Basename of file -- assumed to not move around during a session. flushFinderCaches :: HscEnv -> IO () flushFinderCaches hsc_env = - atomicModifyIORef' fc_ref $ \fm -> (filterModuleEnv is_ext fm, ()) + atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) where this_pkg = thisPackage (hsc_dflags hsc_env) fc_ref = hsc_FC hsc_env - is_ext mod _ | moduleUnitId mod /= this_pkg = True + is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True | otherwise = False -addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO () +addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () addToFinderCache ref key val = - atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ()) + atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) -removeFromFinderCache :: IORef FinderCache -> Module -> IO () +removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO () removeFromFinderCache ref key = - atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ()) + atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult) +lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) lookupFinderCache ref key = do c <- readIORef ref - return $! lookupModuleEnv c key + return $! lookupInstalledModuleEnv c key -- ----------------------------------------------------------------------------- -- The three external entry points @@ -131,11 +131,11 @@ findPluginModule hsc_env mod_name = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> VirginModule -> IO FindResult +findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if moduleUnitId mod == thisPackage dflags - then findHomeModule hsc_env (moduleName mod) + in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags + then findInstalledHomeModule hsc_env (installedModuleName mod) else findPackageModule hsc_env mod -- ----------------------------------------------------------------------------- @@ -169,9 +169,9 @@ orIfNotFound this or_this = do -- been done. Otherwise, do the lookup (with the IO action) and save -- the result in the finder cache and the module location cache (if it -- was successful.) -homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult +homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult homeSearchCache hsc_env mod_name do_this = do - let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name modLocationCache hsc_env mod do_this findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString @@ -190,8 +190,20 @@ findExposedPluginPackageModule hsc_env mod_name findLookupResult :: HscEnv -> LookupResult -> IO FindResult findLookupResult hsc_env r = case r of - LookupFound m pkg_conf -> - findPackageModule_ hsc_env m pkg_conf + LookupFound m pkg_conf -> do + let im = fst (splitModuleInsts m) + r' <- findPackageModule_ hsc_env im pkg_conf + case r' of + -- TODO: ghc -M is unlikely to do the right thing + -- with just the location of the thing that was + -- instantiated; you probably also need all of the + -- implicit locations from the instances + InstalledFound loc _ -> return (Found loc m) + InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) + InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_suggestions = []}) LookupMultiple rs -> return (FoundMultiple rs) LookupHidden pkg_hiddens mod_hiddens -> @@ -205,7 +217,7 @@ findLookupResult hsc_env r = case r of , fr_mods_hidden = [] , fr_suggestions = suggest }) -modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult +modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult modLocationCache hsc_env mod do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod case m of @@ -215,20 +227,43 @@ modLocationCache hsc_env mod do_this = do addToFinderCache (hsc_FC hsc_env) mod result return result +mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule +mkHomeInstalledModule dflags mod_name = + let iuid = fst (splitUnitIdInsts (thisPackage dflags)) + in InstalledModule iuid mod_name + +-- This returns a module because it's more convenient for users addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder hsc_env mod_name loc = do - let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name - addToFinderCache (hsc_FC hsc_env) mod (Found loc mod) - return mod + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) + return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name) uncacheModule :: HscEnv -> ModuleName -> IO () -uncacheModule hsc_env mod = do - let this_pkg = thisPackage (hsc_dflags hsc_env) - removeFromFinderCache (hsc_FC hsc_env) (mkModule this_pkg mod) +uncacheModule hsc_env mod_name = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + removeFromFinderCache (hsc_FC hsc_env) mod -- ----------------------------------------------------------------------------- -- The internal workers +findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule hsc_env mod_name = do + r <- findInstalledHomeModule hsc_env mod_name + return $ case r of + InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_suggestions = [] + } + where + dflags = hsc_dflags hsc_env + uid = thisPackage dflags + -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used -- as a building block for the following operations: @@ -245,14 +280,14 @@ uncacheModule hsc_env mod = do -- -- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to -- call this.) -findHomeModule :: HscEnv -> ModuleName -> IO FindResult -findHomeModule hsc_env mod_name = +findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule hsc_env mod_name = homeSearchCache hsc_env mod_name $ let dflags = hsc_dflags hsc_env home_path = importPaths dflags hisuf = hiSuf dflags - mod = mkModule (thisPackage dflags) mod_name + mod = mkHomeInstalledModule dflags mod_name source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") @@ -275,20 +310,20 @@ findHomeModule hsc_env mod_name = -- special case for GHC.Prim; we won't find it in the filesystem. -- This is important only when compiling the base package (where GHC.Prim -- is a home module). - if mod == gHC_PRIM - then return (Found (error "GHC.Prim ModLocation") mod) + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) else searchPathExts home_path mod exts -- | Search for a module in external packages only. -findPackageModule :: HscEnv -> VirginModule -> IO FindResult +findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env - pkg_id = moduleUnitId mod + pkg_id = installedModuleUnitId mod -- - case lookupPackage dflags pkg_id of - Nothing -> return (NoPackage pkg_id) + case lookupInstalledPackage dflags pkg_id of + Nothing -> return (InstalledNoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf -- | Look up the interface file associated with module @mod@. This function @@ -298,14 +333,14 @@ findPackageModule hsc_env mod = do -- the 'PackageConfig' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. -findPackageModule_ :: HscEnv -> VirginModule -> PackageConfig -> IO FindResult +findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult findPackageModule_ hsc_env mod pkg_conf = - ASSERT( moduleUnitId mod == packageConfigId pkg_conf ) + ASSERT( installedModuleUnitId mod == installedPackageConfigId pkg_conf ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. - if mod == gHC_PRIM - then return (Found (error "GHC.Prim ModLocation") mod) + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) else let @@ -326,9 +361,9 @@ findPackageModule_ hsc_env mod pkg_conf = [one] | MkDepend <- ghcMode dflags -> do -- there's only one place that this .hi file can be, so -- don't bother looking for it. - let basename = moduleNameSlashes (moduleName mod) + let basename = moduleNameSlashes (installedModuleName mod) loc <- mk_hi_loc one basename - return (Found loc mod) + return (InstalledFound loc mod) _otherwise -> searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] @@ -337,13 +372,13 @@ findPackageModule_ hsc_env mod pkg_conf = searchPathExts :: [FilePath] -- paths to search - -> Module -- module name + -> InstalledModule -- module name -> [ ( FileExt, -- suffix FilePath -> BaseName -> IO ModLocation -- action ) ] - -> IO FindResult + -> IO InstalledFindResult searchPathExts paths mod exts = do result <- search to_search @@ -358,7 +393,7 @@ searchPathExts paths mod exts return result where - basename = moduleNameSlashes (moduleName mod) + basename = moduleNameSlashes (installedModuleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) @@ -369,15 +404,12 @@ searchPathExts paths mod exts file = base <.> ext ] - search [] = return (NotFound { fr_paths = map fst to_search - , fr_pkg = Just (moduleUnitId mod) - , fr_mods_hidden = [], fr_pkgs_hidden = [] - , fr_suggestions = [] }) + search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod))) search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then do { loc <- mk_result; return (Found loc mod) } + then do { loc <- mk_result; return (InstalledFound loc mod) } else search rest mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt @@ -539,9 +571,9 @@ cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc cannotFindModule = cantFindErr (sLit "Could not find module") (sLit "Ambiguous module name") -cannotFindInterface :: DynFlags -> ModuleName -> FindResult -> SDoc -cannotFindInterface = cantFindErr (sLit "Failed to load interface for") - (sLit "Ambiguous interface for") +cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc +cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") + (sLit "Ambiguous interface for") cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult -> SDoc @@ -581,7 +613,7 @@ cantFindErr cannot_find _ dflags mod_name find_result = case find_result of NoPackage pkg -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg + text "was found" NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens @@ -642,18 +674,6 @@ cantFindErr cannot_find _ dflags mod_name find_result text "to the build-depends in your .cabal file." | otherwise = Outputable.empty - looks_like_srcpkgid :: UnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id FastString into a source package ID - -- FastString and see if it means anything. - | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (unitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - mod_hidden pkg = text "it is a hidden module in the package" <+> quotes (ppr pkg) @@ -693,3 +713,64 @@ cantFindErr cannot_find _ dflags mod_name find_result = parens (text "needs flag -package-id" <+> ppr (packageConfigId pkg)) | otherwise = Outputable.empty + +cantFindInstalledErr :: LitString -> LitString -> DynFlags -> ModuleName -> InstalledFindResult + -> SDoc +cantFindInstalledErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + InstalledNoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" $$ looks_like_srcpkgid pkg + + InstalledNotFound files mb_pkg + | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags) + -> not_found_in_package pkg files + + | null files + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> tried_these files + + _ -> panic "cantFindInstalledErr" + + build_tag = buildTag dflags + + looks_like_srcpkgid :: InstalledUnitId -> SDoc + looks_like_srcpkgid pk + -- Unsafely coerce a unit id FastString into a source package ID + -- FastString and see if it means anything. + | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk)) + = parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ + (if null pkgs then Outputable.empty + else text "and" <+> int (length pkgs) <+> text "other candidates")) + -- Todo: also check if it looks like a package name! + | otherwise = Outputable.empty + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files + + tried_these files + | null files = Outputable.empty + | verbosity dflags < 3 = + text "Use -v to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 6a3887a0e9..5122329acf 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -576,7 +576,7 @@ checkBrokenTablesNextToCode' dflags -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. -- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId] +setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] setSessionDynFlags dflags = do dflags' <- checkNewDynFlags dflags (dflags'', preload) <- liftIO $ initPackages dflags' @@ -586,7 +586,7 @@ setSessionDynFlags dflags = do return preload -- | Sets the program 'DynFlags'. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId] +setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] setProgramDynFlags dflags = do dflags' <- checkNewDynFlags dflags (dflags'', preload) <- liftIO $ initPackages dflags' @@ -1435,7 +1435,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [UnitId]) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [InstalledUnitId]) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 998d68c11a..0921a58531 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1916,7 +1916,8 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name required_by_imports <- implicitRequirements hsc_env the_imps - return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, + return (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index cd8b56843f..ae6ad7d068 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -179,7 +179,7 @@ newHscEnv dflags = do eps_var <- newIORef initExternalPackageState us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us allKnownKeyNames) - fc_var <- newIORef emptyModuleEnv + fc_var <- newIORef emptyInstalledModuleEnv #ifdef GHCI iserv_mvar <- newMVar Nothing #endif @@ -444,12 +444,14 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do let hsc_src = ms_hsc_src mod_summary dflags = hsc_dflags hsc_env outer_mod = ms_mod mod_summary - inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) + mod_name = moduleName outer_mod + outer_mod' = mkModule (thisPackage dflags) mod_name + inner_mod = canonicalizeHomeModule dflags mod_name src_filename = ms_hspp_file mod_summary real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 MASSERT( moduleUnitId outer_mod == thisPackage dflags ) if hsc_src == HsigFile && not (isHoleModule inner_mod) - then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod real_loc + then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else do hpm <- case mb_rdr_module of Just hpm -> return hpm @@ -1021,7 +1023,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyBag errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [UnitId]) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [InstalledUnitId]) hscGetSafe hsc_env m l = runHsc hsc_env $ do dflags <- getDynFlags (self, pkgs) <- hscCheckSafe' dflags m l @@ -1035,15 +1037,17 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- Return (regardless of trusted or not) if the trust type requires the modules -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. -hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe UnitId, [UnitId]) +hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, [InstalledUnitId]) hscCheckSafe' dflags m l = do (tw, pkgs) <- isModSafe m l case tw of False -> return (Nothing, pkgs) True | isHomePkg m -> return (Nothing, pkgs) - | otherwise -> return (Just $ moduleUnitId m, pkgs) + -- TODO: do we also have to check the trust of the instantiation? + -- Not necessary if that is reflected in dependencies + | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs) where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, [UnitId]) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, [InstalledUnitId]) isModSafe m l = do iface <- lookup' m case iface of @@ -1123,7 +1127,7 @@ hscCheckSafe' dflags m l = do | otherwise = False -- | Check the list of packages are trusted. -checkPkgTrust :: DynFlags -> [UnitId] -> Hsc () +checkPkgTrust :: DynFlags -> [InstalledUnitId] -> Hsc () checkPkgTrust dflags pkgs = case errors of [] -> return () @@ -1131,7 +1135,7 @@ checkPkgTrust dflags pkgs = where errors = catMaybes $ map go pkgs go pkg - | trusted $ getPackageDetails dflags pkg + | trusted $ getInstalledPackageDetails dflags pkg = Nothing | otherwise = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags) diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index c2d2938b45..1320a57e9a 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -10,7 +10,7 @@ module HscTypes ( -- * compilation state HscEnv(..), hscEPS, - FinderCache, FindResult(..), + FinderCache, FindResult(..), InstalledFindResult(..), Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, HscStatus(..), @@ -26,7 +26,7 @@ module HscTypes ( ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ImportedModsVal(..), - ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary, + ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, SourceModified(..), @@ -771,16 +771,18 @@ prepareAnnotations hsc_env mb_guts = do -- modules along the search path. On @:load@, we flush the entire -- contents of this cache. -- --- Although the @FinderCache@ range is 'FindResult' for convenience, --- in fact it will only ever contain 'Found' or 'NotFound' entries. --- -type FinderCache = VirginModuleEnv FindResult +type FinderCache = InstalledModuleEnv InstalledFindResult + +data InstalledFindResult + = InstalledFound ModLocation InstalledModule + | InstalledNoPackage InstalledUnitId + | InstalledNotFound [FilePath] (Maybe InstalledUnitId) -- | The result of searching for an imported module. -- -- NB: FindResult manages both user source-import lookups -- (which can result in 'Module') as well as direct imports --- for interfaces (which always result in 'VirginModule'). +-- for interfaces (which always result in 'InstalledModule'). data FindResult = Found ModLocation Module -- ^ The module was found @@ -1272,8 +1274,8 @@ data CgGuts -- as part of the code-gen of tycons cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to - -- generate #includes for C code gen + cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to + -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks) -- ^ Module breakpoints } @@ -2240,7 +2242,7 @@ data Dependencies -- I.e. modules that this one imports, or that are in the -- dep_mods of those directly-imported modules - , dep_pkgs :: [(UnitId, Bool)] + , dep_pkgs :: [(InstalledUnitId, Bool)] -- ^ All packages transitively below this module -- I.e. packages to which this module's direct imports belong, -- or that are in the dep_pkgs of those modules @@ -2449,7 +2451,7 @@ data ExternalPackageState -- -- * Deprecations and warnings - eps_free_holes :: ModuleEnv (UniqDSet ModuleName), + eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on -- the 'eps_PIT' for this information, EXCEPT that when -- we do dependency analysis, we need to look at the @@ -2602,6 +2604,9 @@ data ModSummary -- ^ The actual preprocessed source, if we have it } +ms_installed_mod :: ModSummary -> InstalledModule +ms_installed_mod = fst . splitModuleInsts . ms_mod + ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index f16c902a7e..6e3e2f1c9b 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -12,6 +12,8 @@ module PackageConfig ( -- * UnitId packageConfigId, expandedPackageConfigId, + definitePackageConfigId, + installedPackageConfigId, -- * The PackageConfig type: information about a package PackageConfig, @@ -35,6 +37,7 @@ import FastString import Outputable import Module import Unique +import UniqDSet -- ----------------------------------------------------------------------------- -- Our PackageConfig type is the InstalledPackageInfo from ghc-boot, @@ -44,7 +47,7 @@ type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName - Module.UnitId + Module.InstalledUnitId Module.UnitId Module.ModuleName Module.Module @@ -129,11 +132,21 @@ pprPackageConfig InstalledPackageInfo {..} = -- version is, so these are handled specially; see #wired_in_packages#. -- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' +installedPackageConfigId :: PackageConfig -> InstalledUnitId +installedPackageConfigId = unitId + packageConfigId :: PackageConfig -> UnitId -packageConfigId = unitId +packageConfigId p = + if indefinite p + then newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p) + else DefiniteUnitId (DefUnitId (unitId p)) expandedPackageConfigId :: PackageConfig -> UnitId expandedPackageConfigId p = - case instantiatedWith p of - [] -> packageConfigId p - _ -> newUnitId (unitIdComponentId (packageConfigId p)) (instantiatedWith p) + newUnitId (installedUnitIdComponentId (unitId p)) (instantiatedWith p) + +definitePackageConfigId :: PackageConfig -> Maybe DefUnitId +definitePackageConfigId p = + case packageConfigId p of + DefiniteUnitId def_uid -> Just def_uid + _ -> Nothing diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 3003e015b6..566d998899 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -20,11 +20,12 @@ module Packages ( -- * Querying the package config lookupPackage, lookupPackage', + lookupInstalledPackage, lookupPackageName, - lookupComponentId, improveUnitId, searchPackageId, getPackageDetails, + getInstalledPackageDetails, componentIdString, listVisibleModuleNames, lookupModuleInAllPackages, @@ -65,6 +66,7 @@ import DynFlags import Name ( Name, nameModule_maybe ) import UniqFM import UniqDFM +import UniqSet import Module import Util import Panic @@ -238,12 +240,18 @@ originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False --- | 'UniqFM' map from 'UnitId' -type UnitIdMap = UniqDFM - --- | 'UniqFM' map from 'UnitId' to 'PackageConfig' --- (newtyped so we can put it in boot.) -newtype PackageConfigMap = PackageConfigMap { unPackageConfigMap :: UnitIdMap PackageConfig } +-- | 'UniqFM' map from 'InstalledUnitId' +type InstalledUnitIdMap = UniqDFM + +-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus +-- the transitive closure of preload packages. +data PackageConfigMap = PackageConfigMap { + unPackageConfigMap :: InstalledUnitIdMap PackageConfig, + -- | The set of transitively reachable packages according + -- to the explicitly provided command line arguments. + -- See Note [UnitId to InstalledUnitId improvement] + preloadClosure :: UniqSet InstalledUnitId + } -- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. type VisibilityMap = Map UnitId UnitVisibility @@ -294,6 +302,9 @@ instance Monoid UnitVisibility where , uv_explicit = uv_explicit uv1 || uv_explicit uv2 } +type WiredUnitId = DefUnitId +type PreloadUnitId = InstalledUnitId + -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons -- (since this is the slow path, we'll just look it up again). @@ -314,12 +325,12 @@ data PackageState = PackageState { -- | A mapping from wired in names to the original names from the -- package database. - unwireMap :: Map UnitId UnitId, + unwireMap :: Map WiredUnitId WiredUnitId, -- | The packages we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a package -- is always mentioned before the packages it depends on. - preloadPackages :: [UnitId], + preloadPackages :: [PreloadUnitId], -- | Packages which we explicitly depend on (from a command line flag). -- We'll use this to generate version macros. @@ -355,11 +366,11 @@ emptyPackageState = PackageState { requirementContext = Map.empty } -type InstalledPackageIndex = Map UnitId PackageConfig +type InstalledPackageIndex = Map InstalledUnitId PackageConfig -- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap -emptyPackageConfigMap = PackageConfigMap emptyUDFM +emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet -- | Find the package we know about with the given unit id, if any lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig @@ -370,14 +381,15 @@ lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState -- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can -- be used while we're initializing 'DynFlags' lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig -lookupPackage' False (PackageConfigMap pkg_map) uid = lookupUDFM pkg_map uid -lookupPackage' True (PackageConfigMap pkg_map) uid = +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 (PackageConfigMap pkg_map) insts) + fmap (renamePackage m insts) (lookupUDFM pkg_map iuid) (_, Nothing) -> lookupUDFM pkg_map uid +{- -- | Find the indefinite package for a given 'ComponentId'. -- The way this works is just by fiat'ing that every indefinite package's -- unit key is precisely its component ID; and that they share uniques. @@ -385,6 +397,7 @@ lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs where PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) +-} -- | Find the package we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this) @@ -399,12 +412,12 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) -- | Extends the package configuration map with a list of package configs. extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap (PackageConfigMap pkg_map) new_pkgs - = PackageConfigMap (foldl add pkg_map new_pkgs) +extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs + = PackageConfigMap (foldl add pkg_map new_pkgs) closure -- We also add the expanded version of the packageConfigId, so that -- 'improveUnitId' can find it. where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) - (packageConfigId p) p + (installedPackageConfigId p) p -- | Looks up the package with the given id in the package state, panicing if it is -- not found @@ -412,6 +425,17 @@ getPackageDetails :: DynFlags -> UnitId -> PackageConfig getPackageDetails dflags pid = expectJust "getPackageDetails" (lookupPackage dflags pid) +lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig +lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid + +lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig +lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid + +getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig +getInstalledPackageDetails dflags uid = + expectJust "getInstalledPackageDetails" $ + lookupInstalledPackage dflags uid + -- | Get a list of entries from the package database. NB: be careful with -- this function, although all packages in this map are "visible", this -- does not imply that the exposed-modules of the package are available @@ -419,7 +443,7 @@ getPackageDetails dflags pid = listPackageConfigMap :: DynFlags -> [PackageConfig] listPackageConfigMap dflags = eltsUDFM pkg_map where - PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) + PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags) -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -437,7 +461,7 @@ listPackageConfigMap dflags = eltsUDFM pkg_map -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. -initPackages :: DynFlags -> IO (DynFlags, [UnitId]) +initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) initPackages dflags0 = do dflags <- interpretPackageEnv dflags0 pkg_db <- @@ -741,7 +765,7 @@ findPackages pkg_db arg pkgs unusable else Nothing finder (UnitIdArg uid) p = let (iuid, mb_insts) = splitUnitIdInsts uid - in if iuid == packageConfigId p + in if iuid == installedPackageConfigId p then Just (case mb_insts of Nothing -> p Just insts -> renamePackage pkg_db insts p) @@ -765,12 +789,10 @@ renamePackage :: PackageConfigMap -> [(ModuleName, Module)] -> PackageConfig -> PackageConfig renamePackage pkg_map insts conf = let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map hsubst - suid = renameHoleUnitId' pkg_map hsubst - new_uid = suid (unitId conf) + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) in conf { - unitId = new_uid, - depends = map suid (depends conf), + instantiatedWith = new_insts, exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) (exposedModules conf) } @@ -783,12 +805,13 @@ matchingStr str p = str == sourcePackageIdString p || str == packageNameString p -matchingId :: UnitId -> PackageConfig -> Bool -matchingId uid p = uid == packageConfigId p +matchingId :: InstalledUnitId -> PackageConfig -> Bool +matchingId uid p = uid == installedPackageConfigId p matching :: PackageArg -> PackageConfig -> Bool matching (PackageArg str) = matchingStr str -matching (UnitIdArg uid) = matchingId uid +matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case sortByVersion :: [PackageConfig] -> [PackageConfig] sortByVersion = sortBy (flip (comparing packageVersion)) @@ -849,7 +872,7 @@ pprTrustFlag flag = case flag of wired_in_pkgids :: [String] wired_in_pkgids = map unitIdString wiredInUnitIds -type WiredPackagesMap = Map UnitId UnitId +type WiredPackagesMap = Map WiredUnitId WiredUnitId findWiredInPackages :: DynFlags @@ -918,7 +941,7 @@ findWiredInPackages dflags pkgs vis_map = do mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids let wired_in_pkgs = catMaybes mb_wired_in_pkgs - wired_in_ids = map unitId wired_in_pkgs + wired_in_ids = mapMaybe definitePackageConfigId wired_in_pkgs -- this is old: we used to assume that if there were -- multiple versions of wired-in packages installed that @@ -933,30 +956,38 @@ findWiredInPackages dflags pkgs vis_map = do && package p `notElem` map fst wired_in_ids -} - wiredInMap :: Map UnitId UnitId + wiredInMap :: Map WiredUnitId WiredUnitId wiredInMap = foldl' add_mapping Map.empty pkgs where add_mapping m pkg - | let key = unitId pkg + | Just key <- definitePackageConfigId pkg , key `elem` wired_in_ids - = Map.insert key (stringToUnitId (packageNameString pkg)) m + = Map.insert key (DefUnitId (stringToInstalledUnitId (packageNameString pkg))) m | otherwise = m updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs where upd_pkg pkg - | unitId pkg `elem` wired_in_ids + | Just def_uid <- definitePackageConfigId pkg + , def_uid `elem` wired_in_ids = pkg { unitId = let PackageName fs = packageName pkg - in fsToUnitId fs + in fsToInstalledUnitId fs } | otherwise = pkg upd_deps pkg = pkg { - depends = map upd_wired_in (depends pkg), + -- temporary harmless DefUnitId invariant violation + depends = map (unDefUnitId . upd_wired_in . DefUnitId) (depends pkg), exposedModules = map (\(k,v) -> (k, fmap upd_wired_in_mod v)) (exposedModules pkg) } - upd_wired_in_mod (Module uid m) = Module (upd_wired_in uid) m + upd_wired_in_mod (Module uid m) = Module (upd_wired_in_uid uid) m + upd_wired_in_uid (DefiniteUnitId def_uid) = + DefiniteUnitId (upd_wired_in def_uid) + upd_wired_in_uid (IndefiniteUnitId indef_uid) = + IndefiniteUnitId $ newIndefUnitId + (indefUnitIdComponentId indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod y)) (indefUnitIdInsts indef_uid)) upd_wired_in key | Just key' <- Map.lookup key wiredInMap = key' | otherwise = key @@ -966,9 +997,10 @@ findWiredInPackages dflags pkgs vis_map = do updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) - where f vm (from, to) = case Map.lookup from vis_map of + where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of Nothing -> vm - Just r -> Map.insert to r (Map.delete from vm) + Just r -> Map.insert (DefiniteUnitId to) r + (Map.delete (DefiniteUnitId from) vm) -- ---------------------------------------------------------------------------- @@ -976,13 +1008,13 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap type IsShadowed = Bool data UnusablePackageReason = IgnoredWithFlag - | MissingDependencies IsShadowed [UnitId] + | MissingDependencies IsShadowed [InstalledUnitId] instance Outputable UnusablePackageReason where ppr IgnoredWithFlag = text "[ignored with flag]" ppr (MissingDependencies b uids) = brackets (if b then text "shadowed" else empty <+> ppr uids) -type UnusablePackages = Map UnitId +type UnusablePackages = Map InstalledUnitId (PackageConfig, UnusablePackageReason) pprReason :: SDoc -> UnusablePackageReason -> SDoc @@ -1014,7 +1046,7 @@ reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) -- findBroken :: IsShadowed -> [PackageConfig] - -> Map UnitId PackageConfig + -> Map InstalledUnitId PackageConfig -> UnusablePackages findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs where @@ -1031,7 +1063,7 @@ findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs depsAvailable :: InstalledPackageIndex -> PackageConfig - -> Either PackageConfig (PackageConfig, [UnitId]) + -> Either PackageConfig (PackageConfig, [InstalledUnitId]) depsAvailable pkg_map pkg | null dangling = Left pkg | otherwise = Right (pkg, dangling) @@ -1058,9 +1090,9 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) mkPackageState :: DynFlags -> [(FilePath, [PackageConfig])] -- initial databases - -> [UnitId] -- preloaded packages + -> [PreloadUnitId] -- preloaded packages -> IO (PackageState, - [UnitId]) -- new packages to preload + [PreloadUnitId]) -- new packages to preload mkPackageState dflags dbs preload0 = do -- Compute the unit id @@ -1138,7 +1170,7 @@ mkPackageState dflags dbs preload0 = do `Map.union` unusable) where -- The set of UnitIds which appear in both -- db and pkgs (to be shadowed from pkgs) - shadow_set :: Set UnitId + shadow_set :: Set InstalledUnitId shadow_set = foldr ins Set.empty db where ins pkg s -- If the package from the upper database is @@ -1180,7 +1212,7 @@ mkPackageState dflags dbs preload0 = do -- Now merge the sets together (NB: later overrides -- earlier!) - pkg_map' :: Map UnitId PackageConfig + pkg_map' :: Map InstalledUnitId PackageConfig pkg_map' = mk_pkg_map (shadowed_pkgs ++ db3) (pkg_map1, unusable) <- foldM merge (Map.empty, Map.empty) dbs @@ -1309,7 +1341,7 @@ mkPackageState dflags dbs preload0 = do $ (basicLinkedPackages ++ preload2) -- Close the preload packages with their dependencies - dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing)) + dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map @@ -1333,8 +1365,9 @@ mkPackageState dflags dbs preload0 = do -- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' -- that it was recorded as in the package database. unwireUnitId :: DynFlags -> UnitId -> UnitId -unwireUnitId dflags uid = - fromMaybe uid (Map.lookup uid (unwireMap (pkgState dflags))) +unwireUnitId dflags uid@(DefiniteUnitId def_uid) = + maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) +unwireUnitId _ uid = uid -- ----------------------------------------------------------------------------- -- | Makes the mapping from module to package info @@ -1415,7 +1448,7 @@ mkModuleToPkgConfAll dflags pkg_db vis_map = -- use. -- | Find all the include directories in these and the preload packages -getPackageIncludePath :: DynFlags -> [UnitId] -> IO [String] +getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs @@ -1423,7 +1456,7 @@ collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages -getPackageLibraryPath :: DynFlags -> [UnitId] -> IO [String] +getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageLibraryPath dflags pkgs = collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs @@ -1432,7 +1465,7 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) -getPackageLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String]) +getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs @@ -1481,19 +1514,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages -getPackageExtraCcOpts :: DynFlags -> [UnitId] -> IO [String] +getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageExtraCcOpts dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap ccOptions ps) -- | Find all the package framework paths in these and the preload packages -getPackageFrameworkPath :: DynFlags -> [UnitId] -> IO [String] +getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageFrameworkPath dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (nub (filter notNull (concatMap frameworkDirs ps))) -- | Find all the package frameworks in these and the preload packages -getPackageFrameworks :: DynFlags -> [UnitId] -> IO [String] +getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] getPackageFrameworks dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap frameworks ps) @@ -1616,7 +1649,7 @@ listVisibleModuleNames dflags = -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's -getPreloadPackagesAnd :: DynFlags -> [UnitId] -> IO [PackageConfig] +getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = let state = pkgState dflags @@ -1625,14 +1658,14 @@ getPreloadPackagesAnd dflags pkgids = pairs = zip pkgids (repeat Nothing) in do all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) - return (map (getPackageDetails dflags) all_pkgs) + return (map (getInstalledPackageDetails 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 - -> [(UnitId, Maybe UnitId)] - -> IO [UnitId] + -> [(InstalledUnitId, Maybe InstalledUnitId)] + -> IO [InstalledUnitId] closeDeps dflags pkg_map ps = throwErr dflags (closeDepsErr dflags pkg_map ps) @@ -1644,20 +1677,20 @@ throwErr dflags m closeDepsErr :: DynFlags -> PackageConfigMap - -> [(UnitId,Maybe UnitId)] - -> MaybeErr MsgDoc [UnitId] + -> [(InstalledUnitId,Maybe InstalledUnitId)] + -> MaybeErr MsgDoc [InstalledUnitId] closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps -- internal helper add_package :: DynFlags -> PackageConfigMap - -> [UnitId] - -> (UnitId,Maybe UnitId) - -> MaybeErr MsgDoc [UnitId] + -> [PreloadUnitId] + -> (PreloadUnitId,Maybe PreloadUnitId) + -> MaybeErr MsgDoc [PreloadUnitId] add_package dflags pkg_db ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = - case lookupPackage' (isIndefinite dflags) pkg_db p of + case lookupInstalledPackage' pkg_db p of Nothing -> Failed (missingPackageMsg p <> missingDependencyMsg mb_parent) Just pkg -> do @@ -1671,19 +1704,19 @@ add_package dflags pkg_db ps (p, mb_parent) missingPackageMsg :: Outputable pkgid => pkgid -> SDoc missingPackageMsg p = text "unknown package:" <+> ppr p -missingDependencyMsg :: Maybe UnitId -> SDoc +missingDependencyMsg :: Maybe InstalledUnitId -> SDoc missingDependencyMsg Nothing = Outputable.empty missingDependencyMsg (Just parent) - = space <> parens (text "dependency of" <+> ftext (unitIdFS parent)) + = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) -- ----------------------------------------------------------------------------- componentIdString :: DynFlags -> ComponentId -> Maybe String componentIdString dflags cid = - fmap sourcePackageIdString (lookupComponentId dflags cid) + fmap sourcePackageIdString (lookupInstalledPackage dflags (newInstalledUnitId cid Nothing)) -- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool +isDllName :: DynFlags -> UnitId {- not used -} -> Module -> Name -> Bool -- Despite the "dll", I think this function just means that -- the symbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows @@ -1732,7 +1765,7 @@ pprPackagesWith pprIPI dflags = -- be different from the package databases (exposure, trust) pprPackagesSimple :: DynFlags -> SDoc pprPackagesSimple = pprPackagesWith pprIPI - where pprIPI ipi = let i = unitIdFS (unitId ipi) + where pprIPI ipi = let i = installedUnitIdFS (unitId 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 @@ -1752,13 +1785,20 @@ fsPackageName :: PackageConfig -> FastString fsPackageName = mkFastString . packageNameString -- | Given a fully instantiated 'UnitId', improve it into a --- 'HashedUnitId' if we can find it in the package database. +-- 'InstalledUnitId' if we can find it in the package database. improveUnitId :: PackageConfigMap -> UnitId -> UnitId +improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit improveUnitId pkg_map uid = -- Do NOT lookup indefinite ones, they won't be useful! case lookupPackage' False pkg_map uid of Nothing -> uid - Just pkg -> packageConfigId pkg -- use the hashed version! + Just pkg -> + -- Do NOT improve if the indefinite unit id is not + -- part of the closure unique set. See + -- Note [UnitId to InstalledUnitId improvement] + if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map + then packageConfigId pkg + else uid -- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used -- in the @hs-boot@ loop-breaker. diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index e40b1d679f..e901bde06e 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -1564,7 +1564,7 @@ linesPlatform xs = #endif -linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO () +linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () linkDynLib dflags0 o_files dep_packages = do let -- This is a rather ugly hack to fix dynamically linked @@ -1741,7 +1741,7 @@ linkDynLib dflags0 o_files dep_packages ++ map Option pkg_link_opts ) -getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String] +getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String] getPkgFrameworkOpts dflags platform dep_packages | platformUsesFrameworks platform = do pkg_framework_path_opts <- do diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index e1258a3d0d..70c6b5fcad 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -358,6 +358,7 @@ calculateAvails dflags iface mod_safe' want_boot = | otherwise = dep_finsts deps pkg = moduleUnitId (mi_module iface) + ipkg = toInstalledUnitId pkg -- Does this import mean we now require our own pkg -- to be trusted? See Note [Trust Own Package] @@ -382,9 +383,9 @@ calculateAvails dflags iface mod_safe' want_boot = -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)) - , ppr pkg <+> ppr (dep_pkgs deps) ) - ([], (pkg, False) : dep_pkgs deps, False) + ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps)) + , ppr ipkg <+> ppr (dep_pkgs deps) ) + ([], (ipkg, False) : dep_pkgs deps, False) in ImportAvails { imp_mods = emptyModuleEnv, -- this gets filled in later diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index be24423123..9b4f77472d 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -223,7 +223,7 @@ findExtraSigImports' hsc_env HsigFile modname = (initIfaceLoad hsc_env . withException $ moduleFreeHolesPrecise (text "findExtraSigImports") - (mkModule (AnIndefUnitId iuid) mod_name))) + (mkModule (IndefiniteUnitId iuid) mod_name))) where reqs = requirementMerges (hsc_dflags hsc_env) modname @@ -269,7 +269,7 @@ implicitRequirements' hsc_env normal_imports -- not; a component may have been filled with implementations for the holes -- that don't actually fulfill the requirements. -- --- INVARIANT: the UnitId is NOT a HashedUnitId +-- INVARIANT: the UnitId is NOT a InstalledUnitId checkUnitId :: UnitId -> TcM () checkUnitId uid = do case splitUnitIdInsts uid of @@ -354,9 +354,7 @@ mergeSignatures lcl_iface0 = do fmap fst . withException . flip (findAndReadIface (text "mergeSignatures")) False - -- Blegh, temporarily violated invariant that hashed unit - -- ids are definite - $ mkModule (newSimpleUnitId (indefUnitIdComponentId iuid)) mod_name + $ fst (splitModuleInsts (mkModule (IndefiniteUnitId iuid) mod_name)) -- STEP 3: Get the unrenamed exports of all these interfaces, and -- dO shaping on them. @@ -478,8 +476,7 @@ tcRnInstantiateSignature hsc_env this_mod real_loc = -- explicitly.) checkImplements :: Module -> HoleModule -> TcRn TcGblEnv checkImplements impl_mod (uid, mod_name) = do - let cid = indefUnitIdComponentId uid - insts = indefUnitIdInsts uid + let insts = indefUnitIdInsts uid -- STEP 1: Load the implementing interface, and make a RdrEnv -- for its exports @@ -493,7 +490,7 @@ checkImplements impl_mod (uid, mod_name) = do -- the ORIGINAL signature. We are going to eventually rename it, -- but we must proceed slowly, because it is NOT known if the -- instantiation is correct. - let isig_mod = mkModule (newSimpleUnitId cid) mod_name + let isig_mod = fst (splitModuleInsts (mkModule (IndefiniteUnitId uid) mod_name)) mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod False isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index ff51891b8a..e24305dcf3 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -2471,7 +2471,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , text "Dependent modules:" <+> pprUDFM (imp_dep_mods imports) ppr , text "Dependent packages:" <+> - ppr (sortBy stableUnitIdCmp $ imp_dep_pkgs imports)] + ppr (sortBy compare $ imp_dep_pkgs imports)] where -- The use of sortBy is just to reduce unnecessary -- wobbling in testsuite output diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 2a55b695e8..39707b8944 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1171,12 +1171,12 @@ data ImportAvails -- compiling M might not need to consult X.hi, but X -- is still listed in M's dependencies. - imp_dep_pkgs :: [UnitId], + imp_dep_pkgs :: [InstalledUnitId], -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. - imp_trust_pkgs :: [UnitId], + imp_trust_pkgs :: [InstalledUnitId], -- ^ This is strictly a subset of imp_dep_pkgs and records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index e3a56d6a06..3cc3f5c575 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -54,7 +54,8 @@ import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName, hsc_dflags, msObjFilePath ) import Module import Name -import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag ) +import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, + listVisibleModuleNames, pprFlag ) import PprTyThing import PrelNames import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName ) @@ -2056,7 +2057,7 @@ isSafeModule m = do tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], []) | otherwise = partition part deps - where part pkg = trusted $ getPackageDetails dflags pkg + where part pkg = trusted $ getInstalledPackageDetails dflags pkg ----------------------------------------------------------------------------- -- :browse diff --git a/ghc/Main.hs b/ghc/Main.hs index 9fda91979c..f8049d668c 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -60,7 +60,7 @@ import MonadUtils ( liftIO ) -- Imports for --abi-hash import LoadIface ( loadUserInterface ) import Module ( mkModuleName ) -import Finder ( findImportedModule, cannotFindInterface ) +import Finder ( findImportedModule, cannotFindModule ) import TcRnMonad ( initIfaceCheck ) import Binary ( openBinMem, put_, fingerprintBinMem ) @@ -890,7 +890,7 @@ abiHash strs = do case r of Found _ m -> return m _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ - cannotFindInterface dflags modname r + cannotFindModule dflags modname r mods <- mapM find_it strs diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs index 2e51af0dcb..eda1a696ca 100644 --- a/libraries/ghc-boot/GHC/PackageDb.hs +++ b/libraries/ghc-boot/GHC/PackageDb.hs @@ -92,6 +92,7 @@ data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulenam haddockHTMLs :: [FilePath], exposedModules :: [(modulename, Maybe mod)], hiddenModules :: [modulename], + indefinite :: Bool, exposed :: Bool, trusted :: Bool } @@ -139,7 +140,7 @@ data DbUnitId compid unitid modulename mod dbUnitIdComponentId :: compid, dbUnitIdInsts :: [(modulename, mod)] } - | DbHashedUnitId { + | DbInstalledUnitId { dbUnitIdComponentId :: compid, dbUnitIdHash :: Maybe BS.ByteString } @@ -175,6 +176,7 @@ emptyInstalledPackageInfo = haddockHTMLs = [], exposedModules = [], hiddenModules = [], + indefinite = False, exposed = False, trusted = False } @@ -313,7 +315,7 @@ instance (RepInstalledPackageInfo a b c d e f g) => includes includeDirs haddockInterfaces haddockHTMLs exposedModules hiddenModules - exposed trusted) = do + indefinite exposed trusted) = do put (toStringRep sourcePackageId) put (toStringRep packageName) put packageVersion @@ -338,6 +340,7 @@ instance (RepInstalledPackageInfo a b c d e f g) => put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod)) exposedModules) put (map toStringRep hiddenModules) + put indefinite put exposed put trusted @@ -364,6 +367,7 @@ instance (RepInstalledPackageInfo a b c d e f g) => haddockHTMLs <- get exposedModules <- get hiddenModules <- get + indefinite <- get exposed <- get trusted <- get return (InstalledPackageInfo @@ -384,7 +388,7 @@ instance (RepInstalledPackageInfo a b c d e f g) => (fromStringRep mod_name, fmap fromDbModule mb_mod)) exposedModules) (map fromStringRep hiddenModules) - exposed trusted) + indefinite exposed trusted) instance (BinaryStringRep modulename, BinaryStringRep compid, DbUnitIdModuleRep compid unitid modulename mod) => @@ -409,7 +413,7 @@ instance (BinaryStringRep modulename, BinaryStringRep compid, instance (BinaryStringRep modulename, BinaryStringRep compid, DbUnitIdModuleRep compid unitid modulename mod) => Binary (DbUnitId compid unitid modulename mod) where - put (DbHashedUnitId cid hash) = do + put (DbInstalledUnitId cid hash) = do putWord8 0 put (toStringRep cid) put hash @@ -423,7 +427,7 @@ instance (BinaryStringRep modulename, BinaryStringRep compid, 0 -> do cid <- get hash <- get - return (DbHashedUnitId (fromStringRep cid) hash) + return (DbInstalledUnitId (fromStringRep cid) hash) _ -> do dbUnitIdComponentId <- get dbUnitIdInsts <- get diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/.gitignore b/testsuite/tests/backpack/cabal/bkpcabal01/.gitignore new file mode 100644 index 0000000000..1c08f2f992 --- /dev/null +++ b/testsuite/tests/backpack/cabal/bkpcabal01/.gitignore @@ -0,0 +1,2 @@ +p/P.hs +q/Q.hs diff --git a/testsuite/tests/cabal/cabal05/cabal05.stderr b/testsuite/tests/cabal/cabal05/cabal05.stderr index b38f3a5301..eb51115ab0 100644 --- a/testsuite/tests/cabal/cabal05/cabal05.stderr +++ b/testsuite/tests/cabal/cabal05/cabal05.stderr @@ -1,5 +1,5 @@ T.hs:3:1: error: - Ambiguous interface for ‘Conflict’: + Ambiguous module name ‘Conflict’: it is bound as p-0.1.0.0:P2 by a reexport in package p-0.1.0.0 it is bound as P by a reexport in package p-0.1.0.0 diff --git a/testsuite/tests/cabal/ghcpkg01.stdout b/testsuite/tests/cabal/ghcpkg01.stdout index d7b35b7f88..7077b3507b 100644 --- a/testsuite/tests/cabal/ghcpkg01.stdout +++ b/testsuite/tests/cabal/ghcpkg01.stdout @@ -16,6 +16,7 @@ description: category: none author: simonmar@microsoft.com exposed: True +indefinite: False exposed-modules: A hidden-modules: B C.D @@ -42,6 +43,7 @@ description: category: none author: simonmar@microsoft.com exposed: True +indefinite: False exposed-modules: A hidden-modules: B C.D @@ -74,6 +76,7 @@ description: category: none author: simonmar@microsoft.com exposed: False +indefinite: False exposed-modules: A hidden-modules: B C.D C.E @@ -100,6 +103,7 @@ description: category: none author: simonmar@microsoft.com exposed: False +indefinite: False exposed-modules: A hidden-modules: B C.D C.E @@ -126,6 +130,7 @@ description: category: none author: simonmar@microsoft.com exposed: True +indefinite: False exposed-modules: A hidden-modules: B C.D @@ -159,6 +164,7 @@ description: category: none author: simonmar@microsoft.com exposed: False +indefinite: False exposed-modules: A hidden-modules: B C.D diff --git a/testsuite/tests/cabal/ghcpkg04.stderr b/testsuite/tests/cabal/ghcpkg04.stderr index b601f3e706..5cc97f573f 100644 --- a/testsuite/tests/cabal/ghcpkg04.stderr +++ b/testsuite/tests/cabal/ghcpkg04.stderr @@ -1,4 +1,4 @@ ghcpkg04.hs:1:1: error: - Ambiguous interface for ‘A’: - it was found in multiple packages: testpkg-1.2.3.4 newtestpkg-2.0 + Ambiguous module name ‘A’: + it was found in multiple packages: newtestpkg-2.0 testpkg-1.2.3.4 diff --git a/testsuite/tests/driver/driver063.stderr b/testsuite/tests/driver/driver063.stderr index 84ff5b6dbb..307467b27b 100644 --- a/testsuite/tests/driver/driver063.stderr +++ b/testsuite/tests/driver/driver063.stderr @@ -1,4 +1,4 @@ D063.hs:2:1: error: - Failed to load interface for ‘A063’ + Could not find module ‘A063’ It is not a module in the current program, or in any known package. diff --git a/testsuite/tests/ghc-e/should_run/T2636.stderr b/testsuite/tests/ghc-e/should_run/T2636.stderr index 1a7912735c..bf73e40e77 100644 --- a/testsuite/tests/ghc-e/should_run/T2636.stderr +++ b/testsuite/tests/ghc-e/should_run/T2636.stderr @@ -1,4 +1,4 @@ T2636.hs:1:1: error: - Failed to load interface for ‘MissingModule’ + Could not find module ‘MissingModule’ Use -v to see a list of the files searched for. diff --git a/testsuite/tests/module/mod1.stderr b/testsuite/tests/module/mod1.stderr index ecc147513d..50554ae4c6 100644 --- a/testsuite/tests/module/mod1.stderr +++ b/testsuite/tests/module/mod1.stderr @@ -1,4 +1,4 @@ -mod1.hs:3:1: - Failed to load interface for ‘N’ +mod1.hs:3:1: error: + Could not find module ‘N’ Use -v to see a list of the files searched for. diff --git a/testsuite/tests/module/mod2.stderr b/testsuite/tests/module/mod2.stderr index 32522890ba..a070917fc4 100644 --- a/testsuite/tests/module/mod2.stderr +++ b/testsuite/tests/module/mod2.stderr @@ -1,4 +1,4 @@ -mod2.hs:3:1: - Failed to load interface for ‘N’ +mod2.hs:3:1: error: + Could not find module ‘N’ Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package01e.stderr b/testsuite/tests/package/package01e.stderr index ea5f2f6975..f34ee1dd8f 100644 --- a/testsuite/tests/package/package01e.stderr +++ b/testsuite/tests/package/package01e.stderr @@ -1,10 +1,10 @@ package01e.hs:2:1: error: - Failed to load interface for ‘Data.Map’ + Could not find module ‘Data.Map’ It is a member of the hidden package ‘containers-0.5.7.1’. Use -v to see a list of the files searched for. package01e.hs:3:1: error: - Failed to load interface for ‘Data.IntMap’ + Could not find module ‘Data.IntMap’ It is a member of the hidden package ‘containers-0.5.7.1’. Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package06e.stderr b/testsuite/tests/package/package06e.stderr index 1cb27e342c..c634d2d46c 100644 --- a/testsuite/tests/package/package06e.stderr +++ b/testsuite/tests/package/package06e.stderr @@ -1,10 +1,10 @@ -package06e.hs:2:1: - Failed to load interface for ‘HsTypes’ - It is a member of the hidden package ‘ghc-<VERSION>’. +package06e.hs:2:1: error: + Could not find module ‘HsTypes’ + It is a member of the hidden package ‘ghc-8.1’. Use -v to see a list of the files searched for. -package06e.hs:3:1: - Failed to load interface for ‘UniqFM’ - It is a member of the hidden package ‘ghc-<VERSION>’. +package06e.hs:3:1: error: + Could not find module ‘UniqFM’ + It is a member of the hidden package ‘ghc-8.1’. Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package07e.stderr b/testsuite/tests/package/package07e.stderr index 8de07f99b2..a446a47247 100644 --- a/testsuite/tests/package/package07e.stderr +++ b/testsuite/tests/package/package07e.stderr @@ -1,16 +1,16 @@ package07e.hs:2:1: error: - Failed to load interface for ‘MyHsTypes’ + Could not find module ‘MyHsTypes’ Use -v to see a list of the files searched for. package07e.hs:3:1: error: - Failed to load interface for ‘HsTypes’ + Could not find module ‘HsTypes’ Use -v to see a list of the files searched for. package07e.hs:4:1: error: - Failed to load interface for ‘HsUtils’ + Could not find module ‘HsUtils’ Use -v to see a list of the files searched for. package07e.hs:5:1: error: - Failed to load interface for ‘UniqFM’ + Could not find module ‘UniqFM’ Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package08e.stderr b/testsuite/tests/package/package08e.stderr index c5017350f0..3d8d2321b7 100644 --- a/testsuite/tests/package/package08e.stderr +++ b/testsuite/tests/package/package08e.stderr @@ -1,16 +1,16 @@ package08e.hs:2:1: error: - Failed to load interface for ‘MyHsTypes’ + Could not find module ‘MyHsTypes’ Use -v to see a list of the files searched for. package08e.hs:3:1: error: - Failed to load interface for ‘HsTypes’ + Could not find module ‘HsTypes’ Use -v to see a list of the files searched for. package08e.hs:4:1: error: - Failed to load interface for ‘HsUtils’ + Could not find module ‘HsUtils’ Use -v to see a list of the files searched for. package08e.hs:5:1: error: - Failed to load interface for ‘UniqFM’ + Could not find module ‘UniqFM’ Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package09e.stderr b/testsuite/tests/package/package09e.stderr index 9cd00a2930..3ce28df519 100644 --- a/testsuite/tests/package/package09e.stderr +++ b/testsuite/tests/package/package09e.stderr @@ -1,5 +1,5 @@ -package09e.hs:2:1: - Ambiguous interface for ‘M’: +package09e.hs:2:1: error: + Ambiguous module name ‘M’: it is bound as Data.Set by a package flag it is bound as Data.Map by a package flag diff --git a/testsuite/tests/perf/compiler/parsing001.stderr b/testsuite/tests/perf/compiler/parsing001.stderr index 0f86f7f994..d24d77539b 100644 --- a/testsuite/tests/perf/compiler/parsing001.stderr +++ b/testsuite/tests/perf/compiler/parsing001.stderr @@ -1,4 +1,4 @@ -parsing001.hs:3:1: - Failed to load interface for ‘Wibble’ +parsing001.hs:3:1: error: + Could not find module ‘Wibble’ Use -v to see a list of the files searched for. diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr index 276c723203..d32906e4e5 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr @@ -1,7 +1,7 @@ -SafeLang07.hs:2:14: Warning: +SafeLang07.hs:2:14: warning: -XGeneralizedNewtypeDeriving is not allowed in Safe Haskell; ignoring -XGeneralizedNewtypeDeriving -SafeLang07.hs:15:1: - Failed to load interface for ‘SafeLang07_A’ +SafeLang07.hs:15:1: error: + Could not find module ‘SafeLang07_A’ Use -v to see a list of the files searched for. diff --git a/testsuite/tests/th/T10279.stderr b/testsuite/tests/th/T10279.stderr index 21688ae836..0d23a80877 100644 --- a/testsuite/tests/th/T10279.stderr +++ b/testsuite/tests/th/T10279.stderr @@ -1,8 +1,8 @@ T10279.hs:10:10: error: - Failed to load interface for ‘A’ - no unit id matching ‘rts-1.0’ was found - (This unit ID looks like the source package ID; - the real unit ID is ‘rts’) - In the expression: (rts-1.0:A.Foo) - In an equation for ‘blah’: blah = (rts-1.0:A.Foo) + • Failed to load interface for ‘A’ + no unit id matching ‘rts-1.0’ was found + (This unit ID looks like the source package ID; + the real unit ID is ‘rts’) + • In the expression: (rts-1.0:A.Foo) + In an equation for ‘blah’: blah = (rts-1.0:A.Foo) diff --git a/testsuite/tests/typecheck/should_fail/tcfail082.stderr b/testsuite/tests/typecheck/should_fail/tcfail082.stderr index 4e3d6ce996..841b5c82f6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail082.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail082.stderr @@ -1,12 +1,12 @@ -tcfail082.hs:2:1: - Failed to load interface for ‘Data82’ +tcfail082.hs:2:1: error: + Could not find module ‘Data82’ Use -v to see a list of the files searched for. -tcfail082.hs:3:1: - Failed to load interface for ‘Inst82_1’ +tcfail082.hs:3:1: error: + Could not find module ‘Inst82_1’ Use -v to see a list of the files searched for. -tcfail082.hs:4:1: - Failed to load interface for ‘Inst82_2’ +tcfail082.hs:4:1: error: + Could not find module ‘Inst82_2’ Use -v to see a list of the files searched for. diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 4a72ba7cc6..c0474423de 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1119,6 +1119,7 @@ convertPackageInfoToCacheFormat pkg = GhcPkg.haddockHTMLs = haddockHTMLs pkg, GhcPkg.exposedModules = map convertExposed (exposedModules pkg), GhcPkg.hiddenModules = hiddenModules pkg, + GhcPkg.indefinite = indefinite pkg, GhcPkg.exposed = exposed pkg, GhcPkg.trusted = trusted pkg } @@ -1156,9 +1157,12 @@ instance GhcPkg.DbUnitIdModuleRep ComponentId OpenUnitId ModuleName OpenModule w 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.DbHashedUnitId cid bs) = DefiniteUnitId (DefUnitId (UnitId cid (fmap fromStringRep bs))) + fromDbUnitId (GhcPkg.DbInstalledUnitId cid bs) + = DefiniteUnitId (unsafeMkDefUnitId (UnitId cid (fmap fromStringRep bs))) toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts) - toDbUnitId (DefiniteUnitId (DefUnitId (UnitId cid mb_hash))) = GhcPkg.DbHashedUnitId cid (fmap toStringRep mb_hash) + toDbUnitId (DefiniteUnitId def_uid) + | UnitId cid mb_hash <- unDefUnitId def_uid + = GhcPkg.DbInstalledUnitId cid (fmap toStringRep mb_hash) -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar @@ -1809,8 +1813,9 @@ checkModule :: String -> Validate () checkModule _ _ _ (OpenModuleVar _) = error "Impermissible reexport" checkModule field_name db_stack pkg - (OpenModule (DefiniteUnitId (DefUnitId definingPkgId)) definingModule) = - let mpkg = if definingPkgId == installedUnitId pkg + (OpenModule (DefiniteUnitId def_uid) definingModule) = + let definingPkgId = unDefUnitId def_uid + mpkg = if definingPkgId == installedUnitId pkg then Just pkg else PackageIndex.lookupUnitId ipix definingPkgId in case mpkg of |