Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: a91af86b by fendor at 2026-07-14T13:12:54+02:00 WIP: Introduce UnitIndex for global data - - - - - 7ffa36d7 by fendor at 2026-07-15T13:31:58+02:00 Split State.hs into many more modules - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Types/Unique.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/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 - libraries/ghc-boot/GHC/Unit/Database.hs - 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 (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index 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_eud old_unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -779,6 +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 } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -837,6 +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 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -884,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_eud unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure HomeUnitEnv ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -175,6 +175,8 @@ withBkpSession :: UnitId -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags + env <- getSession + unitIndex <- liftIO $ hscUnitIndex env let cid_fs = unitFS cid is_primary = False uid_str = unpackFS (mkInstantiatedUnitHash cid insts) @@ -194,8 +196,8 @@ withBkpSession cid insts deps session_type do_this = do | otherwise = sub_comp (key_base p) mk_temp_env hsc_env = - hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env - mk_temp_dflags unit_state dflags = dflags + hscUpdateFlags (\dflags -> mk_temp_dflags unitIndex (hsc_units hsc_env) dflags) hsc_env + mk_temp_dflags unit_index unit_state dflags = dflags { backend = case session_type of TcSession -> noBackend _ -> backend dflags @@ -242,7 +244,7 @@ withBkpSession cid insts deps session_type do_this = do , importPaths = [] -- Synthesize the flags , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnit unit_state + let uid = unwireUnit unit_index $ renameHoleUnit unit_state (listToUFM insts) uid0 in ExposePackage (showSDoc dflags @@ -349,9 +351,9 @@ buildUnit session cid insts lunit = do | otherwise = [Nothing] linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env) + unit_index <- liftIO $ hscUnitIndex hsc_env let obj_files = concatMap linkableFiles linkables - state = hsc_units hsc_env compat_fs = unitIdFS cid compat_pn = PackageName compat_fs @@ -377,7 +379,7 @@ buildUnit session cid insts lunit = do -- really used for anything, so we leave it -- blank for now. TcSession -> [] - _ -> map (toUnitId . unwireUnit state) + _ -> map (toUnitId . unwireUnit unit_index) $ deps ++ [ moduleUnit mod | (_, mod) <- insts , not (isHoleModule mod) ], @@ -449,7 +451,7 @@ addUnit u = do { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] } - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 eud (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env) -- update platform constants @@ -467,6 +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 } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -13,6 +13,8 @@ module GHC.Driver.Env , hsc_HUE , hsc_HUG , hsc_all_home_unit_ids + , hscUnitIndex + , hsc_unit_index , hscUpdateLoggerFlags , hscUpdateHUG , hscInsertHPT @@ -230,6 +232,12 @@ hscEUD = readExternalUnitDatabases . hscEUDC 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) + +hsc_unit_index :: HscEnv -> IORef UnitIndex +hsc_unit_index hsc_env = ue_unit_index (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 (hscEUDC hsc_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants emptyHpt <- liftIO $ emptyHomePackageTable ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -126,8 +126,8 @@ Prefer `env_ut :: Char` and -- for fast ordering and equality tests. You should generate these with -- the functions from the 'UniqSupply' module -- --- These are sometimes also referred to as \"keys\" in comments in GHC. newtype Unique = MkUnique Word64 +-- These are sometimes also referred to as \"keys\" in comments in GHC. data UniqueTag = AlphaTyVarTag ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -131,6 +131,7 @@ import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import Data.IORef -------------------------------------------------------------------------------- -- The hard queries @@ -177,6 +178,8 @@ data UnitEnv = UnitEnv , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId) -- TODO: @fendor Docs + , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex) + -- TODO: @fendor Docs } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -186,6 +189,7 @@ initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitE initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache eud <- initExternalUnitDatabaseCache + unit_index <- newIORef (initUnitIndex) return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug @@ -194,6 +198,7 @@ initUnitEnv cur_unit hug namever platform = do , ue_platform = platform , ue_namever = namever , ue_eud = eud + , ue_unit_index = unit_index } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -14,18 +14,59 @@ module GHC.Unit.External.Database ( lookupExternalUnitDatabases, -- * UnitDatabase (..), + -- * + mergeDatabases, + validateDatabase, + UnitPrecedenceMap, + sortByPreference, + compareByPreference, + -- * + UnitDbConfig(..), + readOrGetUnitDatabase, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, + -- * + matchingStr, + matchingId, + matching, ) where import GHC.Prelude -import GHC.Data.OsPath -import GHC.Unit.Info -import GHC.Utils.Outputable +import GHC.Driver.DynFlags -import Data.IORef (IORef) +import Control.Monad +import Data.Char +import Data.Graph (SCC (..), stronglyConnComp) +import Data.IORef import Data.IORef qualified as IORef -import Data.Map.Strict +import Data.List (partition, sortBy) +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Ord +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST +import GHC.Platform.ArchOS +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import System.Directory +import System.Environment (getEnv) +import System.FilePath as FilePath -- ---------------------------------------------------------------------------- -- ExternalUnitDatabaseCache @@ -102,3 +143,422 @@ 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) + +-- | 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 + ] + + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +data UnitDbConfig = UnitDbConfig + { unitDbConfigFlagsDB :: [PackageDBFlag] + , unitDbConfigProgramName :: String + , unitDbConfigDBName :: FilePath + , unitDbConfigPlatformArchOS :: ArchOS + , unitDbConfigGlobalDB :: FilePath + , unitDbConfigGHCDir :: FilePath + , unitDbConfigDBCache :: ExternalUnitDatabaseCache UnitId + } + +readUnitDatabases :: Logger -> UnitDbConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readOrGetUnitDatabase logger cfg) confs + + +getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg) + let pkgconf = dir </> unitDbConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. +readOrGetUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger cfg conf_file = + readExternalUnitDatabase (unitDbConfigDBCache cfg) conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase (unitDbConfigDBCache cfg) new_db + pure new_db + Just db -> + pure db + +-- | Read the 'UnitDatabase' at the given location. +readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do + isdir <- OsPath.doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- OsPath.doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ show conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ show conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) + pkgroot = OsPath.takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) + proto_pkg_configs + -- + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 + where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename + if cache_exists + then do + debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg logger 2 $ text "There is no package.cache in" + <+> ppr conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg logger 3 $ text "There are no .conf files in" + <+> ppr conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ show conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +mungeUnitInfo :: OsPath -> OsPath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeBytecodeLibFields + . mungeLibDirFields + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) + +mungeLibDirFields :: UnitInfo -> UnitInfo +mungeLibDirFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- ---------------------------------------------------------------------------- +-- +-- 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. + +-- 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 ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -0,0 +1,189 @@ +module GHC.Unit.External.Index ( + -- * + UnitIndex, + initUnitIndex, + wiringMap, + unwiringMap, + globalUnits, + setWireMap, + isWireMapEmpty, + addUnitInfoMap, + + -- * + GlobalUnitInfoMap, + lookupGlobalUnitInfoMap, + mkGlobalUnitKey, + + -- * + GlobalUnitKey, + globalUnitKeyFromUnitInfo, + + -- * + updateWiredInUnits, + updateWiredInUnitsInUnitInfo, + upd_wired_in_mod, +) where + +import GHC.Prelude + +import GHC.Data.ShortText qualified as ST +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Wired +import GHC.Unit.Info +import GHC.Unit.Types + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import GHC.Utils.Misc + +-- ---------------------------------------------------------------------------- +-- UnitIndex +-- ---------------------------------------------------------------------------- + +data UnitIndex = UnitIndex + { ui_wireMap :: !WiringMap + -- ^ A mapping from database unit keys to wired in unit ids. + , ui_unwireMap :: !UnwiringMap + -- ^ A mapping from wired in unit ids to unit keys from the database. + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: document + } + +wiringMap :: UnitIndex -> UnwiringMap +wiringMap = ui_unwireMap + +unwiringMap :: UnitIndex -> WiringMap +unwiringMap = ui_wireMap + +globalUnits :: UnitIndex -> GlobalUnitInfoMap +globalUnits = ui_unitInfoMap + +initUnitIndex :: UnitIndex +initUnitIndex = UnitIndex + { ui_wireMap = emptyUniqMap + , ui_unwireMap = emptyUniqMap + , ui_unitInfoMap = emptyUniqMap + } + +setWireMap :: WiringMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + } + +isWireMapEmpty :: UnitIndex -> Bool +isWireMapEmpty unit_index = + isNullUniqMap (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) + } + where + globalMap :: GlobalUnitInfoMap + globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map + +-- ---------------------------------------------------------------------------- +-- GlobalUnitInfoMap +-- ---------------------------------------------------------------------------- + +type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) + +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = + case lookupUniqMap globalMap uid of + Nothing -> Nothing + Just sameUnitId -> Map.lookup abiHash sameUnitId + +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap +mkGlobalUnitInfoMap unitInfos = + listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos + +-- ---------------------------------------------------------------------------- +-- GlobalUnitKey +-- ---------------------------------------------------------------------------- + +data GlobalUnitKey = + GlobalUnitKey + !UnitId -- ^ Unit Id of the 'UnitInfo' + !ST.ShortText + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) + +mkGlobalUnitKey :: UnitId -> ST.ShortText -> GlobalUnitKey +mkGlobalUnitKey = GlobalUnitKey + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_wired_in_pkg wiredInUnitId pkg = + pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupUniqMap wiredInMap (unitId pkg) of + Just wiredIn -> + case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +upd_wired_in_mod :: WiringMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiringMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WiringMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupUniqMap wiredInMap key = key' + | otherwise = key ===================================== compiler/GHC/Unit/External/ModuleOrigin.hs ===================================== @@ -0,0 +1,110 @@ +module GHC.Unit.External.ModuleOrigin ( + ModuleOrigin(..), + fromExposedModules, + fromReexportedModules, + fromFlag, + originVisible, + originEmpty, +) where + +import GHC.Prelude +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Data.Semigroup as Semigroup + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) rhs)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + g Nothing x = x + g x Nothing = x + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False ===================================== compiler/GHC/Unit/External/Providers.hs ===================================== @@ -0,0 +1,32 @@ +module GHC.Unit.External.Providers ( + ModuleNameProvidersMap, + pprModuleMap, +) where + +import GHC.Prelude + +import GHC.Types.Unique.Map +import GHC.Unit.Module +import GHC.Unit.External.ModuleOrigin +import GHC.Utils.Error +import GHC.Utils.Outputable + +-- | 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) ===================================== compiler/GHC/Unit/External/Validate.hs ===================================== @@ -0,0 +1,79 @@ +module GHC.Unit.External.Validate ( + UnusableUnits, + reportUnusable, + + UnusableUnit(..), + + UnusableUnitReason(..), + pprReason, +) where + +import GHC.Prelude + +import GHC.Unit.Types +import GHC.Types.Unique.Map +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Logger +import Control.Monad +import GHC.Utils.Error + +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 ===================================== 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,143 @@ +module GHC.Unit.External.Wired ( + WiringMap, + UnwiringMap, + findWiredInUnits, +) where +import GHC.Types.Unique.Map +import GHC.Unit.Types + +import GHC.Prelude + +import GHC.Driver.DynFlags + +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Ppr +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Unit.Home + +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.DSet +import GHC.Types.Unique.Map +import GHC.Types.Unique +import GHC.Types.PkgQual + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Data.Maybe + +import System.Environment ( getEnv ) +import GHC.Data.FastString +import GHC.Data.OsPath ( OsPath ) +import qualified GHC.Data.OsPath as OsPath +import qualified GHC.Data.ShortText as ST +import GHC.Utils.Logger +import GHC.Utils.Error +import GHC.Utils.Exception + +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 GHC.Unit.External.Visibility + +type WiringMap = + UniqMap UnitId UnitId + +type UnwiringMap = + UniqMap UnitId UnitId + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +findWiredInUnits + :: Logger + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO WiringMap -- map from unit id to wired identity +findWiredInUnits logger prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Types + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] + where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + + notfound = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (UnitId, UnitInfo) + pick pkg = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (wired_pkg, pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + return wiredInMap ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -5,11 +5,14 @@ module GHC.Unit.Info ( GenericUnitInfo (..) , GenUnitInfo , UnitInfo + , UnitInfoMap , UnitKey (..) , UnitKeyInfo , mkUnitKeyInfo , mapUnitInfo , mkUnitPprInfo + , evaluateUnitInfo + , seqUnitInfo , mkUnit @@ -53,6 +56,8 @@ import Data.Containers.ListUtils (nubOrd) import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix) +import GHC.Types.Unique.Map +import Control.Exception (evaluate) -- | Information about an installed unit @@ -73,6 +78,9 @@ type UnitKeyInfo = GenUnitInfo UnitKey -- UnitId) type UnitInfo = GenUnitInfo UnitId +-- TODO @fendor +type UnitInfoMap = UniqMap UnitId UnitInfo + -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo @@ -250,3 +258,21 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar expandTag t | null t = "" | otherwise = '_':t + +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) + +seqUnitInfo :: UnitInfo -> b -> b +seqUnitInfo ui b = + unitImportDirs ui `seqList` + unitIncludeDirs ui `seqList` + unitLibraryDirs ui `seqList` + unitLibraryBytecodeDirs ui `seqList` + unitExtDepFrameworkDirs ui `seq` + unitHaddockInterfaces ui `seq` + unitHaddockHTMLs ui `seqList` + unitLibraryDynDirs ui `seqList` + unitLibraryDirsStatic ui `seqList` + unitDepends ui `seqList` + unitExposedModules ui `seqList` + b ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Unit.State ( module GHC.Unit.Info, - UnitIndex(..), + UnitIndex, initUnitIndex, setWireMap, isWireMapEmpty, @@ -26,7 +26,6 @@ module GHC.Unit.State ( listUnitInfo, -- * Querying the package config - UnitInfoMap, lookupUnit, lookupUnit', unsafeLookupUnit, @@ -96,6 +95,14 @@ import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home +import GHC.Unit.External.Database +import GHC.Unit.External.Index +import GHC.Unit.External.Wired +import GHC.Unit.External.Visibility +import GHC.Unit.External.Validate +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Providers + import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.DSet @@ -108,28 +115,19 @@ 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.Utils.Error -import GHC.Utils.Exception -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.Graph (SCC(..)) 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) @@ -177,162 +175,6 @@ import Data.Either (partitionEithers) -- 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 @@ -357,9 +199,6 @@ data UnitConfig = UnitConfig , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default , unitConfigDBCache :: !(ExternalUnitDatabaseCache UnitId) - -- ^ Cache of databases to use, in the order they were specified on the - -- command line (later databases shadow earlier ones). - -- If Nothing, databases will be found using `unitConfigFlagsDB`. -- command-line flags , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags @@ -423,58 +262,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 - -data UnitIndex = UnitIndex - { ui_wireMap :: WiringMap - -- ^ TODO @fendor: document global property - , ui_unwireMap :: UnwiringMap - -- ^ TODO @fendor: document global property - , ui_unitInfoMap :: UnitInfoMap - -- ^ TODO @fendor: This needs to be Map (UnitId, AbiHash) UnitInfo for absolut correctness - } - -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 = unit_info_map `plusUniqMap` ui_unitInfoMap unit_index - } - --- 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 @@ -495,12 +282,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. @@ -555,8 +336,6 @@ 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) @@ -593,7 +372,6 @@ lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid 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 @@ -711,7 +489,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - wireMap <- ui_wireMap <$> readIORef unit_index + wireMap <- wiringMap <$> readIORef unit_index let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) @@ -764,210 +542,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 - } - -evaluateUnitInfo :: UnitInfo -> IO UnitInfo -evaluateUnitInfo ui = do - importDirs <- evaluate $ unitImportDirs ui - includeDirs <- evaluate $ unitIncludeDirs ui - libraryDirs <- evaluate $ unitLibraryDirs ui - libraryBytecodeDirs <- evaluate $ unitLibraryBytecodeDirs ui - extDepFrameworkDirs <- evaluate $ unitExtDepFrameworkDirs ui - haddockInterfaces <- evaluate $ unitHaddockInterfaces ui - haddockHTMLs <- evaluate $ unitHaddockHTMLs ui - libraryDynDirs <- evaluate $ unitLibraryDynDirs ui - libraryDirsStatic <- evaluate $ unitLibraryDirsStatic ui - evaluate ui - { unitImportDirs = importDirs - , unitIncludeDirs = includeDirs - , unitLibraryDirs = libraryDirs - , unitLibraryDynDirs = libraryDynDirs - , unitLibraryDirsStatic = libraryDirsStatic - , unitLibraryBytecodeDirs = libraryBytecodeDirs - , unitExtDepFrameworkDirs = extDepFrameworkDirs - , unitHaddockInterfaces = haddockInterfaces - , unitHaddockHTMLs = haddockHTMLs - } - -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -1134,57 +708,6 @@ renameUnitInfo pkg_map insts conf = (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 @@ -1195,143 +718,6 @@ 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 -> UnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] -updateWiredInUnits wiredInMap knownInfos pkgs = - map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs - -updateWiredInUnitsInUnitInfo :: WiringMap -> UnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo -updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = - let - upd_pkg pkg - | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId 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 - } - | otherwise - = pkg - 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 knownInfos (unitId pkg) of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps $ upd_pkg pkg - in - Left updated_pkg - --- Helper functions for rewiring Module and Unit. These --- rewrite Units of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. --- --- For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in GHC.Builtin.Names. - -upd_wired_in_mod :: WiringMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiringMap -> Unit -> Unit -upd_wired_in_uid wiredInMap u = case u of - HoleUnit -> HoleUnit - RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) - VirtUnit indef_uid -> - VirtUnit $ mkInstantiatedUnit - (instUnitInstanceOf indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) - -upd_wired_in :: WiringMap -> UnitId -> UnitId -upd_wired_in wiredInMap key - | Just key' <- lookupUniqMap wiredInMap key = key' - | otherwise = key - updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of @@ -1341,51 +727,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 @@ -1395,193 +736,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 @@ -1646,7 +800,7 @@ mkUnitState logger unit_index cfg = do we build a mapping saying what every in scope module name points to. -} - raw_dbs <- readUnitDatabases logger cfg + raw_dbs <- readUnitDatabases logger (initUnitDbConfig cfg) -- distrust all units if the flag is set let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) @@ -1669,14 +823,14 @@ mkUnitState logger unit_index cfg = do debugTraceMsg logger 2 $ text "package flags" <+> ppr other_flags - let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags + let !home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags -- Merge databases together, without checking validity (pkg_map1, prec_map) <- mergeDatabases logger dbs -- 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 @@ -1725,12 +879,12 @@ mkUnitState logger unit_index cfg = do -- Note: we NEVER expose indefinite packages by -- default, because it's almost assuredly not -- what you want (no mix-in linking has occurred). - if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + let !x = fsPackageName p in if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p then addToUniqMap vm (mkUnit p) UnitVisibility { uv_expose_all = True, uv_renamings = [], - uv_package_name = First (Just (fsPackageName p)), + uv_package_name = First (Just x), uv_requirements = emptyUniqMap, uv_explicit = Nothing } @@ -1760,9 +914,9 @@ mkUnitState logger unit_index cfg = do modifyIORef' unit_index (setWireMap wmap) pure wmap else do - pure $ ui_wireMap ui + pure $ wiringMap ui - let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + let all_pkgs = updateWiredInUnits wireMap (globalUnits ui) pkgs1 (new_pkgs, _pkgs_set) = partitionEithers all_pkgs modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (wireMap, map (either id id) all_pkgs) @@ -1853,13 +1007,22 @@ mkUnitState logger unit_index cfg = do , moduleNameProvidersMap = mod_map , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map , packageNameMap = pkgname_map - -- , wireMap = wired_map - -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } return state +initUnitDbConfig :: UnitConfig -> UnitDbConfig +initUnitDbConfig uc = UnitDbConfig + { unitDbConfigFlagsDB = unitConfigFlagsDB uc + , unitDbConfigProgramName = unitConfigProgramName uc + , unitDbConfigDBName = unitConfigDBName uc + , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc + , unitDbConfigGlobalDB = unitConfigGlobalDB uc + , unitDbConfigGHCDir = unitConfigGHCDir uc + , unitDbConfigDBCache = unitConfigDBCache uc + } + selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True selectHptFlag _ _ = False @@ -1872,12 +1035,11 @@ 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) + maybe uid (RealUnit . Definite) (lookupUniqMap (unwiringMap state) def_uid) unwireUnit _ uid = uid -- ----------------------------------------------------------------------------- @@ -2164,7 +1326,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) @@ -2307,17 +1469,6 @@ 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) - fsPackageName :: UnitInfo -> FastString fsPackageName info = fs where ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -1,6 +1,3 @@ module GHC.Unit.State where data UnitState -data ModuleSuggestion -data ModuleOrigin -data UnusableUnit ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -578,7 +578,7 @@ had used @-ignore-package@). The affected packages are compiled with, e.g., @-this-unit-id base@, so that the symbols in the object files have the unversioned unit id in their name. -Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. +Make sure you change 'wiredInUnitIds' if you add an entry here. -} ===================================== compiler/ghc.cabal.in ===================================== @@ -968,6 +968,12 @@ 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.Validate + GHC.Unit.External.Visibility + GHC.Unit.External.Wired GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== ghc/GHCi/UI.hs ===================================== @@ -855,8 +855,9 @@ 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 (unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags (hscEUDC env) all_home_units + liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units hpt <- liftIO emptyHomePackageTable pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -746,11 +746,20 @@ mungeUnitInfoPaths top_dir pkgroot pkg = , unitHaddockHTMLs = munge_paths (munge_urls (unitHaddockHTMLs pkg)) } where - munge_paths = map munge_path - munge_urls = map munge_url + munge_paths = strictMap munge_path + munge_urls = strictMap munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. -- Prefer 'decodeUtf' and gracious error handling. unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath unsafeDecodeUtf = OsPath.Internal.so + +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x:xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -260,7 +260,9 @@ haddockWithGhc ghc args = handleTopExceptions $ do logger' <- getLogger let logger = setLogFlags logger' (initLogFlags dflags) let parserOpts = Parser.initParserOpts dflags - !unit_state <- hsc_units <$> getSession + env <- getSession + let !unit_state = hsc_units env + !unit_index <- liftIO $ hscUnitIndex env -- If any --show-interface was used, show the given interfaces forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do @@ -287,7 +289,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages ifaces + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages ifaces -- If we were not given any input files, error if documentation was -- requested @@ -300,7 +302,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages [] + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -356,6 +358,7 @@ renderStep :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -364,7 +367,7 @@ renderStep -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem pkgs interfaces = do +renderStep dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem pkgs interfaces = do updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> docPathsHtml docPath @@ -380,7 +383,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags parserOpts logger unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap + render dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap where -- get package name from unit-id packageName :: Unit -> String @@ -394,6 +397,7 @@ render :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -403,7 +407,7 @@ render -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () -render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do +render dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do let packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) $ optPackageName flags @@ -505,7 +509,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces p -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_index (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn' = hPutStrLn stderr . ("Warning: " ++) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/747315c39653ecf12f598554bc1258d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/747315c39653ecf12f598554bc1258d... 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