[Git][ghc/ghc][wip/jsem] use semaphore-compat package + cleanups

sheaf (@sheaf) gitlab at gitlab.haskell.org
Thu Oct 27 18:28:41 UTC 2022



sheaf pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC


Commits:
6c4a9934 by sheaf at 2022-10-27T20:28:21+02:00
use semaphore-compat package + cleanups

- - - - -


23 changed files:

- .gitmodules
- cabal.project-reinstall
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeSem.hs
- compiler/ghc.cabal.in
- hadrian/cabal.project
- hadrian/hadrian.cabal
- hadrian/src/Hadrian/Semaphore.hs
- − hadrian/src/Hadrian/Semaphore/System.hs
- hadrian/src/Packages.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- libraries/Cabal
- + libraries/semaphore-compat/.gitignore
- + libraries/semaphore-compat/LICENSE
- + libraries/semaphore-compat/Setup.hs
- + libraries/semaphore-compat/cabal.haskell-ci
- + libraries/semaphore-compat/cabal.project
- + libraries/semaphore-compat/changelog.md
- + libraries/semaphore-compat/readme.md
- + libraries/semaphore-compat/semaphore-compat.cabal
- compiler/GHC/Utils/IO/Semaphore.hs → libraries/semaphore-compat/src/System/Semaphore.hs
- packages


Changes:

=====================================
.gitmodules
=====================================
@@ -83,6 +83,10 @@
 	url = https://gitlab.haskell.org/ghc/packages/unix.git
 	ignore = untracked
 	branch = 2.7
+[submodule "libraries/semaphore-compat"]
+	path = libraries/semaphore-compat
+	url = https://gitlab.haskell.org/ghc/packages/semaphore-compat.git
+	ignore = untracked
 [submodule "libraries/stm"]
 	path = libraries/stm
 	url = https://gitlab.haskell.org/ghc/packages/stm.git


=====================================
cabal.project-reinstall
=====================================
@@ -29,6 +29,7 @@ packages: ./compiler
           ./libraries/parsec/
           -- ./libraries/pretty/
           ./libraries/process/
+          ./libraries/semaphore-compat
           ./libraries/stm
           -- ./libraries/template-haskell/
           ./libraries/terminfo/


=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2876,12 +2876,12 @@ runNjobsAbstractSem n_jobs action = do
     resetNumCapabilities = set_num_caps n_capabilities
   MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem
 
-runWorkerLimit :: WorkerLimit -> Logger -> (AbstractSem -> IO a) -> IO a
-runWorkerLimit worker_limit logger action = case worker_limit of
+runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
+runWorkerLimit worker_limit action = case worker_limit of
     NumProcessorsLimit n_jobs ->
-      runNjobsAbstractSem n_jobs action -- TODO: could use the logger here too.
+      runNjobsAbstractSem n_jobs action
     JSemLimit sem ->
-      runJSemAbstractSem logger sem action
+      runJSemAbstractSem sem action
 
 -- | Build and run a pipeline
 runParPipelines :: WorkerLimit -- ^ How to limit work parallelism
@@ -2906,10 +2906,7 @@ runParPipelines worker_limit plugin_hsc_env mHscMessager all_pipelines = do
   thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
   let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
 
-
-
---  let sem_logger = modify_logger $ hsc_logger thread_safe_hsc_env
-  runWorkerLimit worker_limit (hsc_logger thread_safe_hsc_env) $ \abstract_sem -> do
+  runWorkerLimit worker_limit $ \abstract_sem -> do
     let env = MakeEnv { hsc_env = thread_safe_hsc_env
                       , withLogger = withParLog log_queue_queue_var
                       , compile_sem = abstract_sem


=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -25,13 +25,12 @@ import GHC.Prelude
 import GHC.Conc
 import GHC.Data.OrdList
 import GHC.IO.Exception
-import GHC.Utils.IO.Semaphore
-import GHC.Utils.Logger
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
-import GHC.Utils.Trace
 import GHC.Utils.Json
 
+import System.Semaphore
+
 import Control.Monad
 import qualified Control.Monad.Catch as MC
 import Control.Concurrent.MVar
@@ -55,8 +54,6 @@ data Jobserver
   , jobs :: !(TVar JobResources)
     -- ^ The currently pending jobs, and the resources
     -- obtained from the semaphore
-  , jobsLogger :: !Logger
-    -- ^ The logger used for the jobserver.
   }
 
 data JobserverOptions
@@ -177,19 +174,18 @@ guardRelease ( Jobs { tokensFree, tokensOwned, jobsWaiting } )
 -- | Add one pending job to the jobserver.
 --
 -- Blocks, waiting on the jobserver to supply a free token.
