[Git][ghc/ghc][wip/jsem] Add more cross-platform semaphore operations
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Wed Sep 14 13:47:18 UTC 2022
sheaf pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC
Commits:
504045ae by sheaf at 2022-09-14T15:45:58+02:00
Add more cross-platform semaphore operations
- - - - -
3 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/GHC/Utils/IO/Semaphore.hs
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -662,7 +662,7 @@ createBuildPlan mod_graph maybe_top_mod =
mkWorkerLimit :: DynFlags -> IO WorkerLimit
mkWorkerLimit dflags =
case jsemHandle dflags of
- Just h -> pure (JSemLimit (SemaphoreName h))
+ Just h -> pure (JSemLimit $ SemaphoreName h)
Nothing -> case parMakeCount dflags of
Nothing -> pure $ num_procs 1
Just ParMakeNumProcessors -> num_procs <$> getNumProcessors
=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -10,9 +10,12 @@ module GHC.Driver.MakeSem
-- by a system semaphore (Posix/Windows)
runJSemAbstractSem
- , SemaphoreName(..)
+ -- * System semaphores
+ , Semaphore, SemaphoreName(..)
+
-- * Abstract semaphores
- , AbstractSem(..), withAbstractSem
+ , AbstractSem(..)
+ , withAbstractSem
)
where
@@ -32,11 +35,6 @@ import Control.Concurrent.STM
import Data.Foldable
import Data.Functor
----------------------------------------
--- Abstract semaphores
-
-
-
---------------------------------------
-- Semaphore jobserver
@@ -46,7 +44,7 @@ import Data.Functor
-- available from the semaphore.
data Jobserver
= Jobserver
- { semaphore :: !Semaphore
+ { jSemaphore :: !Semaphore
-- ^ The semaphore which controls available resources
, jobs :: !(TVar JobResources)
-- ^ The currently pending jobs, and the resources
@@ -185,7 +183,7 @@ releaseJob jobs_tvar
-- | Release all tokens owned from the semaphore (to clean up
-- the jobserver at the end).
cleanupJobserver :: Jobserver -> IO ()
-cleanupJobserver (Jobserver { semaphore = sem, jobs = jobs_tvar })
+cleanupJobserver (Jobserver { jSemaphore = sem, jobs = jobs_tvar })
= do
Jobs { tokensOwned = owned, tokensFree = _free } <- readTVarIO jobs_tvar
pprTraceM "cleanupJobserver about to release semaphore tokens:" $
@@ -239,7 +237,7 @@ modifyJobResources jobs_tvar action = do
-- | Spawn a new thread that waits on the semaphore in order to acquire
-- an additional token.
acquireThread :: Jobserver -> IO JobserverAction
-acquireThread (Jobserver { semaphore = sem, jobs = jobs_tvar })
+acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar })
= do
threadFinished_tmvar <- newEmptyTMVarIO
tid <- forkIOWithUnmask \ unmask -> do
@@ -260,7 +258,7 @@ acquireThread (Jobserver { semaphore = sem, jobs = jobs_tvar })
-- | Spawn a thread to release ownership of one resource from the semaphore,
-- provided we have spare resources and no pending jobs.
releaseThread :: Jobserver -> IO JobserverAction
-releaseThread (Jobserver { semaphore = sem, jobs = jobs_tvar }) = do
+releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
threadFinished_tmvar <- newEmptyTMVarIO
MC.mask_ do
still_ok_to_release
@@ -422,8 +420,8 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
-- | Create a new jobserver using the given semaphore handle.
makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())
-makeJobserver (SemaphoreName sem_path) = do
- semaphore <- openSemaphore sem_path
+makeJobserver sem_name = do
+ semaphore <- openSemaphore sem_name
let
init_jobs =
Jobs { tokensOwned = 1
@@ -433,7 +431,7 @@ makeJobserver (SemaphoreName sem_path) = do
jobs_tvar <- newTVarIO init_jobs
let
opts = defaultJobserverOptions -- TODO: allow this to be configure
- sjs = Jobserver { semaphore, jobs = jobs_tvar }
+ sjs = Jobserver { jSemaphore = semaphore, jobs = jobs_tvar }
loop_finished_mvar <- newEmptyMVar
loop_tid <- forkIOWithUnmask \ unmask -> do
r <- try $ unmask $ jobserverLoop opts sjs
=====================================
compiler/GHC/Utils/IO/Semaphore.hs
=====================================
@@ -3,7 +3,11 @@
module GHC.Utils.IO.Semaphore
( -- * System semaphores
Semaphore, SemaphoreName(..)
- , openSemaphore, waitOnSemaphore, releaseSemaphore
+ , createSemaphore, openSemaphore
+ , waitOnSemaphore, tryWaitOnSemaphore
+ , getSemaphoreValue
+ , releaseSemaphore
+ , destroySemaphore
-- * Abstract semaphores
, AbstractSem(..)
@@ -17,66 +21,102 @@ import qualified Control.Monad.Catch as MC
#if defined(mingw32_HOST_OS)
import qualified System.Win32.Event as Win32
- ( waitForSingleObject )
+ ( 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
- , openSemaphore, releaseSemaphore )
+ , createSemaphore, openSemaphore, releaseSemaphore )
+import qualified System.Win32.Types as Win32
+ ( errorWin )
#else
import qualified System.Posix.Semaphore as Posix
( Semaphore, OpenSemFlags(..)
- , semOpen, semWait, semPost, semGetValue )
+ , semOpen, semWait, 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
-type Semaphore =
+newtype SemaphoreName =
+ SemaphoreName { getSemaphoreName :: String }
+ deriving Eq
+
+-- | A semaphore (POSIX or Win32).
+data Semaphore =
+ Semaphore
+ { semaphoreName :: !SemaphoreName
+ , semaphore ::
#if defined(mingw32_HOST_OS)
- Win32.Semaphore
+ !Win32.Semaphore
#else
- Posix.Semaphore
+ !Posix.Semaphore
#endif
-
--- | The name of a 'Semaphore'.
-newtype SemaphoreName = SemaphoreName FilePath
- deriving Eq
+ }
-- | Open a semaphore with the given name.
--
-- If no such semaphore exists, throws an error.
-openSemaphore :: String -- ^ semaphore name
- -> IO Semaphore
-openSemaphore sem_name =
+openSemaphore :: SemaphoreName -> IO Semaphore
+openSemaphore nm@(SemaphoreName sem_name) = do
#if defined(mingw32_HOST_OS)
- Win32.openSemaphore Win32.sEMAPHORE_ALL_ACCESS True sem_name
+ sem <- Win32.openSemaphore Win32.sEMAPHORE_ALL_ACCESS True sem_name
#else
- Posix.semOpen sem_name flags Posix.stdFileMode 0
- where
+ 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 sem =
+waitOnSemaphore (Semaphore { semaphore = sem }) =
#if defined(mingw32_HOST_OS)
void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
#else
Posix.semWait 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 sem n =
+releaseSemaphore (Semaphore { semaphore = sem }) n =
#if defined(mingw32_HOST_OS)
fromIntegral <$> Win32.releaseSemaphore sem (fromIntegral n)
#else
@@ -86,11 +126,52 @@ releaseSemaphore sem n =
return res
#endif
--- | Abstraction over the operations of a semaphore,
--- allowing usage with -jN or a jobserver.
-data AbstractSem = AbstractSem { acquireSem :: IO ()
- , releaseSem :: IO ()
- }
+-- | 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 }
-withAbstractSem :: AbstractSem -> IO b -> IO b
-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
+-- | 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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/504045aeb075a70e5215b380d73e050cab832092
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/504045aeb075a70e5215b380d73e050cab832092
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220914/e28210c5/attachment-0001.html>
More information about the ghc-commits
mailing list