GitLab

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