From e1decb7eaedd14fe4ab8960cf3fed0b4154f1894 Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Thu, 27 Oct 2022 19:25:47 +0200
Subject: [PATCH] use semaphore-compat package
---
Cabal/src/Distribution/Simple/Program/GHC.hs | 2 +-
cabal-install/cabal-install.cabal | 4 +-
.../src/Distribution/Client/JobControl.hs | 20 +-
.../Distribution/Client/ProjectBuilding.hs | 4 +-
.../src/Distribution/Client/ProjectConfig.hs | 3 +-
.../Client/ProjectConfig/Types.hs | 1 -
.../src/Distribution/Client/Semaphore.hs | 174 ------------------
cabal.project | 2 +
8 files changed, 18 insertions(+), 192 deletions(-)
delete mode 100644 cabal-install/src/Distribution/Client/Semaphore.hs
diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs
index b835497a50..89dfea4abc 100644
--- a/Cabal/src/Distribution/Simple/Program/GHC.hs
+++ b/Cabal/src/Distribution/Simple/Program/GHC.hs
@@ -649,7 +649,7 @@ renderGhcOptions comp _platform@(Platform _arch os) opts
Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]
, if parmakeSupported comp
- then case traceShowId (ghcOptNumJobs opts) of
+ then case ghcOptNumJobs opts of
NoFlag -> []
Flag Serial -> []
Flag (UseSem name _) -> if jsemSupported comp then ["-jsem " ++ name] else []
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index cfe29399dd..0e31be2ca3 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -69,7 +69,6 @@ library
Distribution.Deprecated.ReadP
Distribution.Deprecated.ViewAsFieldDescr
- Distribution.Client.Semaphore
Distribution.Client.BuildReports.Anonymous
Distribution.Client.BuildReports.Lens
Distribution.Client.BuildReports.Storage
@@ -229,7 +228,8 @@ library
parsec >= 3.1.13.0 && < 3.2,
regex-base >= 0.94.0.0 && <0.95,
regex-posix >= 0.96.0.0 && <0.97,
- safe-exceptions >= 0.1.7.0 && < 0.2
+ safe-exceptions >= 0.1.7.0 && < 0.2,
+ semaphore-compat >= 1.0.0.0 && < 1.1
if flag(native-dns)
if os(windows)
diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs
index c7fedb64c1..43a594aa8e 100644
--- a/cabal-install/src/Distribution/Client/JobControl.hs
+++ b/cabal-install/src/Distribution/Client/JobControl.hs
@@ -44,7 +44,7 @@ import Control.Concurrent.STM.TChan
import Control.Exception (bracket_, try, finally)
import Distribution.Compat.Stack
import Distribution.Client.Compat.Semaphore
-import Distribution.Client.Semaphore
+import System.Semaphore
-- | A simple concurrency abstraction. Jobs can be spawned and can complete
@@ -173,21 +173,21 @@ readAllTChan qvar = go []
-- that have already been executed or are currently executing cannot be
-- cancelled.
--
-newSemaphoreJobControl :: WithCallStack (SemaphoreName -> Int -> IO (JobControl IO a))
+newSemaphoreJobControl :: WithCallStack (String -> Int -> IO (JobControl IO a))
newSemaphoreJobControl _ n | n < 1 || n > 1000 =
error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n
-newSemaphoreJobControl semName maxJobLimit = do
- sem <- createSemaphore semName maxJobLimit
+newSemaphoreJobControl semPrefix maxJobLimit = do
+ sem <- createSemaphore semPrefix maxJobLimit
outqVar <- newTChanIO
- inqVar <- newTChanIO
+ inqVar <- newTChanIO
countVar <- newTVarIO 0
forkIO (worker sem inqVar outqVar)
return JobControl {
- spawnJob = spawn inqVar countVar,
- collectJob = collect outqVar countVar,
- remainingJobs = remaining countVar,
- cancelJobs = cancel inqVar countVar,
- cleanupJobControl = destroySemaphore sem
+ spawnJob = spawn inqVar countVar,
+ collectJob = collect outqVar countVar,
+ remainingJobs = remaining countVar,
+ cancelJobs = cancel inqVar countVar,
+ cleanupJobControl = destroySemaphore sem
}
where
worker :: Semaphore -> TChan (IO a) -> TChan (Either SomeException a) -> IO ()
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index d7b8227917..273ffcc4eb 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -103,9 +103,9 @@ import Control.Exception (Handler (..), SomeAsyncException, assert, catches, han
import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
import System.IO (IOMode (AppendMode), Handle, withFile)
+import System.Semaphore
import Distribution.Compat.Directory (listDirectory)
-import Distribution.Client.Semaphore
import Distribution.Client.ProjectConfig.Types
@@ -587,7 +587,7 @@ rebuildTargets verbosity
let mkJobControl = case buildSettingNumJobs of
Serial -> newSerialJobControl
Old n -> newParallelJobControl (fromMaybe numberOfProcessors n)
- UseSem sm n -> newSemaphoreJobControl (SemaphoreName sm) n
+ UseSem sm n -> newSemaphoreJobControl sm n
registerLock <- newLock -- serialise registration
cacheLock <- newLock -- serialise access to setup exe cache
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
index 5afc3f5eed..675aeec139 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -151,10 +151,9 @@ import System.FilePath hiding (combine)
import System.IO
( withBinaryFile, IOMode(ReadMode) )
import System.Directory
+import System.Semaphore
import Network.URI
( URI(..), URIAuth(..), parseAbsoluteURI, uriToString )
-import Distribution.Client.Semaphore
-
----------------------------------------
-- Resolving configuration to settings
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
index b0b92475ac..eff45d9234 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
@@ -68,7 +68,6 @@ import Distribution.Utils.NubList
( NubList )
import qualified Data.Map as Map
-import Distribution.Client.Semaphore (SemaphoreName)
import Distribution.Types.ParStrat
-------------------------------
diff --git a/cabal-install/src/Distribution/Client/Semaphore.hs b/cabal-install/src/Distribution/Client/Semaphore.hs
deleted file mode 100644
index 38a82358df..0000000000
--- a/cabal-install/src/Distribution/Client/Semaphore.hs
+++ /dev/null
@@ -1,174 +0,0 @@
-{-# LANGUAGE CPP #-}
-module Distribution.Client.Semaphore
- ( Semaphore(..), SemaphoreName(..)
- , createSemaphore, openSemaphore
- , waitOnSemaphore, tryWaitOnSemaphore
- , getSemaphoreValue
- , releaseSemaphore
- , destroySemaphore
-
- -- * Abstract semaphores
- , AbstractSem(..)
- , withAbstractSem
- ) where
-
-import Control.Monad
-
-import qualified Control.Monad.Catch as MC
-
-#if defined(mingw32_HOST_OS)
-import qualified System.Win32.Event as Win32
- ( waitForSingleObject, wAIT_OBJECT_0 )
-import qualified System.Win32.File as Win32
- ( closeHandle )
-import qualified System.Win32.Process as Win32
- ( iNFINITE )
-import qualified System.Win32.Semaphore as Win32
- ( Semaphore(..), sEMAPHORE_ALL_ACCESS
- , createSemaphore, openSemaphore, releaseSemaphore )
-import qualified System.Win32.Types as Win32
- ( errorWin )
-#else
-import qualified System.Posix.Semaphore as Posix
- ( Semaphore, OpenSemFlags(..)
- , semOpen, semThreadWait, semTryWait
- , semGetValue, semPost, semUnlink )
-import qualified System.Posix.Files as Posix
- ( stdFileMode )
-#endif
-
----------------------------------------
--- Abstract semaphores
-
--- | Abstraction over the operations of a semaphore,
--- allowing usage with -jN or a jobserver.
-data AbstractSem = AbstractSem { acquireSem :: IO ()
- , releaseSem :: IO ()
- }
-
-withAbstractSem :: AbstractSem -> IO b -> IO b
-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-
----------------------------------------
--- System-specific semaphores
-
-newtype SemaphoreName =
- SemaphoreName { getSemaphoreName :: String }
- deriving (Eq, Show)
-
--- | A semaphore (POSIX or Win32).
-data Semaphore =
- Semaphore
- { semaphoreName :: !SemaphoreName
- , semaphore ::
-#if defined(mingw32_HOST_OS)
- !Win32.Semaphore
-#else
- !Posix.Semaphore
-#endif
- }
-
--- | Create a new semaphore with the given name and initial amount of
--- available resources.
---
--- Throws an error if a semaphore by this name already exists.
-createSemaphore :: SemaphoreName -> Int -> IO Semaphore
-createSemaphore nm@(SemaphoreName sem_name) init_toks = do
-#if defined(mingw32_HOST_OS)
- let toks = fromIntegral init_toks
- (sem, exists) <- Win32.createSemaphore Nothing toks toks (Just sem_name)
- when exists $
- Win32.errorWin ("jsem: semaphore " ++ sem_name ++ " already exists")
-#else
- let flags =
- Posix.OpenSemFlags
- { Posix.semCreate = True
- , Posix.semExclusive = True }
- sem <- Posix.semOpen sem_name flags Posix.stdFileMode init_toks
-#endif
- return $
- Semaphore
- { semaphore = sem
- , semaphoreName = nm }
-
--- | Open a semaphore with the given name.
---
--- If no such semaphore exists, throws an error.
-openSemaphore :: SemaphoreName -> IO Semaphore
-openSemaphore nm@(SemaphoreName sem_name) = do
-#if defined(mingw32_HOST_OS)
- sem <- Win32.openSemaphore Win32.sEMAPHORE_ALL_ACCESS True sem_name
-#else
- let
- flags = Posix.OpenSemFlags
- { Posix.semCreate = False
- , Posix.semExclusive = False }
- sem <- Posix.semOpen sem_name flags Posix.stdFileMode 0
-#endif
- return $
- Semaphore
- { semaphore = sem
- , semaphoreName = nm }
-
--- | Indefinitely wait on a semaphore.
-waitOnSemaphore :: Semaphore -> IO ()
-waitOnSemaphore (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
- void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
-#else
- Posix.semThreadWait sem
-#endif
-
--- | Try to obtain a token from the semaphore, without blocking.
---
--- Immediately returns 'False' if no resources are available.
-tryWaitOnSemaphore :: Semaphore -> IO Bool
-tryWaitOnSemaphore (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
- (== Win32.wAIT_OBJECT_0) <$> Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
-#else
- Posix.semTryWait sem
-#endif
-
--- | Release a semaphore: add @n@ to its internal counter,
--- and return the semaphore's count before the operation.
---
--- NB: the returned value should only be used for debugging,
--- not for the main jobserver logic.
-releaseSemaphore :: Semaphore -> Int -> IO Int
-releaseSemaphore (Semaphore { semaphore = sem }) n =
-#if defined(mingw32_HOST_OS)
- fromIntegral <$> Win32.releaseSemaphore sem (fromIntegral n)
-#else
- do
- res <- Posix.semGetValue sem
- replicateM_ n (Posix.semPost sem)
- return res
-#endif
-
--- | Destroy the given semaphore.
-destroySemaphore :: Semaphore -> IO ()
-destroySemaphore sem =
-#if defined(mingw32_HOST_OS)
- Win32.closeHandle (Win32.semaphoreHandle $ semaphore sem)
-#else
- Posix.semUnlink (getSemaphoreName $ semaphoreName sem)
-#endif
-
--- | Query the current semaphore value (how many tokens it has available).
-getSemaphoreValue :: Semaphore -> IO Int
-getSemaphoreValue (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
- do
- wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) (fromInteger 0)
- if wait_res == Win32.wAIT_OBJECT_0
- -- We were able to immediately acquire a resource from the semaphore:
- -- release it immediately, thus obtaining the total number of available
- -- resources.
- then
- (+1) . fromIntegral <$> Win32.releaseSemaphore sem 1
- else
- return 0
-#else
- Posix.semGetValue sem
-#endif
diff --git a/cabal.project b/cabal.project
index aea54a32ef..bf0a9e4adc 100644
--- a/cabal.project
+++ b/cabal.project
@@ -16,6 +16,8 @@ optional-packages: ./vendored/*/*.cabal
allow-newer:
hackage-security:Cabal
+packages: ../semaphore-compat
+
-- avoiding extra dependencies
constraints: rere -rere-cfg
constraints: these -assoc
--
GitLab