[Git][ghc/ghc][wip/jsem] use semaphore-compat package + cleanups
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Thu Oct 27 18:39:07 UTC 2022
sheaf pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC
Commits:
ea49c30d by sheaf at 2022-10-27T20:38:47+02:00
use semaphore-compat package + cleanups
- - - - -
23 changed files:
- .gitmodules
- cabal.project-reinstall
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/ghc.cabal.in
- hadrian/cabal.project
- hadrian/hadrian.cabal
- hadrian/src/Hadrian/Semaphore.hs
- − hadrian/src/Hadrian/Semaphore/System.hs
- hadrian/src/Packages.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- libraries/Cabal
- + libraries/semaphore-compat/.gitignore
- + libraries/semaphore-compat/LICENSE
- + libraries/semaphore-compat/Setup.hs
- + libraries/semaphore-compat/cabal.haskell-ci
- + libraries/semaphore-compat/cabal.project
- + libraries/semaphore-compat/changelog.md
- + libraries/semaphore-compat/readme.md
- + libraries/semaphore-compat/semaphore-compat.cabal
- compiler/GHC/Utils/IO/Semaphore.hs → libraries/semaphore-compat/src/System/Semaphore.hs
- packages
Changes:
=====================================
.gitmodules
=====================================
@@ -83,6 +83,10 @@
url = https://gitlab.haskell.org/ghc/packages/unix.git
ignore = untracked
branch = 2.7
+[submodule "libraries/semaphore-compat"]
+ path = libraries/semaphore-compat
+ url = https://gitlab.haskell.org/ghc/packages/semaphore-compat.git
+ ignore = untracked
[submodule "libraries/stm"]
path = libraries/stm
url = https://gitlab.haskell.org/ghc/packages/stm.git
=====================================
cabal.project-reinstall
=====================================
@@ -29,6 +29,7 @@ packages: ./compiler
./libraries/parsec/
-- ./libraries/pretty/
./libraries/process/
+ ./libraries/semaphore-compat
./libraries/stm
-- ./libraries/template-haskell/
./libraries/terminfo/
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2876,12 +2876,12 @@ runNjobsAbstractSem n_jobs action = do
resetNumCapabilities = set_num_caps n_capabilities
MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
-runWorkerLimit :: WorkerLimit -> Logger -> (AbstractSem -> IO a) -> IO a
-runWorkerLimit worker_limit logger action = case worker_limit of
+runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
+runWorkerLimit worker_limit action = case worker_limit of
NumProcessorsLimit n_jobs ->
- runNjobsAbstractSem n_jobs action -- TODO: could use the logger here too.
+ runNjobsAbstractSem n_jobs action
JSemLimit sem ->
- runJSemAbstractSem logger sem action
+ runJSemAbstractSem sem action
-- | Build and run a pipeline
runParPipelines :: WorkerLimit -- ^ How to limit work parallelism
@@ -2906,10 +2906,7 @@ runParPipelines worker_limit plugin_hsc_env mHscMessager all_pipelines = do
thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
-
-
--- let sem_logger = modify_logger $ hsc_logger thread_safe_hsc_env
- runWorkerLimit worker_limit (hsc_logger thread_safe_hsc_env) $ \abstract_sem -> do
+ runWorkerLimit worker_limit $ \abstract_sem -> do
let env = MakeEnv { hsc_env = thread_safe_hsc_env
, withLogger = withParLog log_queue_queue_var
, compile_sem = abstract_sem
=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -25,13 +25,12 @@ import GHC.Prelude
import GHC.Conc
import GHC.Data.OrdList
import GHC.IO.Exception
-import GHC.Utils.IO.Semaphore
-import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Trace
import GHC.Utils.Json
+import System.Semaphore
+
import Control.Monad
import qualified Control.Monad.Catch as MC
import Control.Concurrent.MVar
@@ -55,8 +54,6 @@ data Jobserver
, jobs :: !(TVar JobResources)
-- ^ The currently pending jobs, and the resources
-- obtained from the semaphore
- , jobsLogger :: !Logger
- -- ^ The logger used for the jobserver.
}
data JobserverOptions
@@ -177,19 +174,18 @@ guardRelease ( Jobs { tokensFree, tokensOwned, jobsWaiting } )
-- | Add one pending job to the jobserver.
--
-- Blocks, waiting on the jobserver to supply a free token.
-acquireJob :: Logger -> TVar JobResources -> IO ()
-acquireJob logger jobs_tvar = do
- (job_tmvar, jobs0) <- tracedAtomically "acquire" $ modifyJobResources jobs_tvar \ jobs -> do
- job_tmvar <- newEmptyTMVar
- return ((job_tmvar, jobs), addJob job_tmvar jobs)
- logDumpMsg logger "acquireJob {" $ ppr jobs0
- jobs1 <- atomically $ takeTMVar job_tmvar >> readTVar jobs_tvar
- logDumpMsg logger "acquireJob }" $ ppr jobs1
+acquireJob :: TVar JobResources -> IO ()
+acquireJob jobs_tvar = do
+ (job_tmvar, _jobs0) <- tracedAtomically "acquire" $
+ modifyJobResources jobs_tvar \ jobs -> do
+ job_tmvar <- newEmptyTMVar
+ return ((job_tmvar, jobs), addJob job_tmvar jobs)
+ atomically $ takeTMVar job_tmvar
-- | Signal to the job server that one job has completed,
-- releasing its corresponding token.
-releaseJob :: Logger -> TVar JobResources -> IO ()
-releaseJob logger jobs_tvar = do
+releaseJob :: TVar JobResources -> IO ()
+releaseJob jobs_tvar = do
tracedAtomically "release" do
modifyJobResources jobs_tvar \ jobs -> do
massertPpr (tokensFree jobs < tokensOwned jobs)
@@ -201,20 +197,13 @@ releaseJob logger jobs_tvar = do
-- the jobserver at the end).
cleanupJobserver :: Jobserver -> IO ()
cleanupJobserver (Jobserver { jSemaphore = sem
- , jobs = jobs_tvar
- , jobsLogger = logger })
+ , jobs = jobs_tvar })
= do
- jobs@(Jobs { tokensOwned = owned }) <- readTVarIO jobs_tvar
- logDumpMsg logger "cleanupJobserver {" $
- vcat [ text "about to release all owned semaphore tokens"
- , ppr jobs ]
- -- (-1) because the caller of GHC is responsible for releasing the last slot on the semaphore.
+ Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar
let toks_to_release = owned - 1
- when (toks_to_release > 0) do
- tokens_before <- releaseSemaphore sem toks_to_release
- logDumpMsg logger "cleanupJobserver }" $
- vcat [ text "released:" <+> ppr toks_to_release
- , text "semaphore count before release:" <+> ppr tokens_before ]
+ -- Subtract off the implicit token: whoever spawned the ghc process
+ -- in the first place is responsible for that token.
+ releaseSemaphore sem toks_to_release
-- | Dispatch the available tokens acquired from the semaphore
-- to the pending jobs in the job server.
@@ -261,8 +250,7 @@ tracedAtomically_ s act = tracedAtomically s (((),) <$> act)
tracedAtomically :: String -> STM (a, Maybe JobResources) -> IO a
tracedAtomically origin act = do
(a, mjr) <- atomically act
- forM_ mjr $ \jr -> do
- -- MP: Could also trace to a logger here as well with suitable verbosity
+ forM_ mjr $ \ jr -> do
-- Use the "jsem:" prefix to identify where the write traces are
traceEventIO ("jsem:" ++ renderJobResources origin jr)
return a
@@ -321,14 +309,13 @@ releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
then return Idle
else do
tid <- forkIO $ do
- x <- MC.try $ void $ do
- releaseSemaphore sem 1
+ x <- MC.try $ releaseSemaphore sem 1
tracedAtomically_ "post-release" $ do
(r, jobs) <- case x of
Left (e :: MC.SomeException) -> do
modifyJobResources jobs_tvar \ jobs ->
return (Just e, addToken jobs)
- Right () -> do
+ Right _ -> do
return (Nothing, Nothing)
putTMVar threadFinished_tmvar r
return jobs
@@ -428,9 +415,6 @@ tryStopThread jobs_tvar jsj = do
interruptWaitOnSemaphore wait_id
return $ jsj { jobserverAction = Idle }
_ -> retry
- where
- kill_thread_and_idle tid =
- killThread tid $> jsj { jobserverAction = Idle }
-- | Main jobserver loop: acquire/release resources as
-- needed for the pending jobs and available semaphore tokens.
@@ -457,8 +441,8 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
loop s
-- | Create a new jobserver using the given semaphore handle.
-makeJobserver :: Logger -> SemaphoreName -> IO (AbstractSem, IO ())
-makeJobserver logger sem_name = do
+makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())
+makeJobserver sem_name = do
semaphore <- openSemaphore sem_name
let
init_jobs =
@@ -470,8 +454,7 @@ makeJobserver logger sem_name = do
let
opts = defaultJobserverOptions -- TODO: allow this to be configured
sjs = Jobserver { jSemaphore = semaphore
- , jobs = jobs_tvar
- , jobsLogger = logger }
+ , jobs = jobs_tvar }
loop_finished_mvar <- newEmptyMVar
loop_tid <- forkIOWithUnmask \ unmask -> do
r <- try $ unmask $ jobserverLoop opts sjs
@@ -485,8 +468,8 @@ makeJobserver logger sem_name = do
Right () -> Nothing
labelThread loop_tid "job_server"
let
- acquireSem = acquireJob logger jobs_tvar
- releaseSem = releaseJob logger jobs_tvar
+ acquireSem = acquireJob jobs_tvar
+ releaseSem = releaseJob jobs_tvar
cleanupSem = do
-- this is interruptible
cleanupJobserver sjs
@@ -498,13 +481,12 @@ makeJobserver logger sem_name = do
-- | Implement an abstract semaphore using a semaphore 'Jobserver'
-- which queries the system semaphore of the given name for resources.
-runJSemAbstractSem :: Logger
- -> SemaphoreName -- ^ the system semaphore to use
+runJSemAbstractSem :: SemaphoreName -- ^ the system semaphore to use
-> (AbstractSem -> IO a) -- ^ the operation to run
-- which requires a semaphore
-> IO a
-runJSemAbstractSem logger sem action = MC.mask \ unmask -> do
- (abs, cleanup) <- makeJobserver logger sem
+runJSemAbstractSem sem action = MC.mask \ unmask -> do
+ (abs, cleanup) <- makeJobserver sem
r <- try $ unmask $ action abs
case r of
Left (e1 :: MC.SomeException) -> do
=====================================
compiler/ghc.cabal.in
=====================================
@@ -90,6 +90,7 @@ Library
hpc == 0.6.*,
transformers == 0.5.*,
exceptions == 0.10.*,
+ semaphore-compat,
stm,
ghc-boot == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,
@@ -793,7 +794,6 @@ Library
GHC.Utils.FV
GHC.Utils.GlobalVars
GHC.Utils.IO.Unsafe
- GHC.Utils.IO.Semaphore
GHC.Utils.Json
GHC.Utils.Lexeme
GHC.Utils.Logger
=====================================
hadrian/cabal.project
=====================================
@@ -1,5 +1,7 @@
packages: ./
, ../libraries/Win32
+ , ../libraries/unix
+ , ../libraries/semaphore-compat
-- This essentially freezes the build plan for hadrian
index-state: 2022-09-10T18:46:55Z
=====================================
hadrian/hadrian.cabal
=====================================
@@ -68,7 +68,6 @@ executable hadrian
, Hadrian.Target
, Hadrian.Utilities
, Hadrian.Semaphore
- , Hadrian.Semaphore.System
, Oracles.Flag
, Oracles.Flavour
, Oracles.Setting
@@ -160,6 +159,7 @@ executable hadrian
, time
, mtl == 2.2.*
, parsec >= 3.1 && < 3.2
+ , semaphore-compat
, shake >= 0.18.3 && < 0.20
, transformers >= 0.4 && < 0.6
, unordered-containers >= 0.2.1 && < 0.3
=====================================
hadrian/src/Hadrian/Semaphore.hs
=====================================
@@ -5,48 +5,49 @@ module Hadrian.Semaphore
, Semaphore, SemaphoreName(..)
) where
-import Hadrian.Semaphore.System
-import Hadrian.Utilities
-import Development.Shake
-import Control.Exception ( SomeException, try )
+-- base
import Control.Monad ( void )
-data GlobalSemaphore = NoSemaphore | GlobalSemaphore SemaphoreName Semaphore
+-- semaphore-compat
+import System.Semaphore
+
+-- shake
+import Development.Shake
+
+-- hadrian
+import Hadrian.Utilities
+
+--------------------------------------------------------------------------------
+
+data GlobalSemaphore = NoSemaphore | GlobalSemaphore Semaphore
getJsemSemaphore :: Action GlobalSemaphore
getJsemSemaphore = userSetting NoSemaphore
globalSemaphore :: a -> (SemaphoreName -> Semaphore -> a) -> GlobalSemaphore -> a
-globalSemaphore def _ NoSemaphore = def
-globalSemaphore _ f (GlobalSemaphore fp sem) = f fp sem
+globalSemaphore def _ NoSemaphore = def
+globalSemaphore _ f (GlobalSemaphore sem) = f (semaphoreName sem) sem
initialiseSemaphore :: Int -> IO GlobalSemaphore
-initialiseSemaphore n = do
- let sem_nm = SemaphoreName "hadrian_semaphore"
- -- Destroy any previous semaphore by this name...
- _ <- void $ try @SomeException $ do
- old_sem <- openSemaphore sem_nm
- destroySemaphore old_sem
- sem <- createSemaphore sem_nm n
- return (GlobalSemaphore sem_nm sem)
+initialiseSemaphore n
+ | n <= 0
+ = error $ unlines
+ [ "hadrian: attempting to create a semaphore with no slots"
+ , "Perhaps you tried to use -j, without specifying a number?"
+ , "In which case, use -jN instead of -j." ]
+ | otherwise
+ = GlobalSemaphore <$> freshSemaphore "hadrian_semaphore" n
unlinkSemaphore :: GlobalSemaphore -> IO ()
-unlinkSemaphore NoSemaphore = return ()
-unlinkSemaphore (GlobalSemaphore _ sem) = destroySemaphore sem
+unlinkSemaphore NoSemaphore = return ()
+unlinkSemaphore (GlobalSemaphore sem) = destroySemaphore sem
-- | Wrap an action which requires the semaphore with wait/post
withSemaphore :: GlobalSemaphore -> Action a -> Action a
withSemaphore sem act =
- globalSemaphore act (\_ sem -> actionBracket (wait sem) (\_ -> post sem) (\_ -> act)) sem
+ globalSemaphore act
+ ( \ _ sem -> actionBracket (wait sem) (\_ -> post sem) (\_ -> act) )
+ sem
where
- wait s = do
- n <- getSemaphoreValue s
- liftIO $ print ("WAITING:" ++ show n)
- waitOnSemaphore s
- liftIO $ print "WAITED"
-
- post s = do
- liftIO $ print "POST"
- n <- releaseSemaphore s 1
-
- liftIO $ print ("SEM_VALUE:" ++ show (n+1))
+ wait s = void $ waitOnSemaphore s
+ post s = releaseSemaphore s 1
=====================================
hadrian/src/Hadrian/Semaphore/System.hs deleted
=====================================
@@ -1,176 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Hadrian.Semaphore.System
- ( -- * System semaphores
- 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
-
--- | 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
=====================================
hadrian/src/Packages.hs
=====================================
@@ -8,7 +8,7 @@ module Packages (
ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline,
hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy,
libffi, libiserv, mtl, parsec, pretty, primitive, process, remoteIserv, rts,
- runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy,
+ runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout, touchy,
transformers, unlit, unix, win32, xhtml,
lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
ghcPackages, isGhcPackage,
@@ -39,7 +39,7 @@ ghcPackages =
, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh
, ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs
, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl
- , parsec, pretty, process, rts, runGhc, stm, templateHaskell
+ , parsec, pretty, process, rts, runGhc, semaphoreCompat, stm, templateHaskell
, terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
, timeout
, lintersCommon
@@ -55,7 +55,7 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count
exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh,
ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs,
hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, libiserv, mtl,
- parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell,
+ parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell,
terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml,
timeout,
lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
@@ -111,6 +111,7 @@ process = lib "process"
remoteIserv = util "remote-iserv"
rts = top "rts"
runGhc = util "runghc"
+semaphoreCompat = lib "semaphore-compat"
stm = lib "stm"
templateHaskell = lib "template-haskell"
terminfo = lib "terminfo"
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -67,11 +67,13 @@ compileAndLinkHs = (builder (Ghc . CompileHs) ||^ builder (Ghc LinkHs)) ? do
, builder (Ghc (CompileHs GhcMake)) ? do
jsem <- expr getJsemSemaphore
mconcat
- ([ arg "--make"
- , arg "-no-link"
- ]
- ++ globalSemaphore []
- (\(SemaphoreName name) _ -> [ arg "-jsem", arg name ]) jsem)
+ ( [ arg "--make"
+ , arg "-no-link"
+ ]
+ ++
+ globalSemaphore []
+ (\(SemaphoreName name) _ -> [ arg "-jsem", arg name ]) jsem
+ )
, getInputs
, notM (builder (Ghc (CompileHs GhcMake))) ? mconcat
[arg "-o", arg =<< getOutput]
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -95,6 +95,7 @@ stage0Packages = do
, hpcBin
, mtl
, parsec
+ , semaphoreCompat
, time
, templateHaskell
, text
@@ -134,6 +135,7 @@ stage1Packages = do
, integerGmp
, pretty
, rts
+ , semaphoreCompat
, stm
, unlit
, xhtml
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit b01efbe2b9119c0d5b257afd2eb264dd476868c2
+Subproject commit e1decb7eaedd14fe4ab8960cf3fed0b4154f1894
=====================================
libraries/semaphore-compat/.gitignore
=====================================
@@ -0,0 +1,11 @@
+/dist/
+/dist-boot/
+/dist-install/
+/dist-newstyle/
+/cabal.project.local
+/.cabal-sandbox/
+/cabal.sandbox.config
+/.ghc.environment.*
+*~
+ghc.mk
+GNUmakefile
=====================================
libraries/semaphore-compat/LICENSE
=====================================
@@ -0,0 +1,34 @@
+-----------------------------------------------------------------------------
+
+The Glasgow Haskell Compiler License
+
+Copyright 2022, The GHC team. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
+
+-----------------------------------------------------------------------------
=====================================
libraries/semaphore-compat/Setup.hs
=====================================
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
=====================================
libraries/semaphore-compat/cabal.haskell-ci
=====================================
@@ -0,0 +1 @@
+branches: master
=====================================
libraries/semaphore-compat/cabal.project
=====================================
@@ -0,0 +1,4 @@
+packages:
+ .,
+ ../unix,
+ ../Win32
=====================================
libraries/semaphore-compat/changelog.md
=====================================
@@ -0,0 +1,3 @@
+### 1.0.0 (October 27th, 2022)
+
+- First version of the `semaphore-compat` package.
=====================================
libraries/semaphore-compat/readme.md
=====================================
@@ -0,0 +1,16 @@
+# semaphore-compat
+
+`semaphore-compat` provides a cross-platform implementation of system semaphores
+that abstracts over the `unix` and `Win32` libraries.
+
+It supports:
+
+ - Creating (`createSemaphore`, `freshSemaphore`), opening (`openSemaphore`)
+ and closing (`destroySemaphore`) semaphores.
+ - Waiting on a semaphore:
+ - without blocking with `tryWaitOnSemaphore`,
+ - blocking forever, with `waitOnSemaphore`,
+ - blocking, in a separate thread and allowing interruption, with
+ `forkWaitOnSemaphoreInterruptible` and `interruptWaitOnSemaphore`.
+ - Releasing tokens to a semaphore (`releaseSemaphore`).
+ - Querying the semaphore for its current value (`getSemaphoreValue`).
=====================================
libraries/semaphore-compat/semaphore-compat.cabal
=====================================
@@ -0,0 +1,61 @@
+cabal-version: 3.0
+name:
+ semaphore-compat
+version:
+ 1.0.0
+license:
+ BSD-3-Clause
+
+author:
+ The GHC team
+maintainer:
+ ghc-devs at haskell.org
+homepage:
+ https://gitlab.haskell.org/ghc/packages/semaphore-compat
+bug-reports:
+ https://gitlab.haskell.org/ghc/ghc/issues/new
+
+category:
+ System
+synopsis:
+ Cross-platform abstraction for system semaphores
+description:
+ This package provides a cross-platform implementation of system semaphores
+ that abstracts over the `unix` and `Win32` libraries.
+
+build-type:
+ Simple
+
+extra-source-files:
+ changelog.md
+ , readme.md
+
+
+source-repository head
+ type: git
+ location: https://gitlab.haskell.org/ghc/packages/semaphore-compat.git
+
+library
+ hs-source-dirs:
+ src
+
+ exposed-modules:
+ System.Semaphore
+
+ build-depends:
+ base
+ >= 4.12 && < 4.19
+ , exceptions
+ >= 0.7 && < 0.11
+
+ if os(windows)
+ build-depends:
+ Win32
+ >= 2.13.4.0 && < 2.14
+ else
+ build-depends:
+ unix
+ >= 2.0 && < 2.9
+
+ default-language:
+ Haskell2010
=====================================
compiler/GHC/Utils/IO/Semaphore.hs → libraries/semaphore-compat/src/System/Semaphore.hs
=====================================
@@ -1,11 +1,13 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
-module GHC.Utils.IO.Semaphore
+module System.Semaphore
( -- * System semaphores
Semaphore(..), SemaphoreName(..)
- , createSemaphore, openSemaphore
+ , createSemaphore, freshSemaphore, openSemaphore
, waitOnSemaphore, tryWaitOnSemaphore
, WaitId(..)
, forkWaitOnSemaphoreInterruptible
@@ -19,13 +21,17 @@ module GHC.Utils.IO.Semaphore
, withAbstractSem
) where
-import GHC.Prelude
+-- base
import Control.Concurrent
import Control.Monad
+import Data.List.NonEmpty ( NonEmpty(..) )
+import GHC.Exts ( Char(..), Int(..), indexCharOffAddr# )
+-- exceptions
import qualified Control.Monad.Catch as MC
#if defined(mingw32_HOST_OS)
+-- Win32
import qualified System.Win32.Event as Win32
( createEvent, setEvent
, waitForSingleObject, waitForMultipleObjects
@@ -37,29 +43,26 @@ import qualified System.Win32.Process as Win32
import qualified System.Win32.Semaphore as Win32
( Semaphore(..), sEMAPHORE_ALL_ACCESS
, createSemaphore, openSemaphore, releaseSemaphore )
+import qualified System.Win32.Time as Win32
+ ( FILETIME(..), getSystemTimeAsFileTime )
import qualified System.Win32.Types as Win32
( HANDLE, errorWin )
#else
+-- base
+import Foreign.C.Types
+ ( CClock(..) )
+
+-- unix
import qualified System.Posix.Semaphore as Posix
( Semaphore, OpenSemFlags(..)
, semOpen, semWaitInterruptible, semTryWait
, semGetValue, semPost, semUnlink )
import qualified System.Posix.Files as Posix
( stdFileMode )
+import qualified System.Posix.Process as Posix
+ ( ProcessTimes(systemTime), getProcessTimes )
#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
@@ -67,7 +70,7 @@ newtype SemaphoreName =
SemaphoreName { getSemaphoreName :: String }
deriving Eq
--- | A semaphore (POSIX or Win32).
+-- | A system semaphore (POSIX or Win32).
data Semaphore =
Semaphore
{ semaphoreName :: !SemaphoreName
@@ -83,24 +86,69 @@ data Semaphore =
-- 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
+createSemaphore :: SemaphoreName
+ -> Int -- ^ number of tokens on the semaphore
+ -> IO Semaphore
+createSemaphore (SemaphoreName sem_name) init_toks = do
+ mb_sem <- create_sem sem_name init_toks
+ case mb_sem of
+ Left err -> err
+ Right sem -> return sem
+
+-- | Create a fresh semaphore with the given amount of tokens.
+--
+-- Its name will start with the given prefix, but will have a random suffix
+-- appended to it.
+freshSemaphore :: String -- ^ prefix
+ -> Int -- ^ number of tokens on the semaphore
+ -> IO Semaphore
+freshSemaphore prefix init_toks = do
+ suffixes <- random_strings
+ go 0 suffixes
+ where
+ go :: Int -> NonEmpty String -> IO Semaphore
+ go i (suffix :| suffs) = do
+ mb_sem <- create_sem (prefix ++ "_" ++ suffix) init_toks
+ case mb_sem of
+ Right sem -> return sem
+ Left err
+ | next : nexts <- suffs
+ , i < 32 -- give up after 32 attempts
+ -> go (i+1) (next :| nexts)
+ | otherwise
+ -> err
+
+create_sem :: String -> Int -> IO (Either (IO Semaphore) Semaphore)
+create_sem sem_str 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")
+ mb_sem <- MC.try @_ @MC.SomeException $
+ Win32.createSemaphore Nothing toks toks (Just sem_str)
+ return $ case mb_sem of
+ Right (sem, exists)
+ | exists
+ -> Left (Win32.errorWin $ "semaphore-compat: semaphore " ++ sem_str ++ " already exists")
+ | otherwise
+ -> Right $ mk_sem sem
+ Left err
+ -> Left $ MC.throwM err
#else
let flags =
Posix.OpenSemFlags
{ Posix.semCreate = True
, Posix.semExclusive = True }
- sem <- Posix.semOpen sem_name flags Posix.stdFileMode init_toks
+ mb_sem <- MC.try @_ @MC.SomeException $
+ Posix.semOpen sem_str flags Posix.stdFileMode init_toks
+ return $ case mb_sem of
+ Left err -> Left $ MC.throwM err
+ Right sem -> Right $ mk_sem sem
#endif
- return $
- Semaphore
- { semaphore = sem
- , semaphoreName = nm }
+ where
+ sem_nm = SemaphoreName sem_str
+ mk_sem sem =
+ Semaphore
+ { semaphore = sem
+ , semaphoreName = sem_nm }
-- | Open a semaphore with the given name.
--
@@ -128,10 +176,11 @@ openSemaphore nm@(SemaphoreName sem_name) = do
waitOnSemaphore :: Semaphore -> IO Bool
waitOnSemaphore (Semaphore { semaphore = sem }) =
#if defined(mingw32_HOST_OS)
- (== Win32.wAIT_OBJECT_0) <$>
- Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
+ MC.mask_ $ do
+ wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
+ return $ wait_res == Win32.wAIT_OBJECT_0
#else
- Posix.semWait sem
+ Posix.semTryWait sem
#endif
-- | Try to obtain a token from the semaphore, without blocking.
@@ -140,18 +189,26 @@ waitOnSemaphore (Semaphore { semaphore = sem }) =
tryWaitOnSemaphore :: Semaphore -> IO Bool
tryWaitOnSemaphore (Semaphore { semaphore = sem }) =
#if defined(mingw32_HOST_OS)
- (== Win32.wAIT_OBJECT_0) <$> Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
+ MC.mask_ $ do
+ wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
+ return $ wait_res == Win32.wAIT_OBJECT_0
#else
Posix.semTryWait sem
#endif
-- | Release a semaphore: add @n@ to its internal counter.
+--
+-- No-op when `n <= 0`.
releaseSemaphore :: Semaphore -> Int -> IO ()
-releaseSemaphore (Semaphore { semaphore = sem }) n =
+releaseSemaphore (Semaphore { semaphore = sem }) n
+ | n <= 0
+ = return ()
+ | otherwise
+ = MC.mask_ $ do
#if defined(mingw32_HOST_OS)
- void $ Win32.releaseSemaphore sem (fromIntegral n)
+ void $ Win32.releaseSemaphore sem (fromIntegral n)
#else
- replicateM_ n (Posix.semPost sem)
+ replicateM_ n (Posix.semPost sem)
#endif
-- | Destroy the given semaphore.
@@ -170,7 +227,7 @@ destroySemaphore sem =
getSemaphoreValue :: Semaphore -> IO Int
getSemaphoreValue (Semaphore { semaphore = sem }) =
#if defined(mingw32_HOST_OS)
- do
+ MC.mask_ $ do
wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
if wait_res == Win32.wAIT_OBJECT_0
-- We were able to acquire a resource from the semaphore without waiting:
@@ -216,19 +273,20 @@ forkWaitOnSemaphoreInterruptible
#if defined(mingw32_HOST_OS)
-- Windows: wait on both the handle used for cancelling the wait
-- and on the semaphore.
- --
- -- Only in the case that the wait result is WAIT_OBJECT_0 will
- -- we have succeeded in obtaining a token from the semaphore.
- (== Win32.wAIT_OBJECT_0) <$>
- Win32.waitForMultipleObjects
- [ Win32.semaphoreHandle sem
- , cancelHandle ]
- False -- False <=> WaitAny
- Win32.iNFINITE
+ do
+ wait_res <-
+ Win32.waitForMultipleObjects
+ [ Win32.semaphoreHandle sem
+ , cancelHandle ]
+ False -- False <=> WaitAny
+ Win32.iNFINITE
+ return $ wait_res == Win32.wAIT_OBJECT_0
+ -- Only in the case that the wait result is WAIT_OBJECT_0 will
+ -- we have succeeded in obtaining a token from the semaphore.
#else
-- POSIX: use the 'semWaitInterruptible' interruptible FFI call
-- that can be interrupted when we send a killThread signal.
- Posix.semWaitInterruptible (semaphore sem)
+ Posix.semWaitInterruptible sem
#endif
waitingThreadId <- forkIO $ MC.mask_ $ do
wait_res <- MC.try interruptible_wait
@@ -246,3 +304,49 @@ interruptWaitOnSemaphore ( WaitId { .. } ) = do
killThread waitingThreadId
-- On POSIX, killing the thread will cancel the wait on the semaphore
-- due to the FFI call being interruptible ('semWaitInterruptible').
+
+---------------------------------------
+-- Abstract semaphores
+
+-- | Abstraction over the operations of a semaphore.
+data AbstractSem =
+ AbstractSem
+ { acquireSem :: IO ()
+ , releaseSem :: IO ()
+ }
+
+withAbstractSem :: AbstractSem -> IO b -> IO b
+withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
+
+---------------------------------------
+-- Utility
+
+iToBase62 :: Int -> String
+iToBase62 m = go m' ""
+ where
+ m'
+ | m == minBound
+ = maxBound
+ | otherwise
+ = abs m
+ go n cs | n < 62
+ = let !c = chooseChar62 n
+ in c : cs
+ | otherwise
+ = let !(!q, r) = quotRem n 62
+ !c = chooseChar62 r
+ in go q (c : cs)
+
+ chooseChar62 :: Int -> Char
+ {-# INLINE chooseChar62 #-}
+ chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)
+ chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
+
+random_strings :: IO (NonEmpty String)
+random_strings = do
+#if defined(mingw32_HOST_OS)
+ Win32.FILETIME t <- Win32.getSystemTimeAsFileTime
+#else
+ CClock t <- Posix.systemTime <$> Posix.getProcessTimes
+#endif
+ return $ fmap ( \ i -> iToBase62 (i + fromIntegral t) ) (0 :| [1..])
=====================================
packages
=====================================
@@ -66,5 +66,6 @@ libraries/Win32 - - https:/
libraries/xhtml - - https://github.com/haskell/xhtml.git
libraries/exceptions - - https://github.com/ekmett/exceptions.git
nofib nofib - -
+libraries/semaphore-compat - - -
libraries/stm - - ssh://git@github.com/haskell/stm.git
. - ghc.git -
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea49c30db3f85dcd051f3a1b42121b441c1935ca
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea49c30db3f85dcd051f3a1b42121b441c1935ca
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/20221027/2059860a/attachment-0001.html>
More information about the ghc-commits
mailing list