[Git][ghc/ghc][wip/fendor/external-unit-db-cache] Split State.hs into many more modules

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: ba143db3 by fendor at 2026-07-17T12:47:29+02:00 Split State.hs into many more modules - - - - - 23 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Unit/Env.hs - 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 - ghc/GHCi/UI.hs - hadrian/src/Rules/Generate.hs - testsuite/tests/count-deps/CountDepsParser.stdout - utils/haddock/haddock-api/src/Haddock.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do logger <- getLogger hsc_env <- getSession - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = @@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph old_unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) (ue_eud old_unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -779,7 +779,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env , ue_eud = ue_eud old_unit_env - , ue_unit_index = ue_unit_index old_unit_env + , ue_uic = ue_uic old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -838,7 +838,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_eps = ue_eps unit_env0 , ue_module_graph = ue_module_graph unit_env0 , ue_eud = ue_eud unit_env0 - , ue_unit_index = ue_unit_index unit_env0 + , ue_uic = ue_uic unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -886,7 +886,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) (ue_eud unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure HomeUnitEnv ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -451,7 +451,7 @@ addUnit u = do { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] } - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) eud (hsc_all_home_unit_ids hsc_env) -- update platform constants @@ -469,7 +469,7 @@ addUnit u = do , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env , ue_eud = ue_eud old_unit_env - , ue_unit_index = ue_unit_index old_unit_env + , ue_uic = ue_uic old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Driver.Env , hsc_HUG , hsc_all_home_unit_ids , hscUnitIndex - , hsc_unit_index + , hscUIC , hscUpdateLoggerFlags , hscUpdateHUG , hscInsertHPT @@ -94,6 +94,7 @@ import GHC.Builtin.Names import Data.IORef import qualified Data.Set as Set import GHC.Unit.External.Database (ExternalUnitDatabaseCache, readExternalUnitDatabases, ExternalUnitDatabases) +import GHC.Unit.External.Index runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env hsc = do @@ -233,10 +234,10 @@ hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env) hscUnitIndex :: HscEnv -> IO UnitIndex -hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env) +hscUnitIndex hsc_env = ueUI (hsc_unit_env hsc_env) -hsc_unit_index :: HscEnv -> IORef UnitIndex -hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env) +hscUIC :: HscEnv -> UnitIndexCache +hscUIC hsc_env = ue_uic (hsc_unit_env hsc_env) -------------------------------------------------------------------------------- -- * Queries on Transitive Closure ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do let hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) (hscEUDC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants emptyHpt <- liftIO $ emptyHomePackageTable ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -40,6 +40,8 @@ module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv , ueEPS -- Not really needed, get directly type families and rule base! + , ueEUD + , ueUI , updateHug -- * Unit Env helper functions , ue_currentHomeUnitEnv @@ -110,6 +112,7 @@ import qualified Data.Set as Set import GHC.Unit.External import GHC.Unit.External.Database +import GHC.Unit.External.Index import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Types @@ -131,7 +134,6 @@ import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import Data.IORef -------------------------------------------------------------------------------- -- The hard queries @@ -177,19 +179,28 @@ data UnitEnv = UnitEnv -- ^ GHC name/version (used for dynamic library suffix) , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId) - -- TODO: @fendor Docs - , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex) - -- TODO: @fendor Docs + -- ^ Global cache of already read package databases + + , ue_uic :: {-# UNPACK #-} !UnitIndexCache + -- ^ Index of already processed 'UnitInfo's. + -- Shares state over all 'UnitState' in the 'HomeUnitGraph'. } ueEPS :: UnitEnv -> IO ExternalPackageState ueEPS = eucEPS . ue_eps +ueEUD :: UnitEnv -> IO (ExternalUnitDatabases UnitId) +ueEUD = readExternalUnitDatabases . ue_eud + +ueUI :: UnitEnv -> IO UnitIndex +ueUI = readUnitIndex . ue_uic + + initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache eud <- initExternalUnitDatabaseCache - unit_index <- newIORef (initUnitIndex) + uic <- initUnitIndexCache return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug @@ -198,7 +209,7 @@ initUnitEnv cur_unit hug namever platform = do , ue_platform = platform , ue_namever = namever , ue_eud = eud - , ue_unit_index = unit_index + , ue_uic = uic } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -1,31 +1,64 @@ module GHC.Unit.External.Database ( - -- * + -- * Mutable cache for 'ExternalUnitDatabases' ExternalUnitDatabaseCache (..), initExternalUnitDatabaseCache, readExternalUnitDatabases, readExternalUnitDatabase, cacheExternalUnitDatabase, clearExternalUnitDatabaseCache, - -- * + -- * 'ExternalUnitDatabases' ExternalUnitDatabases, emptyExternalUnitDatabases, insertExternalUnitDatabases, deleteExternalUnitDatabases, lookupExternalUnitDatabases, - -- * + -- * 'UnitDatabase' UnitDatabase (..), + mergeDatabases, + UnitPrecedenceMap, + sortByPreference, + compareByPreference, + -- * Reading packages from disk. + UnitDbConfig(..), + readOrGetUnitDatabase, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, ) where import GHC.Prelude -import GHC.Data.OsPath +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.Driver.DynFlags +import GHC.Platform.ArchOS +import GHC.Types.Unique.Map +import GHC.Unit.Database import GHC.Unit.Info -import GHC.Utils.Outputable +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 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 (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 System.Directory +import System.Environment (getEnv) +import System.FilePath as FilePath -- ---------------------------------------------------------------------------- -- ExternalUnitDatabaseCache @@ -102,3 +135,273 @@ 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 + } + +readUnitDatabases :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger db_cache cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readOrGetUnitDatabase logger db_cache 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 -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger db_cache cfg conf_file = + readExternalUnitDatabase db_cache conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase db_cache 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,238 @@ +module GHC.Unit.External.Index ( + -- * The 'UnitIndexCache'. + -- A mutable wrapper around 'UnitIndex' + UnitIndexCache(..), + initUnitIndexCache, + readUnitIndex, + modifyUnitIndexCache, + clearUnitIndexCache, + -- * 'UnitIndex' + UnitIndex, + emptyUnitIndex, + wiringMap, + unwiringMap, + globalUnits, + setWireMap, + wireMapExists, + addUnitInfoMap, + -- * 'GlobalUnitInfoMap' + GlobalUnitInfoMap, + lookupGlobalUnitInfoMap, + emptyGlobalUnitInfoMap, + mkGlobalUnitInfoMap, + -- * 'GlobalUnitKey' + GlobalUnitKey, + UnitAbiHash, + mkGlobalUnitKey, + globalUnitKeyFromUnitInfo, + -- * Wired-in units + unwireUnit, + updateWiredInUnits, + updateWiredInUnitsInUnitInfo, + updateWiredInUnitIdInModule, +) 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.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map + +-- ---------------------------------------------------------------------------- +-- UnitIndex +-- ---------------------------------------------------------------------------- + +newtype UnitIndexCache = UnitIndexCache + { uic_index :: IORef UnitIndex + } + +initUnitIndexCache :: IO UnitIndexCache +initUnitIndexCache = + UnitIndexCache <$> IORef.newIORef emptyUnitIndex + +readUnitIndex :: UnitIndexCache -> IO UnitIndex +readUnitIndex eudc = + IORef.readIORef (uic_index eudc) + +modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO () +modifyUnitIndexCache eudc f = + IORef.modifyIORef' (uic_index eudc) f + +clearUnitIndexCache :: UnitIndexCache -> IO () +clearUnitIndexCache eudc = + modifyUnitIndexCache eudc (const emptyUnitIndex) + +data UnitIndex = UnitIndex + { ui_wireMap :: !WireMap + -- ^ A mapping from database unit keys to wired in unit ids. + , ui_unwireMap :: !UnwireMap + -- ^ A mapping from wired in unit ids to unit keys from the database. + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: document + } + +wiringMap :: UnitIndex -> WireMap +wiringMap = ui_wireMap + +unwiringMap :: UnitIndex -> UnwireMap +unwiringMap = ui_unwireMap + +globalUnits :: UnitIndex -> GlobalUnitInfoMap +globalUnits = ui_unitInfoMap + +emptyUnitIndex :: UnitIndex +emptyUnitIndex = UnitIndex + { ui_wireMap = emptyWireMap + , ui_unwireMap = emptyUnwireMap + , ui_unitInfoMap = emptyGlobalUnitInfoMap + } + +setWireMap :: WireMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = unwiringMapFromWireMap wired_map + } + +wireMapExists :: UnitIndex -> Bool +wireMapExists unit_index = + not $ isWireMapEmpty (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = + -- Order should not matter, either it is exactly the same 'UnitInfo', + -- or a new one. + GlobalUnitInfoMap $ plusUniqMap_C Map.union newEntriesMap oldMap + } + where + GlobalUnitInfoMap newEntriesMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map + GlobalUnitInfoMap oldMap = ui_unitInfoMap unit_index + +-- ---------------------------------------------------------------------------- +-- GlobalUnitInfoMap +-- ---------------------------------------------------------------------------- + +type UnitAbiHash = ST.ShortText + +-- | A +newtype GlobalUnitInfoMap = GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo)) + +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) (GlobalUnitInfoMap globalMap) = + case lookupUniqMap globalMap uid of + Nothing -> Nothing + Just sameUnitId -> Map.lookup abiHash sameUnitId + +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap +mkGlobalUnitInfoMap unitInfos = + GlobalUnitInfoMap $ listToUniqMap_C Map.union (map mkEntry unitInfos) + where + mkEntry (uid, v) = (uid, Map.singleton (unitAbiHash v) v) + +emptyGlobalUnitInfoMap :: GlobalUnitInfoMap +emptyGlobalUnitInfoMap = GlobalUnitInfoMap emptyUniqMap + +-- ---------------------------------------------------------------------------- +-- GlobalUnitKey +-- ---------------------------------------------------------------------------- + +-- | A 'GlobalUnitKey' is a key that can globally identify a 'UnitInfo', not just +-- in the 'UnitInfoMap'. +data GlobalUnitKey = + GlobalUnitKey + !UnitId -- ^ Unit Id of the 'UnitInfo' + !UnitAbiHash -- ^ ABI hash of the 'UnitInfo' + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) + +mkGlobalUnitKey :: UnitId -> UnitAbiHash -> 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) (lookupUnwireMap def_uid (unwiringMap state)) +unwireUnit _ uid = uid + +updateWiredInUnits :: WireMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WireMap -> 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 (updateWiredInUnitIdInModule wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupWireMap (unitId pkg) wiredInMap 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. + +updateWiredInUnitIdInModule :: WireMap -> Module -> Module +updateWiredInUnitIdInModule wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WireMap -> 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,updateWiredInUnitIdInModule wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WireMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupWireMap key wiredInMap = 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 ( + -- * Query the 'UnitInfoMap' + 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 ( + -- * Substitution and module renaming + 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,383 @@ +module GHC.Unit.External.Validate ( + -- * Validation of unit databases + validateDatabase, + reportUnusable, + UnusableUnits, + UnusableUnit(..), + UnusableUnitReason(..), + pprReason, + -- * Package resolver + findPackages, + selectPackages, + -- * Unit database closure validation + UnitErr(..), + mayThrowUnitErr, + closeUnitDeps, + closeUnitDeps', + -- * Utils + 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,140 @@ +module GHC.Unit.External.Wired ( + -- * 'WireMap' + WireMap, + emptyWireMap, + isWireMapEmpty, + lookupWireMap, + listWireMap, + -- * 'UnwireMap' + UnwireMap, + emptyUnwireMap, + lookupUnwireMap, + unwiringMapFromWireMap, + -- * Creating 'WireMap' + findWiredInUnits, +) where + +import GHC.Prelude + +import GHC.Unit.External.Database +import GHC.Unit.External.Visibility + +import GHC.Data.Maybe +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable as Outputable + +-- | The 'WireMap' records the mapping from the 'UnitId' of on-disk 'UnitInfo' +-- to the 'UnitId' of the 'wiredInMap'. +-- +-- See 'wiredInUnitIds' for the set of wired-in units. +-- +newtype WireMap = + WireMap (UniqMap UnitId UnitId) + +emptyWireMap :: WireMap +emptyWireMap = WireMap emptyUniqMap + +isWireMapEmpty :: WireMap -> Bool +isWireMapEmpty (WireMap wmap) = isNullUniqMap wmap + +lookupWireMap :: UnitId -> WireMap -> Maybe UnitId +lookupWireMap uid (WireMap wmap) = lookupUniqMap wmap uid + +listWireMap :: WireMap -> [(UnitId, UnitId)] +listWireMap (WireMap wmap) = nonDetUniqMapToList wmap + +-- | The reverse of 'WireMap'. +-- Records the mapping from the wired-in 'UnitId' to the on-disk 'UnitId'. +newtype UnwireMap = + UnwireMap (UniqMap UnitId UnitId) + +emptyUnwireMap :: UnwireMap +emptyUnwireMap = UnwireMap emptyUniqMap + +unwiringMapFromWireMap :: WireMap -> UnwireMap +unwiringMapFromWireMap (WireMap wired_map) = + UnwireMap $ listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + +lookupUnwireMap :: UnitId -> UnwireMap -> Maybe UnitId +lookupUnwireMap uid (UnwireMap wmap) = lookupUniqMap wmap uid + +-- ----------------------------------------------------------------------------- +-- 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 WireMap -- 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 $ WireMap 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 ===================================== @@ -4,14 +4,6 @@ -- | Unit manipulation module GHC.Unit.State ( module GHC.Unit.Info, - - UnitIndex(..), - initUnitIndex, - setWireMap, - isWireMapEmpty, - addUnitInfoMap, - -- lookupUnitInfoMap, - -- * Reading the package config, and processing cmdline args UnitState(..), UnitDatabase (..), @@ -26,7 +18,6 @@ module GHC.Unit.State ( listUnitInfo, -- * Querying the package config - UnitInfoMap, lookupUnit, lookupUnit', unsafeLookupUnit, @@ -90,50 +81,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.Types.Unique.Set -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.List (intersperse, partition, sort, sortOn) +import Data.Monoid (First (..)) +import Data.Set (Set) +import Data.Set qualified as Set -- --------------------------------------------------------------------------- -- The Unit state @@ -179,162 +165,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 @@ -358,8 +188,6 @@ data UnitConfig = UnitConfig , unitConfigHideAll :: !Bool -- ^ Hide all units by default , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default - , unitConfigDBCache :: !(ExternalUnitDatabaseCache UnitId) - -- command-line flags , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags , unitConfigFlagsExposed :: [PackageFlag] -- ^ Exposed units @@ -369,8 +197,8 @@ data UnitConfig = UnitConfig , unitConfigHomeUnits :: Set.Set UnitId } -initUnitConfig :: DynFlags -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> UnitConfig -initUnitConfig dflags cached_dbs home_units = +initUnitConfig :: DynFlags -> Set.Set UnitId -> UnitConfig +initUnitConfig dflags home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags !hu_instantiations = homeUnitInstantiations_ dflags @@ -407,7 +235,6 @@ initUnitConfig dflags cached_dbs home_units = , unitConfigHideAll = gopt Opt_HideAllPackages dflags , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags - , unitConfigDBCache = cached_dbs , unitConfigFlagsDB = map (offsetPackageDb (workingDirectory dflags)) $ packageDBFlags dflags , unitConfigFlagsExposed = packageFlags dflags , unitConfigFlagsIgnored = ignorePackageFlags dflags @@ -422,77 +249,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 @@ -500,12 +256,18 @@ data UnitState = UnitState { -- is adjusted at runtime. (In particular, some units in this map -- may have the 'exposed' flag be 'False'.) -- - -- TODO @fendor: All values are shared with 'UnitIndex.ui_unitInfoMap'. + -- All values are shared with 'UnitIndex'.'globalUnits'. unitInfoMap :: UnitInfoMap, - -- | Local overlay for the unit info so that sharing is more accurate - trustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet - distrustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet + -- | Set of units that we trust. + -- + -- Local overlay of 'UnitInfo'. + trustedUnits :: UniqSet UnitId, + + -- | Set of units that we distrust. + -- + -- Local overlay of 'UnitInfo'. + distrustedUnits :: UniqSet UnitId, -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same -- package name (e.g. different instantiations), then we return one of them... @@ -513,12 +275,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. @@ -559,8 +315,8 @@ data UnitState = UnitState { emptyUnitState :: UnitState emptyUnitState = UnitState { unitInfoMap = emptyUniqMap, - trustedUnits = Set.empty, - distrustedUnits = Set.empty, + trustedUnits = emptyUniqSet, + distrustedUnits = emptyUniqSet, packageNameMap = emptyUFM, -- wireMap = emptyUniqMap, -- unwireMap = emptyUniqMap, @@ -573,45 +329,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 @@ -691,20 +416,21 @@ mkUnitInfoMap infos = foldl' add emptyUniqMap infos listUnitInfo :: UnitState -> [UnitInfo] listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool -isUnitTrusted ue u = - Set.member (toUnitId u) (trustedUnits ue) && (Set.notMember (toUnitId u) (distrustedUnits ue)) - || unitIsTrusted (unsafeLookupUnit ue u) - +-- | Do we trust the 'UnitInfo' for the given 'UnitId'? isUnitIdTrusted :: HasDebugCallStack => UnitState -> UnitId -> Bool isUnitIdTrusted ue u = - Set.member u (trustedUnits ue) && (Set.notMember u (distrustedUnits ue)) + elementOfUniqSet u (trustedUnits ue) && (not $ elementOfUniqSet u (distrustedUnits ue)) || unitIsTrusted (unsafeLookupUnitId ue u) +-- | Do we trust the 'UnitInfo' for the given 'Unit'? +isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool +isUnitTrusted ue u = + isUnitIdTrusted ue (toUnitId u) + +-- | Do we trust the given 'UnitInfo'? isUnitInfoTrusted :: HasDebugCallStack => UnitState -> UnitInfo -> Bool isUnitInfoTrusted ue unit_info = - Set.member (unitId unit_info) (trustedUnits ue) && (Set.notMember (unitId unit_info) (distrustedUnits ue)) - || unitIsTrusted unit_info + isUnitIdTrusted ue (unitId unit_info) -- ---------------------------------------------------------------------------- -- Loading the unit db files and building up the unit state @@ -714,22 +440,22 @@ isUnitInfoTrusted ue unit_info = -- command-line (@-package@, @-hide-package@ etc.) -- -- 'initUnits' can be called again subsequently after updating the --- 'packageFlags' field of the 'DynFlags', and it will update the --- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> IORef UnitIndex -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants) +-- 'packageFlags' and 'packageDBFlags' fields of the 'DynFlags', and it will +-- update the 'unitState' in 'DynFlags'. +initUnits :: Logger -> DynFlags -> UnitIndexCache -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants) initUnits logger dflags unit_index cached_dbs home_units = do let forceUnitInfoMap state = unitInfoMap state `seq` () unit_state <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger unit_index (initUnitConfig dflags cached_dbs home_units) + $ mkUnitState logger unit_index cached_dbs (initUnitConfig dflags home_units) putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - wireMap <- ui_wireMap <$> readIORef unit_index + wireMap <- wiringMap <$> readUnitIndex unit_index let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) @@ -756,7 +482,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do return (unit_state,home_unit,mconstants) mkHomeUnit - :: WiringMap + :: WireMap -> UnitId -- ^ Home unit id -> Maybe UnitId -- ^ Home unit instance of -> [(ModuleName, Module)] -- ^ Home unit instantiations @@ -765,7 +491,7 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = let -- Some wired units can be used to instantiate the home unit. We need to -- replace their unit keys with their wired unit ids. - hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_ + hu_instantiations = map (fmap (updateWiredInUnitIdInModule wmap)) hu_instantiations_ in case (hu_instanceof, hu_instantiations) of (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") @@ -782,205 +508,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. @@ -989,9 +516,9 @@ applyTrustFlag :: UnitPrecedenceMap -> UnusableUnits -> [UnitInfo] - -> (Set.Set UnitId, Set.Set UnitId) + -> (UniqSet UnitId, UniqSet UnitId) -> TrustFlag - -> MaybeErr UnitErr (Set.Set UnitId, Set.Set UnitId) + -> MaybeErr UnitErr (UniqSet UnitId, UniqSet UnitId) applyTrustFlag prec_map unusable pkgs (trusted, distrusted) flag = case flag of -- we trust all matching packages. Maybe should only trust first one? @@ -1006,11 +533,11 @@ applyTrustFlag prec_map unusable pkgs (trusted, distrusted) flag = Left ps -> Failed (TrustFlagErr flag ps) Right (ps,_) -> Succeeded (removeAll ps trusted, insertAll ps distrusted) -insertAll :: [UnitInfo] -> Set UnitId -> Set UnitId -insertAll elements set = foldl' (\ acc -> flip Set.insert acc . unitId) set elements +insertAll :: [UnitInfo] -> UniqSet UnitId -> UniqSet UnitId +insertAll elements set = foldl' (\ acc -> addOneToUniqSet acc . unitId) set elements -removeAll :: [UnitInfo] -> Set UnitId -> Set UnitId -removeAll elements set = foldl' (\ acc -> flip Set.delete acc . unitId) set elements +removeAll :: [UnitInfo] -> UniqSet UnitId -> UniqSet UnitId +removeAll elements set = foldl' (\ acc -> addOneToUniqSet acc . unitId) set elements applyPackageFlag :: UnitPrecedenceMap @@ -1094,267 +621,8 @@ 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) +updateVisibilityMap :: WireMap -> VisibilityMap -> VisibilityMap +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (listWireMap wiredInMap) where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of Nothing -> vm Just r -> addToUniqMap (delFromUniqMap vm (RealUnit (Definite from))) @@ -1362,51 +630,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 +639,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 @@ -1610,10 +646,11 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger - -> IORef UnitIndex + -> UnitIndexCache + -> ExternalUnitDatabaseCache UnitId -> UnitConfig -> IO UnitState -mkUnitState logger unit_index cfg = do +mkUnitState logger unit_index_cache db_cache cfg = do {- Plan. @@ -1667,17 +704,17 @@ 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 db_cache (initUnitDbConfig cfg) -- distrust all units if the flag is set - let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) - allUnits = Set.unions $ map unitsOf raw_dbs + let unitsOf db = foldl' (\ acc ui -> addOneToUniqSet acc (unitId ui)) emptyUniqSet (unitDatabaseUnits db) + allUnits = unionManyUniqSets $ map unitsOf raw_dbs distrustedUnits | unitConfigDistrustAll cfg = allUnits - | otherwise = Set.empty + | otherwise = emptyUniqSet - trustedUnits = Set.empty + trustedUnits = emptyUniqSet dbs = raw_dbs @@ -1697,7 +734,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 @@ -1773,19 +810,19 @@ mkUnitState logger unit_index cfg = do -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. -- - ui <- readIORef unit_index + ui <- readUnitIndex unit_index_cache (wired_map, pkgs2) <- do - wireMap <- if isWireMapEmpty ui + wireMap <- if not (wireMapExists ui) then do wmap <- findWiredInUnits logger prec_map pkgs1 vis_map2 - modifyIORef' unit_index (setWireMap wmap) + modifyUnitIndexCache unit_index_cache (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) + modifyUnitIndexCache unit_index_cache (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (wireMap, map (either id id) all_pkgs) let pkg_db = mkUnitInfoMap pkgs2 @@ -1859,7 +896,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,10 +909,8 @@ 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 } @@ -1893,157 +928,15 @@ 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) - +initUnitDbConfig :: UnitConfig -> UnitDbConfig +initUnitDbConfig uc = UnitDbConfig + { unitDbConfigFlagsDB = unitConfigFlagsDB uc + , unitDbConfigProgramName = unitConfigProgramName uc + , unitDbConfigDBName = unitConfigDBName uc + , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc + , unitDbConfigGlobalDB = unitConfigGlobalDB uc + , unitDbConfigGHCDir = unitConfigGHCDir uc + } -- ----------------------------------------------------------------------------- -- Package Utils @@ -2185,7 +1078,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 +1092,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 +1150,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 +1182,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. -} @@ -655,7 +655,7 @@ be it either hadrian or cabal, knows exactly the unit-id it passed with -this-un Note that we also ensure the ghc's unit key matches its unit id, both when hadrian or cabal is building ghc. This way, we no longer need to add `ghc` to -the WiringMap, and that's why 'wiredInUnitIds' no longer includes +the WireMap, and that's why 'wiredInUnitIds' no longer includes 'thisGhcUnitId'. -} ===================================== 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.ModuleOrigin + GHC.Unit.External.Providers + GHC.Unit.External.Query + GHC.Unit.External.Substitution + GHC.Unit.External.Validate + GHC.Unit.External.Visibility + GHC.Unit.External.Wired GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== ghc/GHCi/UI.hs ===================================== @@ -855,7 +855,7 @@ installInteractiveHomeUnits dflags = do setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv setupHomeUnitFor logger dflags all_home_units = do env <- GHC.getSession - let unit_index = hsc_unit_index env + let unit_index = hscUIC env (unit_state,home_unit,_mconstants) <- liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units hpt <- liftIO emptyHomePackageTable ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -547,7 +547,7 @@ generateConfigHs = do -- See Note [GHC's Unit Id] in GHC.Unit.Types -- -- It's crucial that the unit-id matches the unit-key -- ghc is no longer - -- part of the WiringMap, so we don't to go back and forth between the + -- part of the WireMap, so we don't to go back and forth between the -- unit-id and the unit-key -- we take care that they are the same by using -- 'pkgUnitId' on 'compiler' (the ghc-library package) to create the -- unit-id in both situations. ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -227,6 +227,15 @@ GHC.Types.Var.Env GHC.Types.Var.FV GHC.Types.Var.Set GHC.Unit +GHC.Unit.External.Database +GHC.Unit.External.Index +GHC.Unit.External.ModuleOrigin +GHC.Unit.External.Providers +GHC.Unit.External.Query +GHC.Unit.External.Substitution +GHC.Unit.External.Validate +GHC.Unit.External.Visibility +GHC.Unit.External.Wired GHC.Unit.Home GHC.Unit.Info GHC.Unit.Module ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -69,6 +69,7 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Types.Name.Cache import GHC.Unit +import GHC.Unit.External.Index import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba143db3fc92bcc1abcbde08d427fc4a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba143db3fc92bcc1abcbde08d427fc4a... 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