-acquireJob :: Logger -> TVar JobResources -> IO ()
-acquireJob logger jobs_tvar = do
-  (job_tmvar, jobs0) <- tracedAtomically "acquire" $ modifyJobResources jobs_tvar \ jobs -> do
-    job_tmvar <- newEmptyTMVar
-    return ((job_tmvar, jobs), addJob job_tmvar jobs)
-  logDumpMsg logger "acquireJob {" $ ppr jobs0
-  jobs1 <- atomically $ takeTMVar job_tmvar >> readTVar jobs_tvar
-  logDumpMsg logger "acquireJob }" $ ppr jobs1
+acquireJob :: TVar JobResources -> IO ()
+acquireJob jobs_tvar = do
+  (job_tmvar, _jobs0) <- tracedAtomically "acquire" $
+    modifyJobResources jobs_tvar \ jobs -> do
+      job_tmvar <- newEmptyTMVar
+      return ((job_tmvar, jobs), addJob job_tmvar jobs)
+  atomically $ takeTMVar job_tmvar
 
 -- | Signal to the job server that one job has completed,
 -- releasing its corresponding token.
-releaseJob :: Logger -> TVar JobResources -> IO ()
-releaseJob logger jobs_tvar = do
+releaseJob :: TVar JobResources -> IO ()
+releaseJob jobs_tvar = do
   tracedAtomically "release" do
     modifyJobResources jobs_tvar \ jobs -> do
       massertPpr (tokensFree jobs < tokensOwned jobs)
@@ -201,20 +197,13 @@ releaseJob logger jobs_tvar = do
 -- the jobserver at the end).
 cleanupJobserver :: Jobserver -> IO ()
 cleanupJobserver (Jobserver { jSemaphore = sem
-                            , jobs       = jobs_tvar
-                            , jobsLogger = logger })
+                            , jobs       = jobs_tvar })
   = do
-    jobs@(Jobs { tokensOwned = owned }) <- readTVarIO jobs_tvar
-    logDumpMsg logger "cleanupJobserver {" $
-      vcat [ text "about to release all owned semaphore tokens"
-           , ppr jobs ]
-    -- (-1) because the caller of GHC is responsible for releasing the last slot on the semaphore.
+    Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar
     let toks_to_release = owned - 1
-    when (toks_to_release > 0) do
-      tokens_before <- releaseSemaphore sem toks_to_release
-      logDumpMsg logger "cleanupJobserver }" $
-        vcat [ text "released:" <+> ppr toks_to_release
-             , text "semaphore count before release:" <+> ppr tokens_before ]
+      -- Subtract off the implicit token: whoever spawned the ghc process
+      -- in the first place is responsible for that token.
+    releaseSemaphore sem toks_to_release
 
 -- | Dispatch the available tokens acquired from the semaphore
 -- to the pending jobs in the job server.
@@ -261,8 +250,7 @@ tracedAtomically_ s act = tracedAtomically s (((),) <$> act)
 tracedAtomically :: String -> STM (a, Maybe JobResources) -> IO a
 tracedAtomically origin act = do
   (a, mjr) <- atomically act
-  forM_ mjr $ \jr -> do
-    -- MP: Could also trace to a logger here as well with suitable verbosity
+  forM_ mjr $ \ jr -> do
     -- Use the "jsem:" prefix to identify where the write traces are
     traceEventIO ("jsem:" ++ renderJobResources origin jr)
   return a
@@ -321,14 +309,13 @@ releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
     then return Idle
     else do
       tid <- forkIO $ do
-        x <- MC.try $ void $ do
-               releaseSemaphore sem 1
+        x <- MC.try $ releaseSemaphore sem 1
         tracedAtomically_ "post-release" $ do
           (r, jobs) <- case x of
             Left (e :: MC.SomeException) -> do
               modifyJobResources jobs_tvar \ jobs ->
                 return (Just e, addToken jobs)
-            Right () -> do
+            Right _ -> do
               return (Nothing, Nothing)
           putTMVar threadFinished_tmvar r
           return jobs
@@ -428,9 +415,6 @@ tryStopThread jobs_tvar jsj = do
        interruptWaitOnSemaphore wait_id
        return $ jsj { jobserverAction = Idle }
     _ -> retry
-    where
-     kill_thread_and_idle tid =
-       killThread tid $> jsj { jobserverAction = Idle }
 
 -- | Main jobserver loop: acquire/release resources as
 -- needed for the pending jobs and available semaphore tokens.
@@ -457,8 +441,8 @@ jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })
       loop s
 
 -- | Create a new jobserver using the given semaphore handle.
-makeJobserver :: Logger -> SemaphoreName -> IO (AbstractSem, IO ())
-makeJobserver logger sem_name = do
+makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())
+makeJobserver sem_name = do
   semaphore <- openSemaphore sem_name
   let
     init_jobs =
@@ -470,8 +454,7 @@ makeJobserver logger sem_name = do
   let
     opts = defaultJobserverOptions -- TODO: allow this to be configured
     sjs = Jobserver { jSemaphore = semaphore
-                    , jobs       = jobs_tvar
-                    , jobsLogger = logger }
+                    , jobs       = jobs_tvar }
   loop_finished_mvar <- newEmptyMVar
   loop_tid <- forkIOWithUnmask \ unmask -> do
     r <- try $ unmask $ jobserverLoop opts sjs
@@ -485,8 +468,8 @@ makeJobserver logger sem_name = do
         Right () -> Nothing
   labelThread loop_tid "job_server"
   let
