[Git][ghc/ghc][wip/jsem] 2 commits: remove jsem test
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Thu Oct 27 17:29:17 UTC 2022
sheaf pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC
Commits:
98de50ce by sheaf at 2022-10-27T18:35:09+02:00
remove jsem test
- - - - -
f3d2cdf4 by sheaf at 2022-10-27T19:26:50+02:00
use semaphore-compat package + cleanups
- - - - -
25 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/.github/workflows/haskell-ci.yml
- + 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
- − testsuite/tests/driver/jsem/Main.hs
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,6 @@
packages: ./
, ../libraries/Win32
+ , ../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/.github/workflows/haskell-ci.yml
=====================================
@@ -0,0 +1,266 @@
+# This GitHub workflow config has been generated by a script via
+#
+# haskell-ci 'github' 'cabal.project'
+#
+# To regenerate the script (for example after adjusting tested-with) run
+#
+# haskell-ci regenerate
+#
+# For more information, see https://github.com/haskell-CI/haskell-ci
+#
+# version: 0.13.20211116
+#
+# REGENDATA ("0.13.20211116",["github","cabal.project"])
+#
+name: Haskell-CI
+on:
+ push:
+ branches:
+ - master
+ pull_request:
+ branches:
+ - master
+jobs:
+ linux:
+ name: Haskell-CI - Linux - ${{ matrix.compiler }}
+ runs-on: ubuntu-18.04
+ timeout-minutes:
+ 60
+ container:
+ image: buildpack-deps:bionic
+ continue-on-error: ${{ matrix.allow-failure }}
+ strategy:
+ matrix:
+ include:
+ - compiler: ghc-9.2.1
+ compilerKind: ghc
+ compilerVersion: 9.2.1
+ setup-method: ghcup
+ allow-failure: false
+ - compiler: ghc-9.0.1
+ compilerKind: ghc
+ compilerVersion: 9.0.1
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-8.10.7
+ compilerKind: ghc
+ compilerVersion: 8.10.7
+ setup-method: ghcup
+ allow-failure: false
+ - compiler: ghc-8.8.4
+ compilerKind: ghc
+ compilerVersion: 8.8.4
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-8.6.5
+ compilerKind: ghc
+ compilerVersion: 8.6.5
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-8.4.4
+ compilerKind: ghc
+ compilerVersion: 8.4.4
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-8.2.2
+ compilerKind: ghc
+ compilerVersion: 8.2.2
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-8.0.2
+ compilerKind: ghc
+ compilerVersion: 8.0.2
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-7.10.3
+ compilerKind: ghc
+ compilerVersion: 7.10.3
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-7.8.4
+ compilerKind: ghc
+ compilerVersion: 7.8.4
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-7.6.3
+ compilerKind: ghc
+ compilerVersion: 7.6.3
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-7.4.2
+ compilerKind: ghc
+ compilerVersion: 7.4.2
+ setup-method: hvr-ppa
+ allow-failure: false
+ - compiler: ghc-7.4.1
+ compilerKind: ghc
+ compilerVersion: 7.4.1
+ setup-method: hvr-ppa
+ allow-failure: false
+ fail-fast: false
+ steps:
+ - name: apt
+ run: |
+ apt-get update
+ apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
+ mkdir -p "$HOME/.ghcup/bin"
+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
+ chmod a+x "$HOME/.ghcup/bin/ghcup"
+ "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
+ else
+ apt-add-repository -y 'ppa:hvr/ghc'
+ apt-get update
+ apt-get install -y "$HCNAME"
+ mkdir -p "$HOME/.ghcup/bin"
+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
+ chmod a+x "$HOME/.ghcup/bin/ghcup"
+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
+ fi
+ env:
+ HCKIND: ${{ matrix.compilerKind }}
+ HCNAME: ${{ matrix.compiler }}
+ HCVER: ${{ matrix.compilerVersion }}
+ - name: Set PATH and environment variables
+ run: |
+ echo "$HOME/.cabal/bin" >> $GITHUB_PATH
+ echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
+ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
+ echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
+ HCDIR=/opt/$HCKIND/$HCVER
+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
+ HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
+ echo "HC=$HC" >> "$GITHUB_ENV"
+ echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
+ echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+ else
+ HC=$HCDIR/bin/$HCKIND
+ echo "HC=$HC" >> "$GITHUB_ENV"
+ echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
+ echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+ fi
+
+ HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
+ echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
+ echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
+ echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
+ echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
+ echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
+ echo "GHCJSARITH=0" >> "$GITHUB_ENV"
+ env:
+ HCKIND: ${{ matrix.compilerKind }}
+ HCNAME: ${{ matrix.compiler }}
+ HCVER: ${{ matrix.compilerVersion }}
+ - name: env
+ run: |
+ env
+ - name: write cabal config
+ run: |
+ mkdir -p $CABAL_DIR
+ cat >> $CABAL_CONFIG <<EOF
+ remote-build-reporting: anonymous
+ write-ghc-environment-files: never
+ remote-repo-cache: $CABAL_DIR/packages
+ logs-dir: $CABAL_DIR/logs
+ world-file: $CABAL_DIR/world
+ extra-prog-path: $CABAL_DIR/bin
+ symlink-bindir: $CABAL_DIR/bin
+ installdir: $CABAL_DIR/bin
+ build-summary: $CABAL_DIR/logs/build.log
+ store-dir: $CABAL_DIR/store
+ install-dirs user
+ prefix: $CABAL_DIR
+ repository hackage.haskell.org
+ url: http://hackage.haskell.org/
+ EOF
+ cat >> $CABAL_CONFIG <<EOF
+ program-default-options
+ ghc-options: $GHCJOBS +RTS -M3G -RTS
+ EOF
+ cat $CABAL_CONFIG
+ - name: versions
+ run: |
+ $HC --version || true
+ $HC --print-project-git-commit-id || true
+ $CABAL --version || true
+ - name: update cabal index
+ run: |
+ $CABAL v2-update -v
+ - name: install cabal-plan
+ run: |
+ mkdir -p $HOME/.cabal/bin
+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
+ echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
+ xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
+ rm -f cabal-plan.xz
+ chmod a+x $HOME/.cabal/bin/cabal-plan
+ cabal-plan --version
+ - name: checkout
+ uses: actions/checkout at v2
+ with:
+ path: source
+ - name: initial cabal.project for sdist
+ run: |
+ touch cabal.project
+ echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
+ cat cabal.project
+ - name: sdist
+ run: |
+ mkdir -p sdist
+ $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
+ - name: unpack
+ run: |
+ mkdir -p unpacked
+ find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
+ - name: generate cabal.project
+ run: |
+ PKGDIR_parsec="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/parsec-[0-9.]*')"
+ echo "PKGDIR_parsec=${PKGDIR_parsec}" >> "$GITHUB_ENV"
+ rm -f cabal.project cabal.project.local
+ touch cabal.project
+ touch cabal.project.local
+ echo "packages: ${PKGDIR_parsec}" >> cabal.project
+ if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package parsec" >> cabal.project ; fi
+ if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi
+ cat >> cabal.project <<EOF
+ EOF
+ $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(parsec)$/; }' >> cabal.project.local
+ cat cabal.project
+ cat cabal.project.local
+ - name: dump install plan
+ run: |
+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
+ cabal-plan
+ - name: cache
+ uses: actions/cache at v2
+ with:
+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
+ path: ~/.cabal/store
+ restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
+ - name: install dependencies
+ run: |
+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
+ - name: build w/o tests
+ run: |
+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
+ - name: build
+ run: |
+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
+ - name: tests
+ run: |
+ $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
+ - name: cabal check
+ run: |
+ cd ${PKGDIR_parsec} || false
+ ${CABAL} -vnormal check
+ - name: haddock
+ run: |
+ $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
+ - name: unconstrained build
+ run: |
+ rm -f cabal.project.local
+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
=====================================
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 @@
+packages: .
=====================================
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 -> Just $ 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,8 +176,9 @@ 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
#endif
@@ -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,15 +273,16 @@ 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.
@@ -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 <- fromIntegral . 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 -
=====================================
testsuite/tests/driver/jsem/Main.hs deleted
=====================================
@@ -1,243 +0,0 @@
-{-# LANGUAGE Haskell2010 #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Main ( main ) where
-
--- base
-import Control.Concurrent
- ( forkIO, threadDelay, killThread
- , newEmptyMVar, takeMVar, putMVar )
-import Control.Monad
- ( (>=>), forM, when )
-import Data.Foldable
- ( fold, forM_ )
-import System.Console.GetOpt
- ( OptDescr(..), ArgDescr(..), ArgOrder(..)
- , getOpt )
-import System.Environment
- ( getArgs, getExecutablePath )
-import Text.Read
- ( readMaybe )
-
--- ghc
-import GHC.Driver.MakeSem
- ( runJSemAbstractSem )
-import GHC.Utils.IO.Semaphore
- ( Semaphore, SemaphoreName(..)
- , createSemaphore, destroySemaphore
- , waitOnSemaphore, releaseSemaphore
- , getSemaphoreValue
- , AbstractSem(..), withAbstractSem
- )
-import GHC.Utils.Logger
- ( Logger, initLogger, logDumpMsg )
-import GHC.Utils.Outputable
- ( ppr, empty )
-
--- exceptions
-import Control.Monad.Catch
- ( SomeException, onException
- , bracket, bracket_, mask
- , try, throwM )
-
--- process
-import System.Process
- ( callProcess )
-
--- stm
-import Control.Concurrent.STM
- ( atomically
- , newTVarIO, readTVar, stateTVar )
-
--- containers
-import Data.Tree
- ( Tree(..), unfoldTree )
-
---------------------------------------------------------------------------------
-
-withNewSem :: Logger -> Int -> SemaphoreName -> (Semaphore -> IO a) -> IO a
-withNewSem logger n nm act = bracket enter exit act
- where
- enter = createSemaphore nm n
- exit sem = do
- v <- getSemaphoreValue sem
- logDumpMsg logger "exit" (ppr v)
- destroySemaphore sem
-
-runWithAbstractSem :: Logger
- -> SemaphoreName -> Maybe Int
- -> (AbstractSem -> IO a) -> IO a
-runWithAbstractSem logger nm mb_sz act =
- case mb_sz of
- Nothing -> runJSemAbstractSem logger nm act
- Just n -> withNewSem logger n nm \ sem ->
- let
- acquire = do
- logDumpMsg logger "acquire {" empty
- waitOnSemaphore sem
- logDumpMsg logger "acquire }" empty
- release = do
- logDumpMsg logger "release {" empty
- let toks_release = 1
- toks_before <- releaseSemaphore sem toks_release
- logDumpMsg logger "release }" (ppr $ toks_before + toks_release)
- in act (AbstractSem { acquireSem = acquire
- , releaseSem = release })
-
-type Job a = Tree a
-
-semChecker :: Int -> (a -> IO ()) -> IO (a -> IO (), IO ())
-semChecker n act = do
- tv <- newTVarIO 0
- let
- check b msg = unless b . throwM . userError $ msg
- woggle f = do
- r <- atomically $ stateTVar tv $ \x -> (f x, x)
- check (r >= 0 && r <= n) $ "semChecker:sem out of bounds:" <> show r
-
- enter = woggle (+ 1)
- exit = woggle (subtract 1)
-
- check_final = readTVar tv >>= \x -> check (x == 0) $ "semChecker:check_final:" <> show x
- pure (\a -> bracket_ enter exit (act a), atomically check_final)
-
--- | Executes job and blocks until it completes.
--- Throws exception on failure
--- All threads forked are joined before return
-runJob :: AbstractSem -> (a -> IO ()) -> (Job a -> IO ()) -> Job a -> IO ()
-runJob sem act_leaf act (Node { rootLabel, subForest }) =
- mask $ \unmask -> withAbstractSem sem $ do
- rs <- forM subForest $ \a -> do
- mv <- newEmptyMVar
- tid <- forkIO $ try @_ @SomeException (unmask $ act a) >>= putMVar mv
- pure (mv, tid)
- let
- workload = do
- act_leaf rootLabel
- forM_ rs $ \(mv,_) -> takeMVar mv >>= either throwM pure
- unmask workload `onException` forM rs (\(_,tid) -> killThread tid)
-
-
-runJobLocal :: AbstractSem -> (a -> IO ()) -> Job a -> IO ()
-runJobLocal sem act j = runJob sem act (runJobLocal sem act) j
-
-runJobSubprocess :: Show a => Options -> AbstractSem -> (a -> IO ()) -> Job a -> IO ()
-runJobSubprocess ( Options { exeName = exe
- , semName = sem_nm
- , semSize = sz } )
- sem act j0
- = runJob sem act go j0
- where
- go j =
- withAbstractSem sem $
- callProcess exe
- [ "-n " <> getSemaphoreName sem_nm
- , "-s " <> show sz
- , "-j " <> show j ]
-
---runJobWithSem :: Int -> Semaphore -> (a -> IO ()) -> Job a -> IO ()
---runJobWithSem semSize s act j
--- = bracket (semChecker semSize act) (\(_,x) -> x) $ \(sem_checker,_) -> do
--- let ab_sem = undefined s
--- runJob s sem_checker j
-
-
-main :: IO ()
-main = do
- opts@( Options{ semName
- , semSize
- , job
- , delegate } ) <- getOptions
-
- logger <- initLogger
-
- (sem_checker, check_final) <- let
- act_leaf = threadDelay
- in semChecker semSize act_leaf
-
- runWithAbstractSem logger semName (Just semSize) $ \sem -> do
- let
- go j | delegate = runJobSubprocess opts sem sem_checker j
- | otherwise = runJobLocal sem sem_checker j
- runJob sem sem_checker go job
- check_final
-
--------------------------------------------
--- Command line argument handling.
-
-data Options = Options
- { isLeader :: !Bool -- TODO: unused
- , semName :: !SemaphoreName
- , job :: !(Job Int)
- , semSize :: !Int
- , delegate :: !Bool
- , exeName :: !FilePath
- }
-
-defaultOptions :: IO Options
-defaultOptions = do
- exe_nm <- getExecutablePath
- pure $
- Options
- { isLeader = False
- , semName = SemaphoreName "jsemsem"
- , job = pure 1
- , semSize = 10
- , delegate = True
- , exeName = exe_nm
- }
-
-newtype OptionsBuilder =
- OptionsBuilder { buildOptions :: Options -> IO Options }
-
-instance Semigroup OptionsBuilder where
- OptionsBuilder x <> OptionsBuilder y = OptionsBuilder $ x >=> y
-
-instance Monoid OptionsBuilder where
- mempty = OptionsBuilder pure
-
-setSemName :: String -> OptionsBuilder
-setSemName sem_nm = OptionsBuilder $ \ o ->
- pure $ o { semName = SemaphoreName sem_nm }
-
-setJobToDo :: String -> OptionsBuilder
-setJobToDo job_str = OptionsBuilder $ \ o ->
- case readMaybe job_str of
- Nothing -> throwM $ userError $ "failed to parse job: " <> job_str
- Just j -> pure $ o { job = j }
-
-setSemSize :: String -> OptionsBuilder
-setSemSize sz_str = OptionsBuilder $ \ o ->
- case readMaybe sz_str of
- Nothing -> throwM $ userError $ "failed to parse size: " <> sz_str
- Just sz -> pure $ o { semSize = sz }
-
-topJob :: Int -> Job Int
-topJob n = unfoldTree go n where
- go x | x <= 1 = (0, [])
- | otherwise = (x `div` 2, take n (repeat x))
-
-topJobOptionsBuilder :: OptionsBuilder
-topJobOptionsBuilder = OptionsBuilder $ \ o ->
- pure $ o { job = topJob 5, isLeader = True }
-
-options :: [OptDescr OptionsBuilder]
-options = [sem_name, sem_size, job, topjob]
- where
- sem_name = Option ['n'] ["sem-name"] (ReqArg setSemName "SEMNAME") "name of the semaphore"
- job = Option ['j'] ["job"] (ReqArg setJobToDo "JOB" ) "job to do"
- topjob = Option ['t'] ["topjob"] (NoArg topJobOptionsBuilder ) "default top job"
- sem_size = Option ['s'] ["sem-size"] (ReqArg setSemSize "SEMSIZE") "number of slots in the semaphore"
-
-getOptions :: IO Options
-getOptions = do
- args <- getArgs
- case getOpt RequireOrder options args of
- ([os],[],[]) -> defaultOptions >>= buildOptions os
- (_,uos,errs) -> throwM $ userError $ fold $
- [ "Parsing options failed:" ]
- <> [ "unrecognised option:" <> o | o <- uos ]
- <> [ "error: " <> e | e <- errs ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b3737f00937862a5d8c132e3deb8a3272543cd4...f3d2cdf4a31940b95956b1765a7325b12a062550
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b3737f00937862a5d8c132e3deb8a3272543cd4...f3d2cdf4a31940b95956b1765a7325b12a062550
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/d6558020/attachment-0001.html>
More information about the ghc-commits
mailing list