[Git][ghc/ghc][wip/jsem] Add GHC.Utils.IO.Semaphore
Douglas Wilson (@duog)
gitlab at gitlab.haskell.org
Wed Sep 14 12:40:33 UTC 2022
Douglas Wilson pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC
Commits:
f0faa270 by Douglas Wilson at 2022-09-14T13:39:56+01:00
Add GHC.Utils.IO.Semaphore
- - - - -
3 changed files:
- compiler/GHC/Driver/MakeSem.hs
- + compiler/GHC/Utils/IO/Semaphore.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
@@ -7,16 +6,13 @@
--
--
module GHC.Driver.MakeSem
- ( -- * Abstract semaphores
- AbstractSem(..)
- , withAbstractSem
-
- -- * System semaphores
- , Semaphore, SemaphoreName(..)
-
- -- * JSem: parallelism semaphore backed
+ ( -- * JSem: parallelism semaphore backed
-- by a system semaphore (Posix/Windows)
- , runJSemAbstractSem
+ runJSemAbstractSem
+
+ , SemaphoreName(..)
+ -- * Abstract semaphores
+ , AbstractSem(..), withAbstractSem
)
where
@@ -24,6 +20,7 @@ import GHC.Prelude
import GHC.Conc
import GHC.Data.OrdList
import GHC.IO.Exception
+import GHC.Utils.IO.Semaphore
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Trace
@@ -35,88 +32,10 @@ import Control.Concurrent.STM
import Data.Foldable
import Data.Functor
-#if defined(mingw32_HOST_OS)
-import qualified System.Win32.Event as Win32
- ( waitForSingleObject )
-import qualified System.Win32.Process as Win32
- ( iNFINITE )
-import qualified System.Win32.Semaphore as Win32
- ( Semaphore(..), sEMAPHORE_ALL_ACCESS
- , openSemaphore, releaseSemaphore )
-#else
-import qualified System.Posix.Semaphore as Posix
- ( Semaphore, OpenSemFlags(..)
- , semOpen, semWait, semPost, semGetValue )
-import qualified System.Posix.Files as Posix
- ( stdFileMode )
-#endif
-
---------------------------------------
-- Abstract semaphores
--- | Abstraction over the operations of a semaphore,
--- allowing usage with -jN or a jobserver.
-data AbstractSem = AbstractSem { acquireSem :: IO ()
- , releaseSem :: IO ()
- }
-
-withAbstractSem :: AbstractSem -> IO b -> IO b
-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-
----------------------------------------
--- System-specific semaphores
-
-type Semaphore =
-#if defined(mingw32_HOST_OS)
- Win32.Semaphore
-#else
- Posix.Semaphore
-#endif
-
--- | The name of a 'Semaphore'.
-newtype SemaphoreName = SemaphoreName FilePath
- deriving Eq
--- | Open a semaphore with the given name.
---
--- If no such semaphore exists, throws an error.
-openSemaphore :: String -- ^ semaphore name
- -> IO Semaphore
-openSemaphore sem_name =
-#if defined(mingw32_HOST_OS)
- Win32.openSemaphore Win32.sEMAPHORE_ALL_ACCESS True sem_name
-#else
- Posix.semOpen sem_name flags Posix.stdFileMode 0
- where
- flags = Posix.OpenSemFlags
- { Posix.semCreate = False
- , Posix.semExclusive = False }
-#endif
-
--- | Indefinitely wait on a semaphore.
-waitOnSemaphore :: Semaphore -> IO ()
-waitOnSemaphore sem =
-#if defined(mingw32_HOST_OS)
- void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
-#else
- Posix.semWait sem
-#endif
-
--- | Release a semaphore: add @n@ to its internal counter,
--- and return the semaphore's count before the operation.
---
--- NB: the returned value should only be used for debugging,
--- not for the main jobserver logic.
-releaseSemaphore :: Semaphore -> Int -> IO Int
-releaseSemaphore sem n =
-#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
---------------------------------------
-- Semaphore jobserver
=====================================
compiler/GHC/Utils/IO/Semaphore.hs
=====================================
@@ -0,0 +1,96 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Utils.IO.Semaphore
+ ( -- * System semaphores
+ Semaphore, SemaphoreName(..)
+ , openSemaphore, waitOnSemaphore, releaseSemaphore
+
+ -- * Abstract semaphores
+ , AbstractSem(..)
+ , withAbstractSem
+ ) where
+
+import GHC.Prelude
+import Control.Monad
+
+import qualified Control.Monad.Catch as MC
+
+#if defined(mingw32_HOST_OS)
+import qualified System.Win32.Event as Win32
+ ( waitForSingleObject )
+import qualified System.Win32.Process as Win32
+ ( iNFINITE )
+import qualified System.Win32.Semaphore as Win32
+ ( Semaphore(..), sEMAPHORE_ALL_ACCESS
+ , openSemaphore, releaseSemaphore )
+#else
+import qualified System.Posix.Semaphore as Posix
+ ( Semaphore, OpenSemFlags(..)
+ , semOpen, semWait, semPost, semGetValue )
+import qualified System.Posix.Files as Posix
+ ( stdFileMode )
+#endif
+
+---------------------------------------
+-- System-specific semaphores
+
+type Semaphore =
+#if defined(mingw32_HOST_OS)
+ Win32.Semaphore
+#else
+ Posix.Semaphore
+#endif
+
+-- | The name of a 'Semaphore'.
+newtype SemaphoreName = SemaphoreName FilePath
+ deriving Eq
+
+-- | Open a semaphore with the given name.
+--
+-- If no such semaphore exists, throws an error.
+openSemaphore :: String -- ^ semaphore name
+ -> IO Semaphore
+openSemaphore sem_name =
+#if defined(mingw32_HOST_OS)
+ Win32.openSemaphore Win32.sEMAPHORE_ALL_ACCESS True sem_name
+#else
+ Posix.semOpen sem_name flags Posix.stdFileMode 0
+ where
+ flags = Posix.OpenSemFlags
+ { Posix.semCreate = False
+ , Posix.semExclusive = False }
+#endif
+
+-- | Indefinitely wait on a semaphore.
+waitOnSemaphore :: Semaphore -> IO ()
+waitOnSemaphore sem =
+#if defined(mingw32_HOST_OS)
+ void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
+#else
+ Posix.semWait sem
+#endif
+
+-- | Release a semaphore: add @n@ to its internal counter,
+-- and return the semaphore's count before the operation.
+--
+-- NB: the returned value should only be used for debugging,
+-- not for the main jobserver logic.
+releaseSemaphore :: Semaphore -> Int -> IO Int
+releaseSemaphore sem n =
+#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
+
+-- | 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)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -789,6 +789,7 @@ Library
GHC.Utils.FV
GHC.Utils.GlobalVars
GHC.Utils.IO.Unsafe
+ GHC.Utils.IO.Semaphore
GHC.Utils.Json
GHC.Utils.Lexeme
GHC.Utils.Logger
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0faa2703d87d2c97f94acab2a93ebc3bf038a78
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0faa2703d87d2c97f94acab2a93ebc3bf038a78
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220914/9d297a9f/attachment-0001.html>
More information about the ghc-commits
mailing list