-    acquireSem = acquireJob logger jobs_tvar
-    releaseSem = releaseJob logger jobs_tvar
+    acquireSem = acquireJob jobs_tvar
+    releaseSem = releaseJob jobs_tvar
     cleanupSem = do
       -- this is interruptible
       cleanupJobserver sjs
@@ -498,13 +481,12 @@ makeJobserver logger sem_name = do
 
 -- | Implement an abstract semaphore using a semaphore 'Jobserver'
 -- which queries the system semaphore of the given name for resources.
-runJSemAbstractSem :: Logger
-                   -> SemaphoreName         -- ^ the system semaphore to use
+runJSemAbstractSem :: SemaphoreName         -- ^ the system semaphore to use
                    -> (AbstractSem -> IO a) -- ^ the operation to run
                                             -- which requires a semaphore
                    -> IO a
-runJSemAbstractSem logger sem action = MC.mask \ unmask -> do
-  (abs, cleanup) <- makeJobserver logger sem
+runJSemAbstractSem sem action = MC.mask \ unmask -> do
+  (abs, cleanup) <- makeJobserver sem
   r <- try $ unmask $ action abs
   case r of
     Left (e1 :: MC.SomeException) -> do


=====================================
compiler/ghc.cabal.in
=====================================
@@ -90,6 +90,7 @@ Library
                    hpc        == 0.6.*,
                    transformers == 0.5.*,
                    exceptions == 0.10.*,
+                   semaphore-compat,
                    stm,
                    ghc-boot   == @ProjectVersionMunged@,
                    ghc-heap   == @ProjectVersionMunged@,
@@ -793,7 +794,6 @@ Library
         GHC.Utils.FV
         GHC.Utils.GlobalVars
         GHC.Utils.IO.Unsafe
-        GHC.Utils.IO.Semaphore
         GHC.Utils.Json
         GHC.Utils.Lexeme
         GHC.Utils.Logger


=====================================
hadrian/cabal.project
=====================================
@@ -1,5 +1,7 @@
 packages: ./
         , ../libraries/Win32
+        , ../libraries/unix
+        , ../libraries/semaphore-compat
 
 -- This essentially freezes the build plan for hadrian
 index-state: 2022-09-10T18:46:55Z


=====================================
hadrian/hadrian.cabal
=====================================
@@ -68,7 +68,6 @@ executable hadrian
                        , Hadrian.Target
                        , Hadrian.Utilities
                        , Hadrian.Semaphore
-                       , Hadrian.Semaphore.System
                        , Oracles.Flag
                        , Oracles.Flavour
                        , Oracles.Setting
@@ -160,6 +159,7 @@ executable hadrian
                        , time
                        , mtl                  == 2.2.*
                        , parsec               >= 3.1     && < 3.2
+                       , semaphore-compat
                        , shake                >= 0.18.3  && < 0.20
                        , transformers         >= 0.4     && < 0.6
                        , unordered-containers >= 0.2.1   && < 0.3


=====================================
hadrian/src/Hadrian/Semaphore.hs
=====================================
@@ -5,48 +5,49 @@ module Hadrian.Semaphore
   , Semaphore, SemaphoreName(..)
   ) where
 
-import Hadrian.Semaphore.System
-import Hadrian.Utilities
-import Development.Shake
-import Control.Exception ( SomeException, try )
+-- base
 import Control.Monad ( void )
 
-data GlobalSemaphore = NoSemaphore | GlobalSemaphore SemaphoreName Semaphore
+-- semaphore-compat
+import System.Semaphore
+
+-- shake
+import Development.Shake
+
+-- hadrian
+import Hadrian.Utilities
+
+--------------------------------------------------------------------------------
+
+data GlobalSemaphore = NoSemaphore | GlobalSemaphore Semaphore
 
 getJsemSemaphore :: Action GlobalSemaphore
 getJsemSemaphore = userSetting NoSemaphore
 
 globalSemaphore :: a -> (SemaphoreName -> Semaphore -> a) -> GlobalSemaphore -> a
-globalSemaphore def _ NoSemaphore = def
-globalSemaphore _ f (GlobalSemaphore fp sem) = f fp sem
+globalSemaphore def _ NoSemaphore           = def
+globalSemaphore _   f (GlobalSemaphore sem) = f (semaphoreName sem) sem
 
 initialiseSemaphore :: Int -> IO GlobalSemaphore
-initialiseSemaphore n = do
-  let sem_nm = SemaphoreName "hadrian_semaphore"
-  -- Destroy any previous semaphore by this name...
-  _ <- void $ try @SomeException $ do
-    old_sem <- openSemaphore sem_nm
-    destroySemaphore old_sem
-  sem <- createSemaphore sem_nm n
-  return (GlobalSemaphore sem_nm sem)
+initialiseSemaphore n
+  | n <= 0
+  = error $ unlines
+    [ "hadrian: attempting to create a semaphore with no slots"
+    , "Perhaps you tried to use -j, without specifying a number?"
+    , "In which case, use -jN instead of -j." ]
+  | otherwise
+  = GlobalSemaphore <$> freshSemaphore "hadrian_semaphore" n
 
 unlinkSemaphore :: GlobalSemaphore -> IO ()
