Andreas Klebinger pushed to branch wip/andreask/hadrian_race at Glasgow Haskell Compiler / GHC Commits: 1b7bcd0d by Andreas Klebinger at 2026-02-06T21:01:35+01:00 ghc-pkg: Rework locking to make it more stable under concurrent accesses. ghc-pkg will now keep a database locked while reading it. See Note [ghc-pkg database locking] for details. I also killed of the remaining workarounds for single file package databases. This should fix #22870. - - - - - 3 changed files: - docs/users_guide/9.16.1-notes.rst - libraries/ghc-boot/GHC/Unit/Database.hs - utils/ghc-pkg/Main.hs Changes: ===================================== docs/users_guide/9.16.1-notes.rst ===================================== @@ -160,6 +160,13 @@ Cmm the recompilation checker will look at to determine if a module needs to be recompiled. +``ghc-pkg`` utility +~~~~~~~~~~~~~~~~~~~ + +- A slight rework how package databases are being locked should make ghc-pkg more + reliable when multiple invocations try to read/modify a package database at the + same time. + Included libraries ~~~~~~~~~~~~~~~~~~ ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -58,6 +58,9 @@ module GHC.Unit.Database , DbMode(..) , DbOpenMode(..) , isDbOpenReadMode + , dbMode + , modeWithLock + , readPackageDbForGhc , readPackageDbForGhcPkg , writePackageDb @@ -65,6 +68,7 @@ module GHC.Unit.Database , PackageDbLock , lockPackageDb , unlockPackageDb + , withLockedPackageDb -- * Misc , mkMungePathUrl , mungeUnitInfoPaths @@ -313,6 +317,22 @@ data DbInstUnitId -- | Represents a lock of a package db. newtype PackageDbLock = PackageDbLock Handle +-- | Run the action under a lock, then return the result. +-- If the mode is R/W the *caller* needs to either free the lock or pass it +-- on to code that will. +-- +-- If an exception is raised the lock is released. +withLockedPackageDb :: DbOpenMode m t -> FilePath -> (PackageDbLock -> IO a) -> IO a +withLockedPackageDb mode file act = do + lock <- lockPackageDbWith (lock_mode mode) file + r <- act lock `onException` unlockPackageDb lock + when (isDbOpenReadMode mode ) $ unlockPackageDb lock + pure r + where + lock_mode :: DbOpenMode m t -> LockMode + lock_mode DbOpenReadOnly = SharedLock + lock_mode DbOpenReadWrite{} = ExclusiveLock + -- | Acquire an exclusive lock related to package DB under given location. lockPackageDb :: FilePath -> IO PackageDbLock @@ -362,12 +382,13 @@ lockPackageDbWith mode file = do return $ PackageDbLock hnd lockPackageDb = lockPackageDbWith ExclusiveLock + unlockPackageDb (PackageDbLock hnd) = do hUnlock hnd hClose hnd -- | Mode to open a package db in. -data DbMode = DbReadOnly | DbReadWrite +data DbMode = DbReadOnly | DbReadWrite deriving Eq -- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So -- it is like 'Maybe' but with a type argument for the mode to enforce that the @@ -380,6 +401,14 @@ deriving instance Functor (DbOpenMode mode) deriving instance F.Foldable (DbOpenMode mode) deriving instance F.Traversable (DbOpenMode mode) +dbMode :: DbOpenMode m t -> DbMode +dbMode DbOpenReadOnly = DbReadOnly +dbMode DbOpenReadWrite{} = DbReadWrite + +modeWithLock :: PackageDbLock -> DbOpenMode m t -> DbOpenMode m PackageDbLock +modeWithLock _ DbOpenReadOnly = DbOpenReadOnly +modeWithLock l DbOpenReadWrite{} = DbOpenReadWrite l + isDbOpenReadMode :: DbOpenMode mode t -> Bool isDbOpenReadMode = \case DbOpenReadOnly -> True @@ -388,9 +417,11 @@ isDbOpenReadMode = \case -- | Read the part of the package DB that GHC is interested in. -- readPackageDbForGhc :: FilePath -> IO [DbUnitInfo] -readPackageDbForGhc file = - decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case - (pkgs, DbOpenReadOnly) -> return pkgs +readPackageDbForGhc file = do + hPutStrLn stderr $ "readPackageDbForGhc:" ++ show file + withLockedPackageDb DbOpenReadOnly file $ \_ -> do + decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case + (pkgs, DbOpenReadOnly) -> return pkgs where getDbForGhc = do _version <- getHeader @@ -405,11 +436,13 @@ readPackageDbForGhc file = -- is not defined in this package. This is because ghc-pkg uses Cabal types -- (and Binary instances for these) which this package does not depend on. -- +-- The incoming mode carries the exclusive lock if we are in R/W mode. +-- -- If we open the package db in read only mode, we get its contents. Otherwise -- we additionally receive a PackageDbLock that represents a lock on the -- database, so that we can safely update it later. -- -readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t -> +readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode PackageDbLock -> IO (pkgs, DbOpenMode mode PackageDbLock) readPackageDbForGhcPkg file mode = decodeFromFile file mode getDbForGhcPkg @@ -496,26 +529,19 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0" -- | Feed a 'Get' decoder with data chunks from a file. -- -decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs -> +-- The file is already locked when we call this. We only need to pass it on +-- if we are in R/W mode. +decodeFromFile :: FilePath -> DbOpenMode mode PackageDbLock -> Get pkgs -> IO (pkgs, DbOpenMode mode PackageDbLock) decodeFromFile file mode decoder = case mode of DbOpenReadOnly -> do - -- Note [Locking package database on Windows] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- When we open the package db in read only mode, there is no need to acquire - -- shared lock on non-Windows platform because we update the database with an - -- atomic rename, so readers will always see the database in a consistent - -- state. -#if defined(mingw32_HOST_OS) - bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do -#endif (, DbOpenReadOnly) <$> decodeFileContents DbOpenReadWrite{} -> do - -- When we open the package db in read/write mode, acquire an exclusive lock - -- on the database and return it so we can keep it for the duration of the + -- When we open the package db in read/write mode, we receive an exclusive lock + -- on the database via the mode and return it so we can keep it for the duration of the -- update. - bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do - (, DbOpenReadWrite lock) <$> decodeFileContents + -- If an exception is raised the caller releases the lock. + (, mode) <$> decodeFileContents where decodeFileContents = withBinaryFile file ReadMode $ \hnd -> feed hnd (runGetIncremental decoder) ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -8,6 +8,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-} -- Fine if this comes from make/Hadrian or the pre-built base. @@ -872,6 +873,23 @@ lookForPackageDBIn dir = do exists_file <- doesFileExist path_file if exists_file then return (Just path_file) else return Nothing +{- Note [ghc-pkg database locking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We differentiate the read only (RO) and read write (R/W) cases. + +The general idea is we use `withLockedPackageDb` to lock an already existing +database in both modes. In RO mode we simply unlock the DB once we read it. +The unlocking is also handled by withLockedPackageDb. + +For the R/W case withLockedPackageDb will *lock* the database, and handle unlocking +in the case of exceptions. But rather than unlocking it once the argument has been +executed without error we simply pass along the lock inside either a `DbOpenMode` or `PackageDB` +so we can keep holding while doing one or more modifications. + +The alternative would be to rewrite much of this in a CPS/bracket style and I couldn't +quite bring myself to do so. + +-} readParseDatabase :: forall mode t. Verbosity -> Maybe (FilePath,Bool) -> GhcPkg.DbOpenMode mode t @@ -889,83 +907,79 @@ readParseDatabase verbosity mb_user_conf mode use_cache path = do e <- tryIO $ getDirectoryContents path case e of Left err - | ioeGetErrorType err == InappropriateType -> do - -- We provide a limited degree of backwards compatibility for - -- old single-file style db: - mdb <- tryReadParseOldFileStyleDatabase verbosity - mb_user_conf mode use_cache path - case mdb of - Just db -> return db - Nothing -> - die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" - ++ "to create the database with the correct format." - + | ioeGetErrorType err == InappropriateType -> dieOnSingleFileDb path | otherwise -> ioError err - Right fs - | not use_cache -> ignore_cache (const $ return ()) - | otherwise -> do - e_tcache <- tryIO $ getModificationTime cache - case e_tcache of - Left ex -> do - whenReportCacheErrors $ - if isDoesNotExistError ex - then - -- It's fine if the cache is not there as long as the - -- database is empty. - when (not $ null confs) $ do - warn ("WARNING: cache does not exist: " ++ cache) - warn ("ghc will fail to read this package db. " ++ - recacheAdvice) - else do - warn ("WARNING: cache cannot be read: " ++ show ex) - warn "ghc will fail to read this package db." - ignore_cache (const $ return ()) - Right tcache -> do - when (verbosity >= Verbose) $ do - warn ("Timestamp " ++ show tcache ++ " for " ++ cache) - -- If any of the .conf files is newer than package.cache, we - -- assume that cache is out of date. - cache_outdated <- (`anyM` confs) $ \conf -> - (tcache <) <$> getModificationTime conf - if not cache_outdated - then do - when (verbosity > Normal) $ - infoLn ("using cache: " ++ cache) - GhcPkg.readPackageDbForGhcPkg cache mode - >>= uncurry mkPackageDB - else do - whenReportCacheErrors $ do - warn ("WARNING: cache is out of date: " ++ cache) - warn ("ghc will see an old view of this " ++ - "package db. " ++ recacheAdvice) - ignore_cache $ \file -> do - when (verbosity >= Verbose) $ do - tFile <- getModificationTime file - let rel = case tcache `compare` tFile of - LT -> " (NEWER than cache)" - GT -> " (older than cache)" - EQ -> " (same as cache)" - warn ("Timestamp " ++ show tFile - ++ " for " ++ file ++ rel) - where - confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs - - ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode) - ignore_cache checkTime = do - -- If we're opening for modification, we need to acquire a - -- lock even if we don't open the cache now, because we are - -- going to modify it later. - lock <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode - let doFile f = do checkTime f - parseSingletonPackageConf verbosity f - pkgs <- mapM doFile confs - mkPackageDB pkgs lock - - -- We normally report cache errors for read-only commands, - -- since modify commands will usually fix the cache. - whenReportCacheErrors = when $ verbosity > Normal - || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode + -- Take a lock to use while we read the DB + Right fs -> withLockedPackageDb mode cache $ \lock -> do + if not use_cache + then ignore_cache (lock) (const $ return ()) + else do + e_tcache <- tryIO $ getModificationTime cache + case e_tcache of + Left ex -> do + whenReportCacheErrors $ + if isDoesNotExistError ex + then + -- It's fine if the cache is not there as long as the + -- database is empty. + when (not $ null confs) $ do + warn ("WARNING: cache does not exist: " ++ cache) + warn ("ghc will fail to read this package db. " ++ + recacheAdvice) + else do + warn ("WARNING: cache cannot be read: " ++ show ex) + warn "ghc will fail to read this package db." + ignore_cache (lock) (const $ return ()) + Right tcache -> do + when (verbosity >= Verbose) $ do + warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + -- If any of the .conf files is newer than package.cache, we + -- assume that cache is out of date. + cache_outdated <- (`anyM` confs) $ \conf -> + (tcache <) <$> getModificationTime conf + if not cache_outdated + then do + when (verbosity > Normal) $ + infoLn ("using cache: " ++ cache) + GhcPkg.readPackageDbForGhcPkg cache (modeWithLock lock mode) + >>= uncurry mkPackageDB + else do + whenReportCacheErrors $ do + warn ("WARNING: cache is out of date: " ++ cache) + warn ("ghc will see an old view of this " ++ + "package db. " ++ recacheAdvice) + ignore_cache (lock) $ \file -> do + when (verbosity >= Verbose) $ do + tFile <- getModificationTime file + let rel = case tcache `compare` tFile of + LT -> " (NEWER than cache)" + GT -> " (older than cache)" + EQ -> " (same as cache)" + warn ("Timestamp " ++ show tFile + ++ " for " ++ file ++ rel) + where + confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs + + -- Read the package db, potentially locking the .cache file for r/w mode. + ignore_cache :: PackageDbLock -> (FilePath -> IO ()) -> IO (PackageDB mode) + ignore_cache lock checkTime = do + -- If we're opening for modification, we need to acquire a + -- lock even if we don't open the cache now, because we are + -- going to modify it later. + + -- mode' <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode + + let doFile f = do checkTime f + parseSingletonPackageConf verbosity f + pkgs <- mapM doFile confs + + -- mkPackageDB pkgs mode' + mkPackageDB pkgs (modeWithLock lock mode) + + -- We normally report cache errors for read-only commands, + -- since modify commands will usually fix the cache. + whenReportCacheErrors = when $ verbosity > Normal + || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode where cache = path </> cachefilename @@ -1060,75 +1074,16 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) Just cs@(c : _) | isPathSeparator c -> Just cs _ -> Nothing --- ----------------------------------------------------------------------------- --- Workaround for old single-file style package dbs - --- 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 code is for 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 path.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 itself also cooperates in this workaround - -tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool) - -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath - -> IO (Maybe (PackageDB mode)) -tryReadParseOldFileStyleDatabase verbosity mb_user_conf - mode use_cache path = do - -- assumes we've already established that path exists and is not a dir - content <- readFile path `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - path_abs <- absolutePath path - let path_dir = adjustOldDatabasePath path - warn $ "Warning: ignoring old file-style db and trying " ++ path_dir - direxists <- doesDirectoryExist path_dir - if direxists - then do - db <- readParseDatabase verbosity mb_user_conf mode use_cache path_dir - -- but pretend it was at the original location - return $ Just db { - location = path, - locationAbsolute = path_abs - } - else do - lock <- F.forM mode $ \_ -> do - createDirectoryIfMissing True path_dir - GhcPkg.lockPackageDb $ path_dir </> cachefilename - return $ Just PackageDB { - location = path, - locationAbsolute = path_abs, - packageDbLock = lock, - packages = [] - } - - -- if the path is not a file, or is not an empty db then we fail - else return Nothing - +-- | Just preserved to give a more informative error adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode) adjustOldFileStylePackageDB db = do -- assumes we have not yet established if it's an old style or not mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing - case fmap (take 2) mcontent of + case mcontent of -- it is an old style and empty db, so look for a dir kind in location.d/ - Just "[]" -> return db { - location = adjustOldDatabasePath $ location db, - locationAbsolute = adjustOldDatabasePath $ locationAbsolute db - } - -- it is old style but not empty, we have to bail - Just _ -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'" - ++ "to create the database with the correct format." - -- probably not old style, carry on as normal + Just _ -> dieOnSingleFileDb (location db) Nothing -> return db -adjustOldDatabasePath :: FilePath -> FilePath -adjustOldDatabasePath = (<.> "d") - -- ----------------------------------------------------------------------------- -- Creating a new package DB @@ -2289,3 +2244,9 @@ removeFileSafe fn = -- absolute path. absolutePath :: FilePath -> IO FilePath absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory + +dieOnSingleFileDb :: FilePath -> IO a +dieOnSingleFileDb path = + die $ "ghc no longer supports single-file style package " + ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" + ++ "to create the database with the correct format." \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b7bcd0d7caf8e96d6b2ae5fd3b5a544... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b7bcd0d7caf8e96d6b2ae5fd3b5a544... You're receiving this email because of your account on gitlab.haskell.org.