[Git][ghc/ghc][wip/fendor/external-unit-db-cache] 3 commits: Add ChangeLog

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: 97447bdf by fendor at 2026-07-16T16:27:29+02:00 Add ChangeLog - - - - - aa5d8115 by fendor at 2026-07-16T16:27:29+02:00 Split State.hs into many more modules - - - - - cead9129 by fendor at 2026-07-16T16:27:29+02:00 Add regression test for #26423 - - - - - 21 changed files: - + changelog.d/unit-index - compiler/GHC/Unit/External/Database.hs - + compiler/GHC/Unit/External/Index.hs - + compiler/GHC/Unit/External/ModuleOrigin.hs - + compiler/GHC/Unit/External/Providers.hs - + compiler/GHC/Unit/External/Query.hs - + compiler/GHC/Unit/External/Substitution.hs - + compiler/GHC/Unit/External/Validate.hs - + compiler/GHC/Unit/External/Visibility.hs - + compiler/GHC/Unit/External/Wired.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/State.hs-boot - compiler/GHC/Unit/Types.hs - compiler/ghc.cabal.in - + testsuite/tests/driver/T26423/Hello.hs - + testsuite/tests/driver/T26423/Makefile - + testsuite/tests/driver/T26423/T26423.hs - + testsuite/tests/driver/T26423/all.T - + testsuite/tests/driver/T26423/test/Test.hs - + testsuite/tests/driver/T26423/test/test.pkg Changes: ===================================== changelog.d/unit-index ===================================== @@ -0,0 +1,14 @@ +section: compiler +synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units +issues: #27500 #26423 +mrs: !16115 + +description: { + The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. + This can lead to excessive memory usage with multiple home units and large package databases. + + Our solution to this problem is deduplicating ``UnitInfo``s globally across the whole ``UnitEnv``. + We store this information in the ``UnitIndex`` which contains data global to all ``UnitState``s. + All processed ``UnitInfo``s and the ``WiredMap`` are stored in there, and in the future, we might + move more fields from ``UnitState`` to ``UnitIndex``. +} ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -14,18 +14,52 @@ module GHC.Unit.External.Database ( lookupExternalUnitDatabases, -- * UnitDatabase (..), + -- * + mergeDatabases, + UnitPrecedenceMap, + sortByPreference, + compareByPreference, + -- * + UnitDbConfig(..), + readOrGetUnitDatabase, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, ) where import GHC.Prelude -import GHC.Data.OsPath -import GHC.Unit.Info -import GHC.Utils.Outputable +import GHC.Driver.DynFlags -import Data.IORef (IORef) +import Control.Monad +import Data.Char +import Data.IORef import Data.IORef qualified as IORef -import Data.Map.Strict +import Data.List (partition, sortBy) +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Ord +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST +import GHC.Platform.ArchOS +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import System.Directory +import System.Environment (getEnv) +import System.FilePath as FilePath -- ---------------------------------------------------------------------------- -- ExternalUnitDatabaseCache @@ -102,3 +136,274 @@ data UnitDatabase unit = UnitDatabase instance (Outputable u) => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each unit, a mapping from uid -> i indicates that this +-- unit was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- units that were defined later on the command line, if there +-- is an ambiguity. +type UnitPrecedenceMap = UniqMap UnitId Int + +-- | Given a list of databases, merge them together, where +-- units with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: Logger -> [UnitDatabase UnitId] + -> IO (UnitInfoMap, UnitPrecedenceMap) +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] + where + merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do + debugTraceMsg logger 2 $ + text "loading package database" <+> ppr db_path + when (logVerbAtLeast logger 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set UnitId + override_set = Set.intersection (nonDetUniqMapToKeySet db_map) + (nonDetUniqMapToKeySet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: UnitInfoMap + pkg_map' = pkg_map `plusUniqMap` db_map + + prec_map' :: UnitPrecedenceMap + prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +data UnitDbConfig = UnitDbConfig + { unitDbConfigFlagsDB :: [PackageDBFlag] + , unitDbConfigProgramName :: String + , unitDbConfigDBName :: FilePath + , unitDbConfigPlatformArchOS :: ArchOS + , unitDbConfigGlobalDB :: FilePath + , unitDbConfigGHCDir :: FilePath + , unitDbConfigDBCache :: ExternalUnitDatabaseCache UnitId + } + +readUnitDatabases :: Logger -> UnitDbConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readOrGetUnitDatabase logger cfg) confs + + +getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg) + let pkgconf = dir </> unitDbConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. +readOrGetUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger cfg conf_file = + readExternalUnitDatabase (unitDbConfigDBCache cfg) conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase (unitDbConfigDBCache cfg) new_db + pure new_db + Just db -> + pure db + +-- | Read the 'UnitDatabase' at the given location. +readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do + isdir <- OsPath.doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- OsPath.doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ show conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ show conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) + pkgroot = OsPath.takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) + proto_pkg_configs + -- + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 + where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename + if cache_exists + then do + debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg logger 2 $ text "There is no package.cache in" + <+> ppr conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg logger 3 $ text "There are no .conf files in" + <+> ppr conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ show conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +mungeUnitInfo :: OsPath -> OsPath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeBytecodeLibFields + . mungeLibDirFields + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) + +mungeLibDirFields :: UnitInfo -> UnitInfo +mungeLibDirFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -0,0 +1,198 @@ +module GHC.Unit.External.Index ( + -- * + UnitIndex, + initUnitIndex, + wiringMap, + unwiringMap, + globalUnits, + setWireMap, + isWireMapEmpty, + addUnitInfoMap, + + -- * + GlobalUnitInfoMap, + lookupGlobalUnitInfoMap, + mkGlobalUnitKey, + + -- * + GlobalUnitKey, + globalUnitKeyFromUnitInfo, + + -- * + updateWiredInUnits, + updateWiredInUnitsInUnitInfo, + upd_wired_in_mod, + -- * + unwireUnit, +) where + +import GHC.Prelude + +import GHC.Data.ShortText qualified as ST +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Wired +import GHC.Unit.Info +import GHC.Unit.Types + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Utils.Outputable + +-- ---------------------------------------------------------------------------- +-- UnitIndex +-- ---------------------------------------------------------------------------- + +data UnitIndex = UnitIndex + { ui_wireMap :: !WiringMap + -- ^ A mapping from database unit keys to wired in unit ids. + , ui_unwireMap :: !UnwiringMap + -- ^ A mapping from wired in unit ids to unit keys from the database. + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: document + } + +wiringMap :: UnitIndex -> UnwiringMap +wiringMap = ui_wireMap + +unwiringMap :: UnitIndex -> WiringMap +unwiringMap = ui_unwireMap + +globalUnits :: UnitIndex -> GlobalUnitInfoMap +globalUnits = ui_unitInfoMap + +initUnitIndex :: UnitIndex +initUnitIndex = UnitIndex + { ui_wireMap = emptyUniqMap + , ui_unwireMap = emptyUniqMap + , ui_unitInfoMap = emptyUniqMap + } + +setWireMap :: WiringMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + } + +isWireMapEmpty :: UnitIndex -> Bool +isWireMapEmpty unit_index = + isNullUniqMap (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) + } + where + globalMap :: GlobalUnitInfoMap + globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map + +-- ---------------------------------------------------------------------------- +-- GlobalUnitInfoMap +-- ---------------------------------------------------------------------------- + +type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) + +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = + case lookupUniqMap globalMap uid of + Nothing -> Nothing + Just sameUnitId -> Map.lookup abiHash sameUnitId + +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap +mkGlobalUnitInfoMap unitInfos = + listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos + +-- ---------------------------------------------------------------------------- +-- GlobalUnitKey +-- ---------------------------------------------------------------------------- + +data GlobalUnitKey = + GlobalUnitKey + !UnitId -- ^ Unit Id of the 'UnitInfo' + !ST.ShortText + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) + +mkGlobalUnitKey :: UnitId -> ST.ShortText -> GlobalUnitKey +mkGlobalUnitKey = GlobalUnitKey + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit' +-- that it was recorded as in the package database. +unwireUnit :: UnitIndex -> Unit -> Unit +unwireUnit state uid@(RealUnit (Definite def_uid)) = + maybe uid (RealUnit . Definite) (lookupUniqMap (unwiringMap state) def_uid) +unwireUnit _ uid = uid + +updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_wired_in_pkg wiredInUnitId pkg = + pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupUniqMap wiredInMap (unitId pkg) of + Just wiredIn -> + case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +upd_wired_in_mod :: WiringMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiringMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WiringMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupUniqMap wiredInMap key = key' + | otherwise = key ===================================== compiler/GHC/Unit/External/ModuleOrigin.hs ===================================== @@ -0,0 +1,110 @@ +module GHC.Unit.External.ModuleOrigin ( + ModuleOrigin(..), + fromExposedModules, + fromReexportedModules, + fromFlag, + originVisible, + originEmpty, +) where + +import GHC.Prelude +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Data.Semigroup as Semigroup + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) rhs)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + g Nothing x = x + g x Nothing = x + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False ===================================== compiler/GHC/Unit/External/Providers.hs ===================================== @@ -0,0 +1,186 @@ +module GHC.Unit.External.Providers ( + ModuleNameProvidersMap, + pprModuleMap, + mkModuleNameProvidersMap, + mkUnusableModuleNameProvidersMap, +) where + +import GHC.Prelude + +import GHC.Data.Maybe +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Query +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.Info +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' + +type ModuleNameProvidersMap = + UniqMap ModuleName (UniqMap Module ModuleOrigin) + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (nonDetUniqMapToList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from ModuleName to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: Logger + -> Bool + -> UnitInfoMap + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap logger allowVirtualUnits pkg_map vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_map is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_map multiple times to the actual + -- ModuleNameProvidersMap. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended + where + vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map + + default_vis = listToUniqMap + [ (mkUnit pkg, mempty) + | (_, pkg) <- nonDetUniqMapToList pkg_map + -- Exclude specific instantiations of an indefinite + -- package + , unitIsIndefinite pkg || null (unitInstantiations pkg) + ] + + emptyMap = emptyUniqMap + setOrigins m os = fmap (const os) m + extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, UniqMap Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, UniqMap Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (renderWithContext + (log_default_user_context (logFlags logger)) + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + (pk', m', fromReexportedModules e pkg) + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = mkUnit pkg + unit_lookup uid = lookupUnit' allowVirtualUnits pkg_map uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = unitExposedModules pkg + hidden_mods = unitHiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap unusables = + nonDetFoldUniqMap extend_modmap emptyUniqMap unusables + where + extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings + where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin_reexport = ModUnusable (UnusableUnit unit reason True) + origin_normal = ModUnusable (UnusableUnit unit reason False) + unit = mkUnit unit_info + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] + + -- with re-exports, c:Foo can be reexported from two (or more) + -- unusable packages: + -- Foo -> a:Foo (unusable reason A) -> c:Foo + -- -> b:Foo (unusable reason B) -> c:Foo + -- + -- We must be careful to not record the following (#21097): + -- Foo -> c:Foo (unusable reason A) + -- -> c:Foo (unusable reason B) + -- But: + -- Foo -> a:Foo (unusable reason A) + -- -> b:Foo (unusable reason B) + -- + get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) + get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) + -- in the reexport case, we create a virtual module that doesn't + -- exist but we don't care as it's only used as a key in the map. + + exposed_mods = unitExposedModules unit_info + hidden_mods = unitHiddenModules unit_info + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) + => UniqMap k1 (UniqMap k2 a) + -> [(k1, UniqMap k2 a)] + -> UniqMap k1 (UniqMap k2 a) +addListTo = foldl' merge + where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v + +-- | Create a singleton module mapping +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin +mkModMap pkg mod = unitUniqMap (mkModule pkg mod) ===================================== compiler/GHC/Unit/External/Query.hs ===================================== @@ -0,0 +1,41 @@ +module GHC.Unit.External.Query ( + -- * + lookupUnit', + lookupUnitId', +) where + +import GHC.Prelude + +import GHC.Types.Unique.Map +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Module + +-- | A more specialized interface, which doesn't require a 'UnitState' (so it +-- can be used while we're initializing 'DynFlags') +-- +-- Parameters: +-- * a boolean specifying whether or not to look for on-the-fly renamed interfaces +-- * a 'UnitInfoMap' +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map u = case u of + HoleUnit -> error "Hole unit" + RealUnit i -> lookupUniqMap pkg_map (unDefinite i) + VirtUnit i + | allowOnTheFlyInst + -> -- lookup UnitInfo of the indefinite unit to be instantiated and + -- instantiate it on-the-fly + fmap (renameUnitInfo pkg_map (instUnitInsts i)) + (lookupUniqMap pkg_map (instUnitInstanceOf i)) + + | otherwise + -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite + -- units. Even if they are real, installed units, they can't use the + -- `RealUnit` constructor (it is reserved for definite units) so we use + -- the `VirtUnit` constructor. + lookupUniqMap pkg_map (virtualUnitId i) + + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnitId' db uid = lookupUniqMap db uid ===================================== compiler/GHC/Unit/External/Substitution.hs ===================================== @@ -0,0 +1,61 @@ +module GHC.Unit.External.Substitution ( + -- * + ShHoleSubst, + renameHoleModule', + renameHoleUnit', + renameUnitInfo, +) where + +import GHC.Prelude + +import GHC.Unit.Module +import GHC.Unit.Info +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.DSet + +-- ----------------------------------------------------------------------------- +-- Module renaming + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Rename a 'UnitInfo' according to some module instantiation. +renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) + in conf { + unitInstantiations = new_insts, + unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (unitExposedModules conf) + } + + +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnit' pkg_map env (moduleUnit m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = <Blah>, that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map env uid = + case uid of + (VirtUnit + InstantiatedUnit{ instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + else mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid ===================================== compiler/GHC/Unit/External/Validate.hs ===================================== @@ -0,0 +1,384 @@ +module GHC.Unit.External.Validate ( + validateDatabase, + + findPackages, + selectPackages, + + UnusableUnits, + reportUnusable, + + UnusableUnit(..), + + UnusableUnitReason(..), + pprReason, + + UnitErr(..), + mayThrowUnitErr, + closeUnitDeps, + closeUnitDeps', + ignoreUnits, + pprFlag, +) where + +import GHC.Prelude + +import Control.Monad +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (partition) +import GHC.Data.Maybe +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.External.Database +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Outputable qualified as Outputable +import GHC.Utils.Panic + +-- ----------------------------------------------------------------------------- +-- Database validation + +-- | Validates a database, removing unusable units from it +-- (this includes removing units that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken units (dangling dependencies) +-- 2. Remove all units that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all units which have deps with mismatching ABIs +-- +validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap + -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) +validateDatabase flagsIgnored pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse flagsIgnored -- (unitConfigFlagsIgnored cfg) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids + ] + + -- Find broken units + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (nonDetEltsUniqMap pkg_map1) + (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive units + sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) + | pkg <- nonDetEltsUniqMap pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) + (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out units whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (nonDetEltsUniqMap pkg_map4) + (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + -- combine all unusables. The order is important for shadowing. + -- plusUniqMapList folds using plusUFM which is right biased (opposite of + -- Data.Map.union) so the head of the list should be the least preferred + unusable = plusUniqMapList [ unusable_shadowed + , unusable_cyclic + , unusable_broken + , unusable_ignored + , directly_ignored + ] + + +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) + +-- | A unusable unit module origin +data UnusableUnit = UnusableUnit + { uuUnit :: !Unit -- ^ Unusable unit + , uuReason :: !UnusableUnitReason -- ^ Reason + , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? + } + +-- | The reason why a unit is unusable. +data UnusableUnitReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This unit transitively depends on a unit that was never present + -- in any of the provided databases. + | BrokenDependencies [UnitId] + -- | This unit transitively depends on a unit involved in a cycle. + -- Note that the list of 'UnitId' reports the direct dependencies + -- of this unit that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [UnitId] + -- | This unit transitively depends on a unit which was ignored. + | IgnoredDependencies [UnitId] + -- | This unit transitively depends on a unit which was + -- shadowed by an ABI-incompatible unit. + | ShadowedDependencies [UnitId] + +instance Outputable UnusableUnitReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +pprReason :: SDoc -> UnusableUnitReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportUnusable :: Logger -> UnusableUnits -> IO () +reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg logger 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ----------------------------------------------------------------------------- +-- Package Finding + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: UnitPrecedenceMap + -> UnitInfoMap + -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + [UnitInfo] +findPackages prec_map pkg_map arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if matchingStr str p + then Just p + else Nothing + finder (UnitIdArg uid) p + = case uid of + RealUnit (Definite iuid) + | iuid == unitId p + -> Just p + VirtUnit inst + | instUnitInstanceOf inst == unitId p + -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) + _ -> Nothing + +selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- ----------------------------------------------------------------------------- +-- Ignore units + +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing unit is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- ---------------------------------------------------------------------------- +-- +-- Closures +-- + + +-- | Takes a list of UnitIds (and their "parent" dependency, used for error +-- messages), and returns the list with dependencies included, in reverse +-- dependency order (a units appears before those it depends on). +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps + +-- | Similar to closeUnitDeps but takes a list of already loaded units as an +-- additional argument. +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps + +-- | Add a UnitId and those it depends on (recursively) to the given list of +-- UnitIds if they are not already in it. Return a list in reverse dependency +-- order (a unit appears before those it depends on). +-- +-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). +-- It it's not found, the optional parent unit is used to return a more precise +-- error message ("dependency of <PARENT>"). +add_unit :: UnitInfoMap + -> [UnitId] + -> UnitId + -> Maybe UnitId + -> MaybeErr UnitErr [UnitId] +add_unit pkg_map ps p mb_parent + | p `elem` ps = return ps -- Check if we've already added this unit + | otherwise = case lookupUnitId' pkg_map p of + Nothing -> Failed (CloseUnitErr p mb_parent) + Just info -> do + -- Add the unit's dependents also + ps' <- foldM add_unit_key ps (unitDepends info) + return (p : ps') + where + add_unit_key xs key + = add_unit pkg_map xs key (Just p) +data UnitErr + = CloseUnitErr !UnitId !(Maybe UnitId) + | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] + | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] + +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a +mayThrowUnitErr = \case + Failed e -> throwGhcExceptionIO + $ CmdLineError + $ renderWithContext defaultSDocContext + $ withPprStyle defaultUserStyle + $ ppr e + Succeeded a -> return a + +instance Outputable UnitErr where + ppr = \case + CloseUnitErr p mb_parent + -> (text "unknown unit:" <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + PackageFlagErr flag reasons + -> flag_err (pprFlag flag) reasons + + TrustFlagErr flag reasons + -> flag_err (pprTrustFlag flag) reasons + where + flag_err flag_doc reasons = + text "cannot satisfy " + <> flag_doc + <> (if null reasons then Outputable.empty else text ": ") + $$ nest 4 (vcat (map ppr_reason reasons) $$ + text "(use -v for more information)") + + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = UniqMap UnitId [UnitId] + +-- | Compute the reverse dependency index of a unit database. +reverseDeps :: UnitInfoMap -> RevIndex +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db + where + go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex + go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = addToUniqMap_C (++) r to [from] + +-- | Given a list of 'UnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those units, plus any units which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removeUnits :: [UnitId] -> RevIndex + -> UnitInfoMap + -> (UnitInfoMap, [UnitInfo]) +removeUnits uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- lookupUniqMap m uid + = case lookupUniqMap index uid of + Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' +-- which correspond to units that do not exist in the index. +depsNotAvailable :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in +-- 'unitAbiDepends' which correspond to units that do not exist, OR have +-- mismatching ABIs. +depsAbiMismatch :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- lookupUniqMap pkg_map dep_uid + = unitAbiHash dep_pkg == abi + | otherwise + = False ===================================== compiler/GHC/Unit/External/Visibility.hs ===================================== @@ -0,0 +1,72 @@ +module GHC.Unit.External.Visibility ( + VisibilityMap, + UnitVisibility(..), +) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.Module +import GHC.Utils.Outputable as Outputable + +import Control.Applicative +import Data.Monoid (First (..)) +import Data.Semigroup qualified as Semigroup +import Data.Set (Set) +import Data.Set qualified as Set + +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = UniqMap Unit UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'Unit'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name associated with the 'Unit'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Maybe PackageArg + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) + , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = emptyUniqMap + , uv_explicit = Nothing + } + mappend = (Semigroup.<>) + ===================================== compiler/GHC/Unit/External/Wired.hs ===================================== @@ -0,0 +1,100 @@ +module GHC.Unit.External.Wired ( + WiringMap, + UnwiringMap, + findWiredInUnits, +) where + +import GHC.Prelude + +import GHC.Data.Maybe +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Database +import GHC.Unit.External.Visibility +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable as Outputable + +type WiringMap = + UniqMap UnitId UnitId + +type UnwiringMap = + UniqMap UnitId UnitId + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +findWiredInUnits + :: Logger + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO WiringMap -- map from unit id to wired identity +findWiredInUnits logger prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Types + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] + where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + + notfound = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (UnitId, UnitInfo) + pick pkg = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (wired_pkg, pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + return wiredInMap ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -5,11 +5,14 @@ module GHC.Unit.Info ( GenericUnitInfo (..) , GenUnitInfo , UnitInfo + , UnitInfoMap , UnitKey (..) , UnitKeyInfo , mkUnitKeyInfo , mapUnitInfo , mkUnitPprInfo + , evaluateUnitInfo + , seqUnitInfo , mkUnit @@ -53,6 +56,8 @@ import Data.Containers.ListUtils (nubOrd) import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix) +import GHC.Types.Unique.Map +import Control.Exception (evaluate) -- | Information about an installed unit @@ -73,6 +78,9 @@ type UnitKeyInfo = GenUnitInfo UnitKey -- UnitId) type UnitInfo = GenUnitInfo UnitId +-- TODO @fendor +type UnitInfoMap = UniqMap UnitId UnitInfo + -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo @@ -250,3 +258,21 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar expandTag t | null t = "" | otherwise = '_':t + +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) + +seqUnitInfo :: UnitInfo -> b -> b +seqUnitInfo ui b = + unitImportDirs ui `seqList` + unitIncludeDirs ui `seqList` + unitLibraryDirs ui `seqList` + unitLibraryBytecodeDirs ui `seqList` + unitExtDepFrameworkDirs ui `seq` + unitHaddockInterfaces ui `seq` + unitHaddockHTMLs ui `seqList` + unitLibraryDynDirs ui `seqList` + unitLibraryDirsStatic ui `seqList` + unitDepends ui `seqList` + unitExposedModules ui `seqList` + b ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Unit.State ( module GHC.Unit.Info, - UnitIndex(..), + UnitIndex, initUnitIndex, setWireMap, isWireMapEmpty, @@ -26,7 +26,6 @@ module GHC.Unit.State ( listUnitInfo, -- * Querying the package config - UnitInfoMap, lookupUnit, lookupUnit', unsafeLookupUnit, @@ -90,50 +89,45 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Unit.Database +import GHC.Unit.Home import GHC.Unit.Info -import GHC.Unit.Ppr -import GHC.Unit.Types import GHC.Unit.Module -import GHC.Unit.Home +import GHC.Unit.Ppr -import GHC.Types.Unique.FM +import GHC.Unit.External.Database +import GHC.Unit.External.Index +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Providers +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.External.Wired + +import GHC.Types.PkgQual import GHC.Types.Unique.DFM -import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM import GHC.Types.Unique.Map -import GHC.Types.Unique -import GHC.Types.PkgQual -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Outputable as Outputable -import GHC.Data.Maybe - -import System.Environment ( getEnv ) import GHC.Data.FastString -import GHC.Data.OsPath ( OsPath ) -import qualified GHC.Data.OsPath as OsPath -import qualified GHC.Data.ShortText as ST -import GHC.Utils.Logger +import GHC.Data.Maybe +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST import GHC.Utils.Error -import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic -import System.Directory -import System.FilePath as FilePath import Control.Monad import Data.Containers.ListUtils (nubOrd) -import Data.Graph (stronglyConnComp, SCC(..)) -import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, sortOn, sort ) -import Data.Set (Set) -import Data.Monoid (First(..)) -import qualified Data.Semigroup as Semigroup -import qualified Data.Set as Set -import Control.Applicative -import GHC.Unit.External.Database -import Data.IORef import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Graph (SCC (..)) +import Data.IORef +import Data.List (intersperse, partition, sort, sortOn) +import Data.Monoid (First (..)) +import Data.Set (Set) +import Data.Set qualified as Set -- --------------------------------------------------------------------------- -- The Unit state @@ -179,162 +173,6 @@ import qualified Data.Map.Strict as Map -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. --- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! -data ModuleOrigin = - -- | Module is hidden, and thus never will be available for import. - -- (But maybe the user didn't realize), so we'll still keep track - -- of these modules.) - ModHidden - - -- | Module is unavailable because the unit is unusable. - | ModUnusable !UnusableUnit - - -- | Module is public, and could have come from some places. - | ModOrigin { - -- | @Just False@ means that this module is in - -- someone's @exported-modules@ list, but that package is hidden; - -- @Just True@ means that it is available; @Nothing@ means neither - -- applies. - fromOrigUnit :: Maybe Bool - -- | Is the module available from a reexport of an exposed package? - -- There could be multiple. - , fromExposedReexport :: [UnitInfo] - -- | Is the module available from a reexport of a hidden package? - , fromHiddenReexport :: [UnitInfo] - -- | Did the module export come from a package flag? (ToDo: track - -- more information. - , fromPackageFlag :: Bool - } - --- | A unusable unit module origin -data UnusableUnit = UnusableUnit - { uuUnit :: !Unit -- ^ Unusable unit - , uuReason :: !UnusableUnitReason -- ^ Reason - , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? - } - -instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" - ppr (ModUnusable _) = text "unusable module" - ppr (ModOrigin e res rhs f) = sep (punctuate comma ( - (case e of - Nothing -> [] - Just False -> [text "hidden package"] - Just True -> [text "exposed package"]) ++ - (if null res - then [] - else [text "reexport by" <+> - sep (map (ppr . mkUnit) res)]) ++ - (if null rhs - then [] - else [text "hidden reexport by" <+> - sep (map (ppr . mkUnit) rhs)]) ++ - (if f then [text "package flag"] else []) - )) - --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False - --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is exposed, and --- also its 'UnitInfo'. -fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False - --- | Smart constructor for a module which was bound by a package flag. -fromFlag :: ModuleOrigin -fromFlag = ModOrigin Nothing [] [] True - -instance Semigroup ModuleOrigin where - x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - g Nothing x = x - g x Nothing = x - - x <> y = pprPanic "ModOrigin: module origin mismatch" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - -instance Monoid ModuleOrigin where - mempty = ModOrigin Nothing [] [] False - mappend = (Semigroup.<>) - --- | Is the name from the import actually visible? (i.e. does it cause --- ambiguity, or is it only relevant when we're making suggestions?) -originVisible :: ModuleOrigin -> Bool -originVisible ModHidden = False -originVisible (ModUnusable _) = False -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f - --- | Are there actually no providers for this module? This will never occur --- except when we're filtering based on package imports. -originEmpty :: ModuleOrigin -> Bool -originEmpty (ModOrigin Nothing [] [] False) = True -originEmpty _ = False - --- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. -type VisibilityMap = UniqMap Unit UnitVisibility - --- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'Unit'. -data UnitVisibility = UnitVisibility - { uv_expose_all :: Bool - -- ^ Should all modules in exposed-modules should be dumped into scope? - , uv_renamings :: [(ModuleName, ModuleName)] - -- ^ Any custom renamings that should bring extra 'ModuleName's into - -- scope. - , uv_package_name :: First FastString - -- ^ The package name associated with the 'Unit'. This is used - -- to implement legacy behavior where @-package foo-0.1@ implicitly - -- hides any packages named @foo@ - , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) - -- ^ The signatures which are contributed to the requirements context - -- from this unit ID. - , uv_explicit :: Maybe PackageArg - -- ^ Whether or not this unit was explicitly brought into scope, - -- as opposed to implicitly via the 'exposed' fields in the - -- package database (when @-hide-all-packages@ is not passed.) - } - -instance Outputable UnitVisibility where - ppr (UnitVisibility { - uv_expose_all = b, - uv_renamings = rns, - uv_package_name = First mb_pn, - uv_requirements = reqs, - uv_explicit = explicit - }) = ppr (b, rns, mb_pn, reqs, explicit) - -instance Semigroup UnitVisibility where - uv1 <> uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) - , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 - } - -instance Monoid UnitVisibility where - mempty = UnitVisibility - { uv_expose_all = False - , uv_renamings = [] - , uv_package_name = First Nothing - , uv_requirements = emptyUniqMap - , uv_explicit = Nothing - } - mappend = (Semigroup.<>) - - -- | Unit configuration data UnitConfig = UnitConfig { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS @@ -422,77 +260,6 @@ initUnitConfig dflags cached_dbs home_units = offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p)) offsetPackageDb _ p = p - --- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and --- its 'ModuleOrigin'). --- --- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one --- origin for a given 'Module' - -type ModuleNameProvidersMap = - UniqMap ModuleName (UniqMap Module ModuleOrigin) - -data GlobalUnitKey = - GlobalUnitKey - !UnitId -- ^ Unit Id of the 'UnitInfo' - !ST.ShortText - -globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey -globalUnitKeyFromUnitInfo ui = GlobalUnitKey (unitId ui) (unitAbiHash ui) - -type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) - -lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo -lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = - case lookupUniqMap globalMap uid of - Nothing -> Nothing - Just sameUnitId -> Map.lookup abiHash sameUnitId - -mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap -mkGlobalUnitInfoMap unitInfos = - listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos - - -data UnitIndex = UnitIndex - { ui_wireMap :: !WiringMap - -- ^ TODO @fendor: document global property - , ui_unwireMap :: !UnwiringMap - -- ^ TODO @fendor: document global property - , ui_unitInfoMap :: !GlobalUnitInfoMap - -- ^ TODO @fendor: document - } - -initUnitIndex :: UnitIndex -initUnitIndex = UnitIndex - { ui_wireMap = emptyUniqMap - , ui_unwireMap = emptyUniqMap - , ui_unitInfoMap = emptyUniqMap - } - -setWireMap :: WiringMap -> UnitIndex -> UnitIndex -setWireMap wired_map unit_index = - unit_index - { ui_wireMap = wired_map - , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] - } - -isWireMapEmpty :: UnitIndex -> Bool -isWireMapEmpty unit_index = - isNullUniqMap (ui_wireMap unit_index) - -addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex -addUnitInfoMap unit_info_map unit_index = - unit_index - { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) - } - where - globalMap :: GlobalUnitInfoMap - globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map - --- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo --- lookupUnitInfoMap unit_index unit_id = --- lookupUniqMap (ui_unitInfoMap unit_index) unit_id - data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid units are here. 'UnitInfo' reflects @@ -513,12 +280,6 @@ data UnitState = UnitState { -- And also to resolve package qualifiers with the PackageImports extension. packageNameMap :: UniqFM PackageName UnitId, - -- -- | A mapping from database unit keys to wired in unit ids. - -- wireMap :: WiringMap, - - -- -- | A mapping from wired in unit ids to unit keys from the database. - -- unwireMap :: UnwiringMap, - -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit -- is always mentioned before the units it depends on. @@ -573,45 +334,14 @@ emptyUnitState = UnitState { allowVirtualUnits = False } -type UnitInfoMap = UniqMap UnitId UnitInfo - -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) --- | A more specialized interface, which doesn't require a 'UnitState' (so it --- can be used while we're initializing 'DynFlags') --- --- Parameters: --- * a boolean specifying whether or not to look for on-the-fly renamed interfaces --- * a 'UnitInfoMap' -lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo -lookupUnit' allowOnTheFlyInst pkg_map u = case u of - HoleUnit -> error "Hole unit" - RealUnit i -> lookupUniqMap pkg_map (unDefinite i) - VirtUnit i - | allowOnTheFlyInst - -> -- lookup UnitInfo of the indefinite unit to be instantiated and - -- instantiate it on-the-fly - fmap (renameUnitInfo pkg_map (instUnitInsts i)) - (lookupUniqMap pkg_map (instUnitInstanceOf i)) - - | otherwise - -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite - -- units. Even if they are real, installed units, they can't use the - -- `RealUnit` constructor (it is reserved for definite units) so we use - -- the `VirtUnit` constructor. - lookupUniqMap pkg_map (virtualUnitId i) - -- | Find the unit we know about with the given unit id, if any lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid --- | Find the unit we know about with the given unit id, if any -lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo -lookupUnitId' db uid = lookupUniqMap db uid - - -- | Looks up the given unit in the unit state, panicking if it is not found unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo unsafeLookupUnit state u = case lookupUnit state u of @@ -729,7 +459,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - wireMap <- ui_wireMap <$> readIORef unit_index + wireMap <- wiringMap <$> readIORef unit_index let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) @@ -782,205 +512,6 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = | otherwise -> DefiniteHomeUnit hu_id (Just (u, is)) --- ----------------------------------------------------------------------------- --- Reading the unit database(s) - -readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] -readUnitDatabases logger cfg = do - conf_refs <- getUnitDbRefs cfg - confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs - mapM (readOrGetUnitDatabase logger cfg) confs - - -getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] -getUnitDbRefs cfg = do - let system_conf_refs = [UserPkgDb, GlobalPkgDb] - - e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH") - let base_conf_refs = case e_pkg_path of - Left _ -> system_conf_refs - Right path - | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs - | otherwise - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) - - -- Apply the package DB-related flags from the command line to get the - -- final list of package DBs. - -- - -- Notes on ordering: - -- * The list of flags is reversed (later ones first) - -- * We work with the package DB list in "left shadows right" order - -- * and finally reverse it at the end, to get "right shadows left" - -- - return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg)) - where - doFlag (PackageDB p) dbs = p : dbs - doFlag NoUserPackageDB dbs = filter isNotUser dbs - doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs - doFlag ClearPackageDBs _ = [] - - isNotUser UserPkgDb = False - isNotUser _ = True - - isNotGlobal GlobalPkgDb = False - isNotGlobal _ = True - --- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' --- when the user database filepath is expected but the latter doesn't exist. --- --- NB: This logic is reimplemented in Cabal, so if you change it, --- make sure you update Cabal. (Or, better yet, dump it in the --- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg -resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do - dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) - let pkgconf = dir </> unitConfigDBName cfg - exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero -resolveUnitDatabase _ (PkgDbPath name) = return $ Just name - --- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. -readOrGetUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readOrGetUnitDatabase logger cfg conf_file = - readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case - Nothing -> do - new_db <- readUnitDatabase logger cfg conf_file - cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db - pure new_db - Just db -> - pure db - --- | Read the 'UnitDatabase' at the given location. -readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readUnitDatabase logger cfg conf_file = do - isdir <- OsPath.doesDirectoryExist conf_file - - proto_pkg_configs <- - if isdir - then readDirStyleUnitInfo conf_file - else do - isfile <- OsPath.doesFileExist conf_file - if isfile - then do - mpkgs <- tryReadOldFileStyleUnitInfo - case mpkgs of - Just pkgs -> return pkgs - Nothing -> throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package " ++ - "databases (" ++ show conf_file ++ - ") use 'ghc-pkg init' to create the database with " ++ - "the correct format." - else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ show conf_file - - let - -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = OsPath.dropTrailingPathSeparator conf_file - top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) - pkgroot = OsPath.takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) - proto_pkg_configs - -- - pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 - return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 - where - readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] - readDirStyleUnitInfo conf_dir = do - let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") - cache_exists <- OsPath.doesFileExist filename - if cache_exists - then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc filename - else do - -- If there is no package.cache file, we check if the database is not - -- empty by inspecting if the directory contains any .conf file. If it - -- does, something is wrong and we fail. Otherwise we assume that the - -- database is empty. - debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> ppr conf_dir - <> text ", checking if the database is empty" - db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) - <$> OsPath.getDirectoryContents conf_dir - if db_empty - then do - debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> ppr conf_dir <> text ", treating" - <+> text "package database as empty" - return [] - else - throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ show conf_dir ++ - " even though package database is not empty" - - - -- Single-file style package dbs have been deprecated for some time, but - -- it turns out that Cabal was using them in one place. So this is a - -- workaround to allow older Cabal versions to use this newer ghc. - -- We check if the file db contains just "[]" and if so, we look for a new - -- dir-style db in conf_file.d/, ie in a dir next to the given file. - -- We cannot just replace the file with a new dir style since Cabal still - -- assumes it's a file and tries to overwrite with 'writeFile'. - -- ghc-pkg also cooperates with this workaround. - tryReadOldFileStyleUnitInfo = do - content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" - direxists <- OsPath.doesDirectoryExist conf_dir - if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) - liftM Just (readDirStyleUnitInfo conf_dir) - else return (Just []) -- ghc-pkg will create it when it's updated - else return Nothing - -mungeUnitInfo :: OsPath -> OsPath - -> UnitInfo -> UnitInfo -mungeUnitInfo top_dir pkgroot = - mungeBytecodeLibFields - . mungeLibDirFields - . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) - -mungeLibDirFields :: UnitInfo -> UnitInfo -mungeLibDirFields pkg = - pkg { - unitLibraryDynDirs = case unitLibraryDynDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - --- | Default to using library-dirs if bytecode library dirs is not explicitly set. -mungeBytecodeLibFields :: UnitInfo -> UnitInfo -mungeBytecodeLibFields pkg = - pkg { - unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - -seqUnitInfo :: UnitInfo -> b -> b -seqUnitInfo ui b = - unitImportDirs ui `seqList` - unitIncludeDirs ui `seqList` - unitLibraryDirs ui `seqList` - unitLibraryBytecodeDirs ui `seqList` - unitExtDepFrameworkDirs ui `seq` - unitHaddockInterfaces ui `seq` - unitHaddockHTMLs ui `seqList` - unitLibraryDynDirs ui `seqList` - unitLibraryDirsStatic ui `seqList` - unitDepends ui `seqList` - unitExposedModules ui `seqList` - b - -evaluateUnitInfo :: UnitInfo -> IO UnitInfo -evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) - -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -1094,265 +625,6 @@ applyPackageFlag prec_map pkg_map unusable no_hide_others pkgs vm flag = Left ps -> Failed (PackageFlagErr flag ps) Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) --- | Like 'selectPackages', but doesn't return a list of unmatched --- packages. Furthermore, any packages it returns are *renamed* --- if the 'UnitArg' has a renaming associated with it. -findPackages :: UnitPrecedenceMap - -> UnitInfoMap - -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - [UnitInfo] -findPackages prec_map pkg_map arg pkgs unusable - = let ps = mapMaybe (finder arg) pkgs - in if null ps - then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) - (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps) - where - finder (PackageArg str) p - = if matchingStr str p - then Just p - else Nothing - finder (UnitIdArg uid) p - = case uid of - RealUnit (Definite iuid) - | iuid == unitId p - -> Just p - VirtUnit inst - | instUnitInstanceOf inst == unitId p - -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) - _ -> Nothing - -selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - ([UnitInfo], [UnitInfo]) -selectPackages prec_map arg pkgs unusable - = let matches = matching arg - (ps,rest) = partition matches pkgs - in if null ps - then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps, rest) - --- | Rename a 'UnitInfo' according to some module instantiation. -renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo -renameUnitInfo pkg_map insts conf = - let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map hsubst - new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) - in conf { - unitInstantiations = new_insts, - unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) - (unitExposedModules conf) - } - - --- A package named on the command line can either include the --- version, or just the name if it is unambiguous. -matchingStr :: String -> UnitInfo -> Bool -matchingStr str p - = str == unitPackageIdString p - || str == unitPackageNameString p - -matchingId :: UnitId -> UnitInfo -> Bool -matchingId uid p = uid == unitId p - -matching :: PackageArg -> UnitInfo -> Bool -matching (PackageArg str) = matchingStr str -matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid -matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case - --- | This sorts a list of packages, putting "preferred" packages first. --- See 'compareByPreference' for the semantics of "preference". -sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) - --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking --- which should be "active". Here is the order of preference: --- --- 1. First, prefer the latest version --- 2. If the versions are the same, prefer the package that --- came in the latest package database. --- --- Pursuant to #12518, we could change this policy to, for example, remove --- the version preference, meaning that we would always prefer the units --- in later unit database. -compareByPreference - :: UnitPrecedenceMap - -> UnitInfo - -> UnitInfo - -> Ordering -compareByPreference prec_map pkg pkg' - = case comparing unitPackageVersion pkg pkg' of - GT -> GT - EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) - , Just prec' <- lookupUniqMap prec_map (unitId pkg') - -- Prefer the unit from the later DB flag (i.e., higher - -- precedence) - -> compare prec prec' - | otherwise - -> EQ - LT -> LT - -comparing :: Ord a => (t -> a) -> t -> t -> Ordering -comparing f a b = f a `compare` f b - -pprFlag :: PackageFlag -> SDoc -pprFlag flag = case flag of - HidePackage p -> text "-hide-package " <> text p - ExposePackage doc _ _ -> text doc - -pprTrustFlag :: TrustFlag -> SDoc -pprTrustFlag flag = case flag of - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p - --- ----------------------------------------------------------------------------- --- Wired-in units --- --- See Note [Wired-in units] in GHC.Unit.Types - -type WiringMap = UniqMap UnitId UnitId -type UnwiringMap = UniqMap UnitId UnitId - -findWiredInUnits - :: Logger - -> UnitPrecedenceMap - -> [UnitInfo] -- database - -> VisibilityMap -- info on what units are visible - -- for wired in selection - -> IO WiringMap -- map from unit id to wired identity -findWiredInUnits logger prec_map pkgs vis_map = do - -- Now we must find our wired-in units, and rename them to - -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in units] in GHC.Unit.Types - let - matches :: UnitInfo -> UnitId -> Bool - pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) - - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. - -- - -- When choosing which package to map to a wired-in package - -- name, we try to pick the latest version of exposed packages. - -- However, if there are no exposed wired in packages available - -- (e.g. -hide-all-packages was used), we can't bail: we *have* - -- to assign a package for the wired-in package: so we try again - -- with hidden packages included to (and pick the latest - -- version). - -- - -- You can also override the default choice by using -ignore-package: - -- this works even when there is no exposed wired in package - -- available. - -- - findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) - findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] - where - all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] - - try ps = case sortByPreference prec_map ps of - p:_ -> Just <$> pick p - _ -> pure Nothing - - notfound = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " not found." - return Nothing - pick :: UnitInfo -> IO (UnitId, UnitInfo) - pick pkg = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " mapped to " - <> ppr (unitId pkg) - return (wired_pkg, pkg) - - - mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds - let - wired_in_pkgs = catMaybes mb_wired_in_pkgs - - wiredInMap :: UniqMap UnitId UnitId - wiredInMap = listToUniqMap - [ (unitId realUnitInfo, wiredInUnitId) - | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs - , not (unitIsIndefinite realUnitInfo) - ] - - return wiredInMap - -updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] -updateWiredInUnits wiredInMap knownInfos pkgs = - map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs - -updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo -updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = - let - upd_wired_in_pkg wiredInUnitId pkg = - pkg { unitId = wiredInUnitId - , unitInstanceOf = wiredInUnitId - -- every non instantiated unit is an instance of - -- itself (required by Backpack...) - -- - -- See Note [About units] in GHC.Unit - } - - upd_deps pkg = pkg { - unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), - unitExposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (unitExposedModules pkg) - } - in - case lookupUniqMap wiredInMap (unitId pkg) of - Just wiredIn -> - case lookupGlobalUnitInfoMap (GlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - --- Helper functions for rewiring Module and Unit. These --- rewrite Units of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. --- --- For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in GHC.Builtin.Names. - -upd_wired_in_mod :: WiringMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiringMap -> Unit -> Unit -upd_wired_in_uid wiredInMap u = case u of - HoleUnit -> HoleUnit - RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) - VirtUnit indef_uid -> - VirtUnit $ mkInstantiatedUnit - (instUnitInstanceOf indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) - -upd_wired_in :: WiringMap -> UnitId -> UnitId -upd_wired_in wiredInMap key - | Just key' <- lookupUniqMap wiredInMap key = key' - | otherwise = key - updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of @@ -1362,51 +634,6 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList w -- ---------------------------------------------------------------------------- --- | The reason why a unit is unusable. -data UnusableUnitReason - = -- | We ignored it explicitly using @-ignore-package@. - IgnoredWithFlag - -- | This unit transitively depends on a unit that was never present - -- in any of the provided databases. - | BrokenDependencies [UnitId] - -- | This unit transitively depends on a unit involved in a cycle. - -- Note that the list of 'UnitId' reports the direct dependencies - -- of this unit that (transitively) depended on the cycle, and not - -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [UnitId] - -- | This unit transitively depends on a unit which was ignored. - | IgnoredDependencies [UnitId] - -- | This unit transitively depends on a unit which was - -- shadowed by an ABI-incompatible unit. - | ShadowedDependencies [UnitId] - -instance Outputable UnusableUnitReason where - ppr IgnoredWithFlag = text "[ignored with flag]" - ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) - ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) - ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) - ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) - -type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) - -pprReason :: SDoc -> UnusableUnitReason -> SDoc -pprReason pref reason = case reason of - IgnoredWithFlag -> - pref <+> text "ignored due to an -ignore-package flag" - BrokenDependencies deps -> - pref <+> text "unusable due to missing dependencies:" $$ - nest 2 (hsep (map ppr deps)) - CyclicDependencies deps -> - pref <+> text "unusable due to cyclic dependencies:" $$ - nest 2 (hsep (map ppr deps)) - IgnoredDependencies deps -> - pref <+> text ("unusable because the -ignore-package flag was used to " ++ - "ignore at least one of its dependencies:") $$ - nest 2 (hsep (map ppr deps)) - ShadowedDependencies deps -> - pref <+> text "unusable due to shadowed dependencies:" $$ - nest 2 (hsep (map ppr deps)) - reportCycles :: Logger -> [SCC UnitInfo] -> IO () reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs where @@ -1416,193 +643,6 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs text "these packages are involved in a cycle:" $$ nest 2 (hsep (map (ppr . unitId) vs)) -reportUnusable :: Logger -> UnusableUnits -> IO () -reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) - where - report (ipid, (_, reason)) = - debugTraceMsg logger 2 $ - pprReason - (text "package" <+> ppr ipid <+> text "is") reason - --- ---------------------------------------------------------------------------- --- --- Utilities on the database --- - --- | A reverse dependency index, mapping an 'UnitId' to --- the 'UnitId's which have a dependency on it. -type RevIndex = UniqMap UnitId [UnitId] - --- | Compute the reverse dependency index of a unit database. -reverseDeps :: UnitInfoMap -> RevIndex -reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db - where - go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex - go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) - go' from r to = addToUniqMap_C (++) r to [from] - --- | Given a list of 'UnitId's to remove, a database, --- and a reverse dependency index (as computed by 'reverseDeps'), --- remove those units, plus any units which depend on them. --- Returns the pruned database, as well as a list of 'UnitInfo's --- that was removed. -removeUnits :: [UnitId] -> RevIndex - -> UnitInfoMap - -> (UnitInfoMap, [UnitInfo]) -removeUnits uids index m = go uids (m,[]) - where - go [] (m,pkgs) = (m,pkgs) - go (uid:uids) (m,pkgs) - | Just pkg <- lookupUniqMap m uid - = case lookupUniqMap index uid of - Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) - | otherwise - = go uids (m,pkgs) - --- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' --- which correspond to units that do not exist in the index. -depsNotAvailable :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) - --- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in --- 'unitAbiDepends' which correspond to units that do not exist, OR have --- mismatching ABIs. -depsAbiMismatch :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg - where - abiMatch (dep_uid, abi) - | Just dep_pkg <- lookupUniqMap pkg_map dep_uid - = unitAbiHash dep_pkg == abi - | otherwise - = False - --- ----------------------------------------------------------------------------- --- Ignore units - -ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits -ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) - where - doit (IgnorePackage str) = - case partition (matchingStr str) pkgs of - (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) - | p <- ps ] - -- missing unit is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. - --- ---------------------------------------------------------------------------- --- --- Merging databases --- - --- | For each unit, a mapping from uid -> i indicates that this --- unit was brought into GHC by the ith @-package-db@ flag on --- the command line. We use this mapping to make sure we prefer --- units that were defined later on the command line, if there --- is an ambiguity. -type UnitPrecedenceMap = UniqMap UnitId Int - --- | Given a list of databases, merge them together, where --- units with the same unit id in later databases override --- earlier ones. This does NOT check if the resulting database --- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: Logger -> [UnitDatabase UnitId] - -> IO (UnitInfoMap, UnitPrecedenceMap) -mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] - where - merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do - debugTraceMsg logger 2 $ - text "loading package database" <+> ppr db_path - when (logVerbAtLeast logger 2) $ - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" - return (pkg_map', prec_map') - where - db_map = mk_pkg_map db - mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) - - -- The set of UnitIds which appear in both db and pkgs. These are the - -- ones that get overridden. Compute this just to give some - -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) - - -- Now merge the sets together (NB: in case of duplicate, - -- first argument preferred) - pkg_map' :: UnitInfoMap - pkg_map' = pkg_map `plusUniqMap` db_map - - prec_map' :: UnitPrecedenceMap - prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) - --- | Validates a database, removing unusable units from it --- (this includes removing units that the user has explicitly --- ignored.) Our general strategy: --- --- 1. Remove all broken units (dangling dependencies) --- 2. Remove all units that are cyclic --- 3. Apply ignore flags --- 4. Remove all units which have deps with mismatching ABIs --- -validateDatabase :: UnitConfig -> UnitInfoMap - -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) -validateDatabase cfg pkg_map1 = - (pkg_map5, unusable, sccs) - where - ignore_flags = reverse (unitConfigFlagsIgnored cfg) - - -- Compute the reverse dependency index - index = reverseDeps pkg_map1 - - -- Helper function - mk_unusable mk_err dep_matcher m uids = - listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids - ] - - -- Find broken units - directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (nonDetEltsUniqMap pkg_map1) - (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 - unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken - - -- Find recursive units - sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) - | pkg <- nonDetEltsUniqMap pkg_map2 ] - getCyclicSCC (CyclicSCC vs) = map unitId vs - getCyclicSCC (AcyclicSCC _) = [] - (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 - unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic - - -- Apply ignore flags - directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) - (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 - unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored - - -- Knock out units whose dependencies don't agree with ABI - -- (i.e., got invalidated due to shadowing) - directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (nonDetEltsUniqMap pkg_map4) - (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 - unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - - -- combine all unusables. The order is important for shadowing. - -- plusUniqMapList folds using plusUFM which is right biased (opposite of - -- Data.Map.union) so the head of the list should be the least preferred - unusable = plusUniqMapList [ unusable_shadowed - , unusable_cyclic - , unusable_broken - , unusable_ignored - , directly_ignored - ] -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our unit @@ -1667,7 +707,7 @@ mkUnitState logger unit_index cfg = do we build a mapping saying what every in scope module name points to. -} - raw_dbs <- readUnitDatabases logger cfg + raw_dbs <- readUnitDatabases logger (initUnitDbConfig cfg) -- distrust all units if the flag is set let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) @@ -1697,7 +737,7 @@ mkUnitState logger unit_index cfg = do -- Now that we've merged everything together, prune out unusable -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + let (pkg_map2, unusable, sccs) = validateDatabase (unitConfigFlagsIgnored cfg) pkg_map1 reportCycles logger sccs reportUnusable logger unusable @@ -1781,9 +821,9 @@ mkUnitState logger unit_index cfg = do modifyIORef' unit_index (setWireMap wmap) pure wmap else do - pure $ ui_wireMap ui + pure $ wiringMap ui - let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + let all_pkgs = updateWiredInUnits wireMap (globalUnits ui) pkgs1 (new_pkgs, _pkgs_set) = partitionEithers all_pkgs modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (wireMap, map (either id id) all_pkgs) @@ -1859,7 +899,7 @@ mkUnitState logger unit_index cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db vis_map + let mod_map1 = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable mod_map = mod_map2 `plusUniqMap` mod_map1 @@ -1872,15 +912,24 @@ mkUnitState logger unit_index cfg = do , trustedUnits = trusted , distrustedUnits = distrusted , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db plugin_vis_map , packageNameMap = pkgname_map - -- , wireMap = wired_map - -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } return state +initUnitDbConfig :: UnitConfig -> UnitDbConfig +initUnitDbConfig uc = UnitDbConfig + { unitDbConfigFlagsDB = unitConfigFlagsDB uc + , unitDbConfigProgramName = unitConfigProgramName uc + , unitDbConfigDBName = unitConfigDBName uc + , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc + , unitDbConfigGlobalDB = unitConfigGlobalDB uc + , unitDbConfigGHCDir = unitConfigGHCDir uc + , unitDbConfigDBCache = unitConfigDBCache uc + } + selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True selectHptFlag _ _ = False @@ -1893,158 +942,6 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags -- MP: This does not yet support thinning/renaming go cur _ = cur - --- | Given a wired-in 'Unit', "unwire" it into the 'Unit' --- that it was recorded as in the package database. -unwireUnit :: UnitIndex -> Unit -> Unit -unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid) -unwireUnit _ uid = uid - --- ----------------------------------------------------------------------------- --- | Makes the mapping from ModuleName to package info - --- Slight irritation: we proceed by leafing through everything --- in the installed package database, which makes handling indefinite --- packages a bit bothersome. - -mkModuleNameProvidersMap - :: Logger - -> UnitConfig - -> UnitInfoMap - -> VisibilityMap - -> ModuleNameProvidersMap -mkModuleNameProvidersMap logger cfg pkg_map vis_map = - -- What should we fold on? Both situations are awkward: - -- - -- * Folding on the visibility map means that we won't create - -- entries for packages that aren't mentioned in vis_map - -- (e.g., hidden packages, causing #14717) - -- - -- * Folding on pkg_map is awkward because if we have an - -- Backpack instantiation, we need to possibly add a - -- package from pkg_map multiple times to the actual - -- ModuleNameProvidersMap. Also, we don't really want - -- definite package instantiations to show up in the - -- list of possibilities. - -- - -- So what will we do instead? We'll extend vis_map with - -- entries for every definite (for non-Backpack) and - -- indefinite (for Backpack) package, so that we get the - -- hidden entries we need. - nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended - where - vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map - - default_vis = listToUniqMap - [ (mkUnit pkg, mempty) - | (_, pkg) <- nonDetUniqMapToList pkg_map - -- Exclude specific instantiations of an indefinite - -- package - , unitIsIndefinite pkg || null (unitInstantiations pkg) - ] - - emptyMap = emptyUniqMap - setOrigins m os = fmap (const os) m - extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap - = addListTo modmap theBindings - where - pkg = unit_lookup uid - - theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - theBindings = newBindings b rns - - newBindings :: Bool - -> [(ModuleName, ModuleName)] - -> [(ModuleName, UniqMap Module ModuleOrigin)] - newBindings e rns = es e ++ hiddens ++ map rnBinding rns - - rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, UniqMap Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) - where origEntry = case lookupUFM esmap orig of - Just r -> r - Nothing -> throwGhcException (CmdLineError (renderWithContext - (log_default_user_context (logFlags logger)) - (text "package flag: could not find module name" <+> - ppr orig <+> text "in package" <+> ppr pk))) - - es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] - es e = do - (m, exposedReexport) <- exposed_mods - let (pk', m', origin') = - case exposedReexport of - Nothing -> (pk, m, fromExposedModules e) - Just (Module pk' m') -> - (pk', m', fromReexportedModules e pkg) - return (m, mkModMap pk' m' origin') - - esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) - esmap = listToUFM (es False) -- parameter here doesn't matter, orig will - -- be overwritten - - hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] - - pk = mkUnit pkg - unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map uid - `orElse` pprPanic "unit_lookup" (ppr uid) - - exposed_mods = unitExposedModules pkg - hidden_mods = unitHiddenModules pkg - --- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. -mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap -mkUnusableModuleNameProvidersMap unusables = - nonDetFoldUniqMap extend_modmap emptyUniqMap unusables - where - extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings - where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - bindings = exposed ++ hidden - - origin_reexport = ModUnusable (UnusableUnit unit reason True) - origin_normal = ModUnusable (UnusableUnit unit reason False) - unit = mkUnit unit_info - - exposed = map get_exposed exposed_mods - hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] - - -- with re-exports, c:Foo can be reexported from two (or more) - -- unusable packages: - -- Foo -> a:Foo (unusable reason A) -> c:Foo - -- -> b:Foo (unusable reason B) -> c:Foo - -- - -- We must be careful to not record the following (#21097): - -- Foo -> c:Foo (unusable reason A) - -- -> c:Foo (unusable reason B) - -- But: - -- Foo -> a:Foo (unusable reason A) - -- -> b:Foo (unusable reason B) - -- - get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) - get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) - -- in the reexport case, we create a virtual module that doesn't - -- exist but we don't care as it's only used as a key in the map. - - exposed_mods = unitExposedModules unit_info - hidden_mods = unitHiddenModules unit_info - --- | Add a list of key/value pairs to a nested map. --- --- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks --- when reloading modules in GHCi (see #4029). This ensures that each --- value is forced before installing into the map. -addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) - => UniqMap k1 (UniqMap k2 a) - -> [(k1, UniqMap k2 a)] - -> UniqMap k1 (UniqMap k2 a) -addListTo = foldl' merge - where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v - --- | Create a singleton module mapping -mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin -mkModMap pkg mod = unitUniqMap (mkModule pkg mod) - - -- ----------------------------------------------------------------------------- -- Package Utils @@ -2185,7 +1082,7 @@ lookupModuleWithSuggestions' pkgs mod_map name mb_pn suggestions = fuzzyLookup (moduleNameString name) all_mods all_mods :: [(String, ModuleSuggestion)] -- All modules - all_mods = sortBy (comparing fst) $ + all_mods = sortOn fst $ [ (moduleNameString m, suggestion) | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) @@ -2199,78 +1096,7 @@ listVisibleModuleNames state = map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) where visible (_, ms) = anyUniqMap originVisible ms --- | Takes a list of UnitIds (and their "parent" dependency, used for error --- messages), and returns the list with dependencies included, in reverse --- dependency order (a units appears before those it depends on). -closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps - --- | Similar to closeUnitDeps but takes a list of already loaded units as an --- additional argument. -closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps --- | Add a UnitId and those it depends on (recursively) to the given list of --- UnitIds if they are not already in it. Return a list in reverse dependency --- order (a unit appears before those it depends on). --- --- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). --- It it's not found, the optional parent unit is used to return a more precise --- error message ("dependency of <PARENT>"). -add_unit :: UnitInfoMap - -> [UnitId] - -> UnitId - -> Maybe UnitId - -> MaybeErr UnitErr [UnitId] -add_unit pkg_map ps p mb_parent - | p `elem` ps = return ps -- Check if we've already added this unit - | otherwise = case lookupUnitId' pkg_map p of - Nothing -> Failed (CloseUnitErr p mb_parent) - Just info -> do - -- Add the unit's dependents also - ps' <- foldM add_unit_key ps (unitDepends info) - return (p : ps') - where - add_unit_key xs key - = add_unit pkg_map xs key (Just p) - -data UnitErr - = CloseUnitErr !UnitId !(Maybe UnitId) - | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] - | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] - -mayThrowUnitErr :: MaybeErr UnitErr a -> IO a -mayThrowUnitErr = \case - Failed e -> throwGhcExceptionIO - $ CmdLineError - $ renderWithContext defaultSDocContext - $ withPprStyle defaultUserStyle - $ ppr e - Succeeded a -> return a - -instance Outputable UnitErr where - ppr = \case - CloseUnitErr p mb_parent - -> (text "unknown unit:" <+> ppr p) - <> case mb_parent of - Nothing -> Outputable.empty - Just parent -> space <> parens (text "dependency of" - <+> ftext (unitIdFS parent)) - PackageFlagErr flag reasons - -> flag_err (pprFlag flag) reasons - - TrustFlagErr flag reasons - -> flag_err (pprTrustFlag flag) reasons - where - flag_err flag_doc reasons = - text "cannot satisfy " - <> flag_doc - <> (if null reasons then Outputable.empty else text ": ") - $$ nest 4 (vcat (map ppr_reason reasons) $$ - text "(use -v for more information)") - - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement. @@ -2328,37 +1154,23 @@ pprUnitsSimple ue = pprUnitsWith pprIPI ue t = if isUnitInfoTrusted ue ipi then text "T" else text " " in e <> t <> text " " <> ftext i --- | Show the mapping of modules to where they come from. -pprModuleMap :: ModuleNameProvidersMap -> SDoc -pprModuleMap mod_map = - vcat (map pprLine (nonDetUniqMapToList mod_map)) - where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) - pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc - pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) - | otherwise = ppr m' <+> parens (ppr o) +-- | Print unit-ids with UnitInfo found in the given UnitState +pprWithUnitState :: UnitState -> SDoc -> SDoc +pprWithUnitState state = updSDocContext (\ctx -> ctx + { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) + }) + +-- | Print raw unit-ids, without removing the hash +pprRawUnitIds :: SDoc -> SDoc +pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) fsPackageName :: UnitInfo -> FastString fsPackageName info = fs where PackageName fs = unitPackageName info --- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. -instUnitToUnit :: InstantiatedUnit -> Unit -instUnitToUnit iuid = - -- NB: suppose that we want to compare the instantiated - -- unit p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- VirtUnit, they won't compare equal; only - -- after improvement will the equality hold. - VirtUnit iuid - - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module +-- ----------------------------------------------------------------------------- +-- Module renaming -- | Substitutes holes in a 'Module'. NOT suitable for being called -- directly on a 'nameModule', see Note [Representation of module/name variables]. @@ -2374,44 +1186,19 @@ renameHoleModule state = renameHoleModule' (unitInfoMap state) renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit renameHoleUnit state = renameHoleUnit' (unitInfoMap state) --- | Like 'renameHoleModule', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnit' pkg_map env (moduleUnit m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = <Blah>, that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit -renameHoleUnit' pkg_map env uid = - case uid of - (VirtUnit - InstantiatedUnit{ instUnitInstanceOf = cid - , instUnitInsts = insts - , instUnitHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) - then uid - else mkVirtUnit cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - -- | Injects an 'InstantiatedModule' to 'Module' (see also -- 'instUnitToUnit'. instModuleToModule :: InstantiatedModule -> Module instModuleToModule (Module iuid mod_name) = mkModule (instUnitToUnit iuid) mod_name --- | Print unit-ids with UnitInfo found in the given UnitState -pprWithUnitState :: UnitState -> SDoc -> SDoc -pprWithUnitState state = updSDocContext (\ctx -> ctx - { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) - }) - --- | Print raw unit-ids, without removing the hash -pprRawUnitIds :: SDoc -> SDoc -pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) +-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. +instUnitToUnit :: InstantiatedUnit -> Unit +instUnitToUnit iuid = + -- NB: suppose that we want to compare the instantiated + -- unit p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- VirtUnit, they won't compare equal; only + -- after improvement will the equality hold. + VirtUnit iuid ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -1,6 +1,3 @@ module GHC.Unit.State where data UnitState -data ModuleSuggestion -data ModuleOrigin -data UnusableUnit ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -578,7 +578,7 @@ had used @-ignore-package@). The affected packages are compiled with, e.g., @-this-unit-id base@, so that the symbols in the object files have the unversioned unit id in their name. -Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. +Make sure you change 'wiredInUnitIds' if you add an entry here. -} ===================================== compiler/ghc.cabal.in ===================================== @@ -968,6 +968,14 @@ Library GHC.Unit.Env GHC.Unit.External GHC.Unit.External.Database + GHC.Unit.External.Index + GHC.Unit.External.Substitution + GHC.Unit.External.Query + GHC.Unit.External.ModuleOrigin + GHC.Unit.External.Providers + GHC.Unit.External.Validate + GHC.Unit.External.Visibility + GHC.Unit.External.Wired GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== testsuite/tests/driver/T26423/Hello.hs ===================================== @@ -0,0 +1,6 @@ +module Hello where + +import Tes + +hello :: String +hello = "Imported from dependency 'test':" <> show test ===================================== testsuite/tests/driver/T26423/Makefile ===================================== @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +LOCAL_PKGCONF=test.package.conf.d + +clean: + rm -f test/*.o test/*.hi *.o *.hi + rm -rf $(LOCAL_PKGCONF) + +.PHONY: T26423 +T26423: + @rm -rf $(LOCAL_PKGCONF) + "$(TEST_HC)" $(TEST_HC_OPTS) -this-unit-id test-1.0 -c test/Test.hs + "$(GHC_PKG)" init $(LOCAL_PKGCONF) + "$(GHC_PKG)" --no-user-package-db -f $(LOCAL_PKGCONF) register test/test.pkg -v0 + "$(TEST_HC)" $(TEST_HC_OPTS) -package-db $(LOCAL_PKGCONF)/ -package ghc T26423.hs + ./T26423 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" ===================================== testsuite/tests/driver/T26423/T26423.hs ===================================== @@ -0,0 +1,38 @@ +import GHC +import GHC.Data.OsPath +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Unit.Env +import GHC.Plugins +import GHC.Prelude + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import System.Environment + +-- No sign of new db in output: +-- "Just [DB: <libdir>/package.conf.d]" +bad :: IO () +bad = do + libdir:_ <- getArgs + runGhcT (Just libdir) $ do + df <- getSessionDynFlags + -- The first call simulates having modified the DynFlags once before + setSessionDynFlags df + setSessionDynFlags $ + df { packageDBFlags = PackageDB (PkgDbPath $ os "test.package.conf.d") : (packageDBFlags df) + , packageFlags = [ExposePackage "testpkg" (PackageArg "testpkg") (ModRenaming True [])] + } + + hsc_env <- getSession + t <- guessTarget "Heo.hs" Nothing Nothing + setTargets [t] + r <- load LoadAllTargets + when (failed r) $ do + liftIO $ throwIO $ ErrorCall "Failed to load the target" + + execStmt "hello" execOptions + liftIO $ putStrLn "Successfully compiled Hello.hs" + +main = bad >>= print ===================================== testsuite/tests/driver/T26423/all.T ===================================== @@ -0,0 +1 @@ +test('T26423', [extra_files(['Hello.hs', 'test/'])], makefile_test, []) ===================================== testsuite/tests/driver/T26423/test/Test.hs ===================================== @@ -0,0 +1,4 @@ +module Test where + +test :: Int +test = 42 ===================================== testsuite/tests/driver/T26423/test/test.pkg ===================================== @@ -0,0 +1,8 @@ +name: test +version: 1.0 +id: test-1.0 +key: test-1.0 +exposed-modules: Test +import-dirs: ${pkgroot}/test +library-dirs: ${pkgroot}/test +exposed: True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cffe0d451d67c72c2b1cfc62e36f702... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cffe0d451d67c72c2b1cfc62e36f702... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help