-unlinkSemaphore NoSemaphore = return ()
-unlinkSemaphore (GlobalSemaphore _ sem) = destroySemaphore sem
+unlinkSemaphore NoSemaphore           = return ()
+unlinkSemaphore (GlobalSemaphore sem) = destroySemaphore sem
 
 -- | Wrap an action which requires the semaphore with wait/post
 withSemaphore :: GlobalSemaphore -> Action a -> Action a
 withSemaphore sem act =
-  globalSemaphore act (\_ sem -> actionBracket (wait sem) (\_ -> post sem) (\_ -> act)) sem
+  globalSemaphore act
+    ( \ _ sem -> actionBracket (wait sem) (\_ -> post sem) (\_ -> act) )
+    sem
   where
-    wait s = do
-      n <- getSemaphoreValue s
-      liftIO $ print ("WAITING:" ++ show n)
-      waitOnSemaphore s
-      liftIO $ print "WAITED"
-
-    post s = do
-      liftIO $ print "POST"
-      n <- releaseSemaphore s 1
-
-      liftIO $ print ("SEM_VALUE:" ++ show (n+1))
+    wait s = void $ waitOnSemaphore s
+    post s = releaseSemaphore s 1


=====================================
hadrian/src/Hadrian/Semaphore/System.hs deleted
=====================================
@@ -1,176 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Hadrian.Semaphore.System
-  ( -- * System semaphores
-    Semaphore(..), SemaphoreName(..)
-  , createSemaphore, openSemaphore
-  , waitOnSemaphore, tryWaitOnSemaphore
-  , getSemaphoreValue
-  , releaseSemaphore
-  , destroySemaphore
-
-  -- * Abstract semaphores
-  , AbstractSem(..)
-  , withAbstractSem
-  ) where
-
-import Control.Monad
-
-import qualified Control.Monad.Catch as MC
-
-#if defined(mingw32_HOST_OS)
-import qualified System.Win32.Event     as Win32
-  ( waitForSingleObject, wAIT_OBJECT_0 )
-import qualified System.Win32.File      as Win32
-  ( closeHandle )
-import qualified System.Win32.Process   as Win32
-  ( iNFINITE )
-import qualified System.Win32.Semaphore as Win32
-  ( Semaphore(..), sEMAPHORE_ALL_ACCESS
-  , createSemaphore, openSemaphore, releaseSemaphore )
-import qualified System.Win32.Types     as Win32
-  ( errorWin )
-#else
-import qualified System.Posix.Semaphore as Posix
-  ( Semaphore, OpenSemFlags(..)
-  , semOpen, semThreadWait, semTryWait
-  , semGetValue, semPost, semUnlink )
-import qualified System.Posix.Files     as Posix
-  ( stdFileMode )
-#endif
-
----------------------------------------
--- Abstract semaphores
-
--- | Abstraction over the operations of a semaphore,
--- allowing usage with -jN or a jobserver.
-data AbstractSem = AbstractSem { acquireSem :: IO ()
-                               , releaseSem :: IO ()
-                               }
-
-withAbstractSem :: AbstractSem -> IO b -> IO b
-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-
----------------------------------------
--- System-specific semaphores
-
-newtype SemaphoreName =
-  SemaphoreName { getSemaphoreName :: String }
-  deriving Eq
-
--- | A semaphore (POSIX or Win32).
-data Semaphore =
-  Semaphore
-    { semaphoreName :: !SemaphoreName
-    , semaphore     ::
-#if defined(mingw32_HOST_OS)
-      !Win32.Semaphore
-#else
-      !Posix.Semaphore
-#endif
-    }
-
--- | Create a new semaphore with the given name and initial amount of
--- available resources.
---
--- Throws an error if a semaphore by this name already exists.
-createSemaphore :: SemaphoreName -> Int -> IO Semaphore
-createSemaphore nm@(SemaphoreName sem_name) init_toks = do
-#if defined(mingw32_HOST_OS)
-  let toks = fromIntegral init_toks
-  (sem, exists) <- Win32.createSemaphore Nothing toks toks (Just sem_name)
-  when exists $
-    Win32.errorWin ("jsem: semaphore " ++ sem_name ++ " already exists")
-#else
-  let flags =
-        Posix.OpenSemFlags
-          { Posix.semCreate    = True
-          , Posix.semExclusive = True }
-  sem <- Posix.semOpen sem_name flags Posix.stdFileMode init_toks
-#endif
-  return $
-    Semaphore
-      { semaphore     = sem
-      , semaphoreName = nm }
-
--- | Open a semaphore with the given name.
---
--- If no such semaphore exists, throws an error.
-openSemaphore :: SemaphoreName -> IO Semaphore
-openSemaphore nm@(SemaphoreName sem_name) = do
-#if defined(mingw32_HOST_OS)
-  sem <- Win32.openSemaphore Win32.sEMAPHORE_ALL_ACCESS True sem_name
-#else
-  let
-    flags = Posix.OpenSemFlags
-          { Posix.semCreate    = False
-          , Posix.semExclusive = False }
-  sem <- Posix.semOpen sem_name flags Posix.stdFileMode 0
-#endif
-  return $
-    Semaphore
-      { semaphore     = sem
-      , semaphoreName = nm }
-
--- | Indefinitely wait on a semaphore.
-waitOnSemaphore :: Semaphore -> IO ()
-waitOnSemaphore (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
-  void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
-#else
-  Posix.semThreadWait sem
-#endif
-
--- | Try to obtain a token from the semaphore, without blocking.
---
--- Immediately returns 'False' if no resources are available.
-tryWaitOnSemaphore :: Semaphore -> IO Bool
-tryWaitOnSemaphore (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
-  (== Win32.wAIT_OBJECT_0) <$> Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
-#else
-  Posix.semTryWait sem
-#endif
-
--- | Release a semaphore: add @n@ to its internal counter,
--- and return the semaphore's count before the operation.
---
--- NB: the returned value should only be used for debugging,
--- not for the main jobserver logic.
-releaseSemaphore :: Semaphore -> Int -> IO Int
-releaseSemaphore (Semaphore { semaphore = sem }) n =
-#if defined(mingw32_HOST_OS)
-  fromIntegral <$> Win32.releaseSemaphore sem (fromIntegral n)
-#else
-  do
-    res <- Posix.semGetValue sem
-    replicateM_ n (Posix.semPost sem)
-    return res
-#endif
-
--- | Destroy the given semaphore.
-destroySemaphore :: Semaphore -> IO ()
-destroySemaphore sem =
-#if defined(mingw32_HOST_OS)
-  Win32.closeHandle (Win32.semaphoreHandle $ semaphore sem)
-#else
-  Posix.semUnlink (getSemaphoreName $ semaphoreName sem)
-#endif
-
--- | Query the current semaphore value (how many tokens it has available).
-getSemaphoreValue :: Semaphore -> IO Int
-getSemaphoreValue (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
-  do
-    wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) (fromInteger 0)
-    if wait_res == Win32.wAIT_OBJECT_0
-      -- We were able to immediately acquire a resource from the semaphore:
-      -- release it immediately, thus obtaining the total number of available
-      -- resources.
-    then
-      (+1) . fromIntegral <$> Win32.releaseSemaphore sem 1
-    else
-      return 0
-#else
-  Posix.semGetValue sem
-#endif


=====================================
hadrian/src/Packages.hs
=====================================
@@ -8,7 +8,7 @@ module Packages (
     ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline,
     hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy,
     libffi, libiserv, mtl, parsec, pretty, primitive, process, remoteIserv, rts,
-    runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy,
+    runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout, touchy,
     transformers, unlit, unix, win32, xhtml,
     lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
     ghcPackages, isGhcPackage,
@@ -39,7 +39,7 @@ ghcPackages =
     , exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh
     , ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs
     , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl
-    , parsec, pretty, process, rts, runGhc, stm, templateHaskell
+    , parsec, pretty, process, rts, runGhc, semaphoreCompat, stm, templateHaskell
     , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
     , timeout
     , lintersCommon
@@ -55,7 +55,7 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count
   exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh,
   ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs,
   hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, libiserv, mtl,
-  parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell,
+  parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell,
   terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml,
   timeout,
   lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
@@ -111,6 +111,7 @@ process             = lib  "process"
 remoteIserv         = util "remote-iserv"
 rts                 = top  "rts"
 runGhc              = util "runghc"
+semaphoreCompat     = lib  "semaphore-compat"
 stm                 = lib  "stm"
 templateHaskell     = lib  "template-haskell"
 terminfo            = lib  "terminfo"


=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -67,11 +67,13 @@ compileAndLinkHs = (builder (Ghc . CompileHs) ||^ builder (Ghc LinkHs)) ? do
             , builder (Ghc (CompileHs GhcMake)) ? do
                 jsem <- expr getJsemSemaphore
                 mconcat
-                  ([ arg "--make"
-                  , arg "-no-link"
-                  ]
-                  ++ globalSemaphore []
-                      (\(SemaphoreName name) _ -> [ arg "-jsem", arg name ]) jsem)
+                  ( [ arg "--make"
+                    , arg "-no-link"
+                    ]
+                  ++
+                    globalSemaphore []
+                      (\(SemaphoreName name) _ -> [ arg "-jsem", arg name ]) jsem
+                  )
             , getInputs
             , notM (builder (Ghc (CompileHs GhcMake))) ? mconcat
                 [arg "-o", arg =<< getOutput]


=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -95,6 +95,7 @@ stage0Packages = do
              , hpcBin
              , mtl
              , parsec
+             , semaphoreCompat
              , time
              , templateHaskell
              , text
@@ -134,6 +135,7 @@ stage1Packages = do
         , integerGmp
         , pretty
         , rts
+        , semaphoreCompat
         , stm
         , unlit
         , xhtml


=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit b01efbe2b9119c0d5b257afd2eb264dd476868c2
+Subproject commit e1decb7eaedd14fe4ab8960cf3fed0b4154f1894


=====================================
libraries/semaphore-compat/.gitignore
=====================================
@@ -0,0 +1,11 @@
+/dist/
+/dist-boot/
+/dist-install/
+/dist-newstyle/
+/cabal.project.local
+/.cabal-sandbox/
+/cabal.sandbox.config
+/.ghc.environment.*
+*~
+ghc.mk
+GNUmakefile


=====================================
libraries/semaphore-compat/LICENSE
=====================================
@@ -0,0 +1,34 @@
+-----------------------------------------------------------------------------
+
+The Glasgow Haskell Compiler License
+
+Copyright 2022, The GHC team. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+ 
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+ 
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission. 
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
+
+-----------------------------------------------------------------------------


=====================================
libraries/semaphore-compat/Setup.hs
=====================================
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain


=====================================
libraries/semaphore-compat/cabal.haskell-ci
=====================================
@@ -0,0 +1 @@
+branches: master


=====================================
libraries/semaphore-compat/cabal.project
=====================================
@@ -0,0 +1,4 @@
+packages:
+  .,
+  ../unix,
+  ../Win32


=====================================
libraries/semaphore-compat/changelog.md
=====================================
@@ -0,0 +1,3 @@
+### 1.0.0 (October 27th, 2022)
+
+- First version of the `semaphore-compat` package.


=====================================
libraries/semaphore-compat/readme.md
=====================================
@@ -0,0 +1,16 @@
+# semaphore-compat
+
+`semaphore-compat` provides a cross-platform implementation of system semaphores
+that abstracts over the `unix` and `Win32` libraries.
+
+It supports:
+
+  - Creating (`createSemaphore`, `freshSemaphore`), opening (`openSemaphore`)
+    and closing (`destroySemaphore`) semaphores.
+  - Waiting on a semaphore:
+     - without blocking with `tryWaitOnSemaphore`,
+     - blocking forever, with `waitOnSemaphore`,
+     - blocking, in a separate thread and allowing interruption, with
+       `forkWaitOnSemaphoreInterruptible` and `interruptWaitOnSemaphore`.
+  - Releasing tokens to a semaphore (`releaseSemaphore`).
+  - Querying the semaphore for its current value (`getSemaphoreValue`).


=====================================
libraries/semaphore-compat/semaphore-compat.cabal
=====================================
@@ -0,0 +1,61 @@
+cabal-version: 3.0
+name:
+  semaphore-compat
+version:
+  1.0.0
+license:
+  BSD-3-Clause
+
+author:
+  The GHC team
+maintainer:
+  ghc-devs at haskell.org
+homepage:
+  https://gitlab.haskell.org/ghc/packages/semaphore-compat
+bug-reports:
+  https://gitlab.haskell.org/ghc/ghc/issues/new
+
+category:
+  System
+synopsis:
+  Cross-platform abstraction for system semaphores
+description:
+  This package provides a cross-platform implementation of system semaphores
+  that abstracts over the `unix` and `Win32` libraries.
+
+build-type:
+  Simple
+
+extra-source-files:
+    changelog.md
+  , readme.md
+
+
+source-repository head
+    type:     git
+    location: https://gitlab.haskell.org/ghc/packages/semaphore-compat.git
+
+library
+    hs-source-dirs:
+      src
+
+    exposed-modules:
+        System.Semaphore
+
+    build-depends:
+        base
+          >= 4.12 && < 4.19
+      , exceptions
+          >= 0.7  && < 0.11
+
+    if os(windows)
+      build-depends:
+        Win32
+          >= 2.13.4.0 && < 2.14
+    else
+      build-depends:
+        unix
+          >= 2.0 && < 2.9
+
+    default-language:
+      Haskell2010


=====================================
compiler/GHC/Utils/IO/Semaphore.hs → libraries/semaphore-compat/src/System/Semaphore.hs
=====================================
@@ -1,11 +1,13 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 
-module GHC.Utils.IO.Semaphore
+module System.Semaphore
   ( -- * System semaphores
     Semaphore(..), SemaphoreName(..)
-  , createSemaphore, openSemaphore
+  , createSemaphore, freshSemaphore, openSemaphore
   , waitOnSemaphore, tryWaitOnSemaphore
   , WaitId(..)
   , forkWaitOnSemaphoreInterruptible
@@ -19,13 +21,17 @@ module GHC.Utils.IO.Semaphore
   , withAbstractSem
   ) where
 
-import GHC.Prelude
+-- base
 import Control.Concurrent
 import Control.Monad
+import Data.List.NonEmpty ( NonEmpty(..) )
+import GHC.Exts ( Char(..), Int(..), indexCharOffAddr# )
 
+-- exceptions
 import qualified Control.Monad.Catch as MC
 
 #if defined(mingw32_HOST_OS)
+-- Win32
 import qualified System.Win32.Event     as Win32
   ( createEvent, setEvent
   , waitForSingleObject, waitForMultipleObjects
@@ -37,29 +43,26 @@ import qualified System.Win32.Process   as Win32
 import qualified System.Win32.Semaphore as Win32
   ( Semaphore(..), sEMAPHORE_ALL_ACCESS
   , createSemaphore, openSemaphore, releaseSemaphore )
+import qualified System.Win32.Time      as Win32
+  ( FILETIME(..), getSystemTimeAsFileTime )
 import qualified System.Win32.Types     as Win32
   ( HANDLE, errorWin )
 #else
+-- base
+import Foreign.C.Types
+  ( CClock(..) )
+
+-- unix
 import qualified System.Posix.Semaphore as Posix
   ( Semaphore, OpenSemFlags(..)
   , semOpen, semWaitInterruptible, semTryWait
   , semGetValue, semPost, semUnlink )
 import qualified System.Posix.Files     as Posix
   ( stdFileMode )
+import qualified System.Posix.Process   as Posix
+  ( ProcessTimes(systemTime), getProcessTimes )
 #endif
 
----------------------------------------
--- Abstract semaphores
-
--- | Abstraction over the operations of a semaphore,
--- allowing usage with -jN or a jobserver.
-data AbstractSem = AbstractSem { acquireSem :: IO ()
-                               , releaseSem :: IO ()
-                               }
-
-withAbstractSem :: AbstractSem -> IO b -> IO b
-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-
 ---------------------------------------
 -- System-specific semaphores
 
@@ -67,7 +70,7 @@ newtype SemaphoreName =
   SemaphoreName { getSemaphoreName :: String }
   deriving Eq
 
--- | A semaphore (POSIX or Win32).
+-- | A system semaphore (POSIX or Win32).
 data Semaphore =
   Semaphore
     { semaphoreName :: !SemaphoreName
@@ -83,24 +86,69 @@ data Semaphore =
 -- available resources.
 --
 -- Throws an error if a semaphore by this name already exists.
-createSemaphore :: SemaphoreName -> Int -> IO Semaphore
-createSemaphore nm@(SemaphoreName sem_name) init_toks = do
+createSemaphore :: SemaphoreName
+                -> Int -- ^ number of tokens on the semaphore
+                -> IO Semaphore
+createSemaphore (SemaphoreName sem_name) init_toks = do
+  mb_sem <- create_sem sem_name init_toks
+  case mb_sem of
+    Left  err -> err
+    Right sem -> return sem
+
+-- | Create a fresh semaphore with the given amount of tokens.
+--
+-- Its name will start with the given prefix, but will have a random suffix
+-- appended to it.
+freshSemaphore :: String -- ^ prefix
+               -> Int    -- ^ number of tokens on the semaphore
+               -> IO Semaphore
+freshSemaphore prefix init_toks = do
+  suffixes <- random_strings
+  go 0 suffixes
+  where
+    go :: Int -> NonEmpty String -> IO Semaphore
+    go i (suffix :| suffs) = do
+      mb_sem <- create_sem (prefix ++ "_" ++ suffix) init_toks
+      case mb_sem of
+        Right sem -> return sem
+        Left  err
+          | next : nexts <- suffs
+          , i < 32 -- give up after 32 attempts
+          -> go (i+1) (next :| nexts)
+          | otherwise
+          -> err
+
+create_sem :: String -> Int -> IO (Either (IO Semaphore) Semaphore)
+create_sem sem_str init_toks = do
 #if defined(mingw32_HOST_OS)
   let toks = fromIntegral init_toks
-  (sem, exists) <- Win32.createSemaphore Nothing toks toks (Just sem_name)
-  when exists $
-    Win32.errorWin ("jsem: semaphore " ++ sem_name ++ " already exists")
+  mb_sem <- MC.try @_ @MC.SomeException $
+    Win32.createSemaphore Nothing toks toks (Just sem_str)
+  return $ case mb_sem of
+    Right (sem, exists)
+      | exists
+      -> Left (Win32.errorWin $ "semaphore-compat: semaphore " ++ sem_str ++ " already exists")
+      | otherwise
+      -> Right $ mk_sem sem
+    Left err
+      -> Left $ MC.throwM err
 #else
   let flags =
         Posix.OpenSemFlags
           { Posix.semCreate    = True
           , Posix.semExclusive = True }
-  sem <- Posix.semOpen sem_name flags Posix.stdFileMode init_toks
+  mb_sem <- MC.try @_ @MC.SomeException $
+    Posix.semOpen sem_str flags Posix.stdFileMode init_toks
+  return $ case mb_sem of
+    Left  err -> Left $ MC.throwM err
+    Right sem -> Right $ mk_sem sem
 #endif
-  return $
-    Semaphore
-      { semaphore     = sem
-      , semaphoreName = nm }
+  where
+    sem_nm = SemaphoreName sem_str
+    mk_sem sem =
+      Semaphore
+        { semaphore     = sem
+        , semaphoreName = sem_nm }
 
 -- | Open a semaphore with the given name.
 --
@@ -128,10 +176,11 @@ openSemaphore nm@(SemaphoreName sem_name) = do
 waitOnSemaphore :: Semaphore -> IO Bool
 waitOnSemaphore (Semaphore { semaphore = sem }) =
 #if defined(mingw32_HOST_OS)
-  (== Win32.wAIT_OBJECT_0) <$>
-    Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
+  MC.mask_ $ do
+    wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
+    return $ wait_res == Win32.wAIT_OBJECT_0
 #else
-  Posix.semWait sem
+  Posix.semTryWait sem
 #endif
 
 -- | Try to obtain a token from the semaphore, without blocking.
@@ -140,18 +189,26 @@ waitOnSemaphore (Semaphore { semaphore = sem }) =
 tryWaitOnSemaphore :: Semaphore -> IO Bool
 tryWaitOnSemaphore (Semaphore { semaphore = sem }) =
 #if defined(mingw32_HOST_OS)
-  (== Win32.wAIT_OBJECT_0) <$> Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
+  MC.mask_ $ do
+    wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
+    return $ wait_res == Win32.wAIT_OBJECT_0
 #else
   Posix.semTryWait sem
 #endif
 
 -- | Release a semaphore: add @n@ to its internal counter.
+--
+-- No-op when `n <= 0`.
 releaseSemaphore :: Semaphore -> Int -> IO ()
-releaseSemaphore (Semaphore { semaphore = sem }) n =
+releaseSemaphore (Semaphore { semaphore = sem }) n
+  | n <= 0
+  = return ()
+  | otherwise
+  = MC.mask_ $ do
 #if defined(mingw32_HOST_OS)
-  void $ Win32.releaseSemaphore sem (fromIntegral n)
+    void $ Win32.releaseSemaphore sem (fromIntegral n)
 #else
-  replicateM_ n (Posix.semPost sem)
+    replicateM_ n (Posix.semPost sem)
 #endif
 
 -- | Destroy the given semaphore.
@@ -170,7 +227,7 @@ destroySemaphore sem =
 getSemaphoreValue :: Semaphore -> IO Int
 getSemaphoreValue (Semaphore { semaphore = sem }) =
 #if defined(mingw32_HOST_OS)
-  do
+  MC.mask_ $ do
     wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
     if wait_res == Win32.wAIT_OBJECT_0
       -- We were able to acquire a resource from the semaphore without waiting:
@@ -216,19 +273,20 @@ forkWaitOnSemaphoreInterruptible
 #if defined(mingw32_HOST_OS)
         -- Windows: wait on both the handle used for cancelling the wait
         -- and on the semaphore.
-        --
-        -- Only in the case that the wait result is WAIT_OBJECT_0 will
-        -- we have succeeded in obtaining a token from the semaphore.
-          (== Win32.wAIT_OBJECT_0) <$>
-            Win32.waitForMultipleObjects
-              [ Win32.semaphoreHandle sem
-              , cancelHandle ]
-              False -- False <=> WaitAny
-              Win32.iNFINITE
+          do
+            wait_res <-
+              Win32.waitForMultipleObjects
+                [ Win32.semaphoreHandle sem
+                , cancelHandle ]
+                False -- False <=> WaitAny
+                Win32.iNFINITE
+            return $ wait_res == Win32.wAIT_OBJECT_0
+            -- Only in the case that the wait result is WAIT_OBJECT_0 will
+            -- we have succeeded in obtaining a token from the semaphore.
 #else
         -- POSIX: use the 'semWaitInterruptible' interruptible FFI call
         -- that can be interrupted when we send a killThread signal.
-          Posix.semWaitInterruptible (semaphore sem)
+          Posix.semWaitInterruptible sem
 #endif
     waitingThreadId <- forkIO $ MC.mask_ $ do
       wait_res <- MC.try interruptible_wait
@@ -246,3 +304,49 @@ interruptWaitOnSemaphore ( WaitId { .. } ) = do
   killThread waitingThreadId
     -- On POSIX, killing the thread will cancel the wait on the semaphore
     -- due to the FFI call being interruptible ('semWaitInterruptible').
+
+---------------------------------------
+-- Abstract semaphores
+
+-- | Abstraction over the operations of a semaphore.
+data AbstractSem =
+  AbstractSem
+    { acquireSem :: IO ()
+    , releaseSem :: IO ()
+    }
+
+withAbstractSem :: AbstractSem -> IO b -> IO b
+withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
+
+---------------------------------------
+-- Utility
+
+iToBase62 :: Int -> String
+iToBase62 m = go m' ""
+  where
+    m'
+      | m == minBound
+      = maxBound
+      | otherwise
+      = abs m
+    go n cs | n < 62
+            = let !c = chooseChar62 n
+              in c : cs
+            | otherwise
+            = let !(!q, r) = quotRem n 62
+                  !c       = chooseChar62 r
+              in go q (c : cs)
+
+    chooseChar62 :: Int -> Char
+    {-# INLINE chooseChar62 #-}
+    chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)
+    chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
+
+random_strings :: IO (NonEmpty String)
+random_strings = do
+#if defined(mingw32_HOST_OS)
+  Win32.FILETIME t <- Win32.getSystemTimeAsFileTime
+#else
+  CClock t <- 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                         -



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c4a99346692b94c5a52c64f64e2bda9985f8801

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c4a99346692b94c5a52c64f64e2bda9985f8801
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/8b82344b/attachment-0001.html>


More information about the ghc-commits mailing list