[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