[Git][ghc/ghc][wip/jsem] make semaphore-compat a submodule
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Fri Oct 28 11:34:26 UTC 2022
sheaf pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC
Commits:
37ab69cc by sheaf at 2022-10-28T13:33:48+02:00
make semaphore-compat a submodule
- - - - -
11 changed files:
- .gitmodules
- + libraries/semaphore-compat
- − 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
- − libraries/semaphore-compat/src/System/Semaphore.hs
Changes:
=====================================
.gitmodules
=====================================
@@ -85,7 +85,7 @@
branch = 2.7
[submodule "libraries/semaphore-compat"]
path = libraries/semaphore-compat
- url = https://gitlab.haskell.org/ghc/packages/semaphore-compat.git
+ url = git at gitlab.haskell.org:ghc/semaphore-compat.git
ignore = untracked
[submodule "libraries/stm"]
path = libraries/stm
=====================================
libraries/semaphore-compat
=====================================
@@ -0,0 +1 @@
+Subproject commit 663ef75467995acf41c51d3e21d03347e85b844e
=====================================
libraries/semaphore-compat/.gitignore deleted
=====================================
@@ -1,11 +0,0 @@
-/dist/
-/dist-boot/
-/dist-install/
-/dist-newstyle/
-/cabal.project.local
-/.cabal-sandbox/
-/cabal.sandbox.config
-/.ghc.environment.*
-*~
-ghc.mk
-GNUmakefile
=====================================
libraries/semaphore-compat/LICENSE deleted
=====================================
@@ -1,34 +0,0 @@
------------------------------------------------------------------------------
-
-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 deleted
=====================================
@@ -1,6 +0,0 @@
-module Main (main) where
-
-import Distribution.Simple
-
-main :: IO ()
-main = defaultMain
=====================================
libraries/semaphore-compat/cabal.haskell-ci deleted
=====================================
@@ -1 +0,0 @@
-branches: master
=====================================
libraries/semaphore-compat/cabal.project deleted
=====================================
@@ -1,4 +0,0 @@
-packages:
- .,
- ../unix,
- ../Win32
=====================================
libraries/semaphore-compat/changelog.md deleted
=====================================
@@ -1,3 +0,0 @@
-### 1.0.0 (October 27th, 2022)
-
-- First version of the `semaphore-compat` package.
=====================================
libraries/semaphore-compat/readme.md deleted
=====================================
@@ -1,16 +0,0 @@
-# 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 deleted
=====================================
@@ -1,61 +0,0 @@
-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
=====================================
libraries/semaphore-compat/src/System/Semaphore.hs deleted
=====================================
@@ -1,352 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeApplications #-}
-
-module System.Semaphore
- ( -- * System semaphores
- Semaphore(..), SemaphoreName(..)
- , createSemaphore, freshSemaphore, openSemaphore
- , waitOnSemaphore, tryWaitOnSemaphore
- , WaitId(..)
- , forkWaitOnSemaphoreInterruptible
- , interruptWaitOnSemaphore
- , getSemaphoreValue
- , releaseSemaphore
- , destroySemaphore
-
- -- * Abstract semaphores
- , AbstractSem(..)
- , withAbstractSem
- ) where
-
--- 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
- , 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.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
-
----------------------------------------
--- System-specific semaphores
-
-newtype SemaphoreName =
- SemaphoreName { getSemaphoreName :: String }
- deriving Eq
-
--- | A system 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 -- ^ 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
- 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 }
- 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
- where
- sem_nm = SemaphoreName sem_str
- mk_sem sem =
- Semaphore
- { semaphore = sem
- , semaphoreName = sem_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.
---
--- If you want to be able to cancel a wait operation, use
--- 'forkWaitOnSemaphoreInterruptible' instead.
-waitOnSemaphore :: Semaphore -> IO Bool
-waitOnSemaphore (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
- MC.mask_ $ do
- wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
- return $ wait_res == Win32.wAIT_OBJECT_0
-#else
- Posix.semTryWait 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)
- 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
- | n <= 0
- = return ()
- | otherwise
- = MC.mask_ $ do
-#if defined(mingw32_HOST_OS)
- void $ Win32.releaseSemaphore sem (fromIntegral n)
-#else
- replicateM_ n (Posix.semPost sem)
-#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).
---
--- This is mainly for debugging use, as it is easy to introduce race conditions
--- when nontrivial program logic depends on the value returned by this function.
-getSemaphoreValue :: Semaphore -> IO Int
-getSemaphoreValue (Semaphore { semaphore = sem }) =
-#if defined(mingw32_HOST_OS)
- 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:
- -- 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
-
--- | 'WaitId' stores the information we need to cancel a thread
--- which is waiting on a semaphore.
---
--- See 'forkWaitOnSemaphoreInterruptible' and 'interruptWaitOnSemaphore'.
-data WaitId = WaitId { waitingThreadId :: ThreadId
-#if defined(mingw32_HOST_OS)
- , cancelHandle :: Win32.HANDLE
-#endif
- }
-
--- | Spawn a thread that waits on the given semaphore.
---
--- In this thread, asynchronous exceptions will be masked.
---
--- The waiting operation can be interrupted using the
--- 'interruptWaitOnSemaphore' function.
-forkWaitOnSemaphoreInterruptible
- :: Semaphore
- -> ( Either MC.SomeException Bool -> IO () ) -- ^ wait result action
- -> IO WaitId
-forkWaitOnSemaphoreInterruptible
- (Semaphore { semaphore = sem })
- wait_result_action = do
-#if defined(mingw32_HOST_OS)
- cancelHandle <- Win32.createEvent Nothing True False ""
-#endif
- let
- interruptible_wait :: IO Bool
- interruptible_wait =
-#if defined(mingw32_HOST_OS)
- -- Windows: wait on both the handle used for cancelling the wait
- -- and on the semaphore.
- 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 sem
-#endif
- waitingThreadId <- forkIO $ MC.mask_ $ do
- wait_res <- MC.try interruptible_wait
- wait_result_action wait_res
- return $ WaitId { .. }
-
--- | Interrupt a semaphore wait operation initiated by
--- 'forkWaitOnSemaphoreInterruptible'.
-interruptWaitOnSemaphore :: WaitId -> IO ()
-interruptWaitOnSemaphore ( WaitId { .. } ) = do
-#if defined(mingw32_HOST_OS)
- Win32.setEvent cancelHandle
- -- On Windows, we signal to stop waiting.
-#endif
- killThread waitingThreadId
- -- On POSIX, killing the thread will cancel the wait on the semaphore
- -- due to the FFI call being interruptible ('semWaitInterruptible').
-
----------------------------------------
--- Abstract semaphores
-
--- | Abstraction over the operations of a semaphore.
-data AbstractSem =
- AbstractSem
- { acquireSem :: IO ()
- , releaseSem :: IO ()
- }
-
-withAbstractSem :: AbstractSem -> IO b -> IO b
-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-
----------------------------------------
--- Utility
-
-iToBase62 :: Int -> String
-iToBase62 m = go m' ""
- where
- m'
- | m == minBound
- = maxBound
- | otherwise
- = abs m
- go n cs | n < 62
- = let !c = chooseChar62 n
- in c : cs
- | otherwise
- = let !(!q, r) = quotRem n 62
- !c = chooseChar62 r
- in go q (c : cs)
-
- chooseChar62 :: Int -> Char
- {-# INLINE chooseChar62 #-}
- chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)
- chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
-
-random_strings :: IO (NonEmpty String)
-random_strings = do
-#if defined(mingw32_HOST_OS)
- Win32.FILETIME t <- Win32.getSystemTimeAsFileTime
-#else
- CClock t <- Posix.systemTime <$> Posix.getProcessTimes
-#endif
- return $ fmap ( \ i -> iToBase62 (i + fromIntegral t) ) (0 :| [1..])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37ab69ccf7d29f7e06019109b826b62965d0b387
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37ab69ccf7d29f7e06019109b826b62965d0b387
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/20221028/a1b7f05e/attachment-0001.html>
More information about the ghc-commits
mailing list