(original) (raw)

{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP , MagicHash , UnboxedTuples , ScopedTypeVariables , RankNTypes #-} {-# OPTIONS_GHC -Wno-deprecations #-}

module Control.Concurrent (

    [ThreadId](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#ThreadId),
    [myThreadId](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#myThreadId),

    [forkIO](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#forkIO),
    [forkFinally](Control.Concurrent.html#forkFinally),
    [forkIOWithUnmask](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#forkIOWithUnmask),
    [killThread](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#killThread),
    [throwTo](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#throwTo),

    
    [forkOn](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#forkOn),
    [forkOnWithUnmask](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#forkOnWithUnmask),
    [getNumCapabilities](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#getNumCapabilities),
    [setNumCapabilities](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#setNumCapabilities),
    [threadCapability](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#threadCapability),

    
    [yield](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#yield),

    
    [threadDelay](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.IO.html#threadDelay),
    [threadWaitRead](Control.Concurrent.html#threadWaitRead),
    [threadWaitWrite](Control.Concurrent.html#threadWaitWrite),
    [threadWaitReadSTM](Control.Concurrent.html#threadWaitReadSTM),
    [threadWaitWriteSTM](Control.Concurrent.html#threadWaitWriteSTM),
    

    module [GHC.Internal.Control.Concurrent.MVar](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Control.Concurrent.MVar.html),
    module [Control.Concurrent.Chan](Control.Concurrent.Chan.html),
    module [Control.Concurrent.QSem](Control.Concurrent.QSem.html),
    module [Control.Concurrent.QSemN](Control.Concurrent.QSemN.html),
    
    
    [rtsSupportsBoundThreads](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Bound.html#rtsSupportsBoundThreads),
    [forkOS](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Bound.html#forkOS),
    [forkOSWithUnmask](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Bound.html#forkOSWithUnmask),
    [isCurrentThreadBound](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Bound.html#isCurrentThreadBound),
    [runInBoundThread](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Bound.html#runInBoundThread),
    [runInUnboundThread](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Bound.html#runInUnboundThread),

    
    [mkWeakThreadId](/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html#mkWeakThreadId),
    

) where

import Prelude import GHC.Internal.Control.Exception.Base as Exception

import GHC.Internal.Conc.Bound import GHC.Conc hiding (threadWaitRead, threadWaitWrite, threadWaitReadSTM, threadWaitWriteSTM)

import GHC.Internal.System.Posix.Types ( Fd )

#if defined(mingw32_HOST_OS) import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types import GHC.Internal.System.IO import GHC.Internal.Data.Functor ( void ) import GHC.Internal.Int ( Int64 ) #else import qualified GHC.Internal.Conc.IO as Conc #endif

import GHC.Internal.Control.Concurrent.MVar import Control.Concurrent.Chan import Control.Concurrent.QSem import Control.Concurrent.QSemN

forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkFinally :: forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkFinally IO a action Either SomeException a -> IO () and_then = ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b mask (((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId) -> ((forall a. IO a -> IO a) -> IO ThreadId) -> IO ThreadId forall a b. (a -> b) -> a -> b $ \forall a. IO a -> IO a restore -> IO () -> IO ThreadId forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId forall a b. (a -> b) -> a -> b $ IO a -> IO (Either SomeException a) forall e a. Exception e => IO a -> IO (Either e a) try (IO a -> IO a forall a. IO a -> IO a restore IO a action) IO (Either SomeException a) -> (Either SomeException a -> IO ()) -> IO () forall a b. IO a -> (a -> IO b) -> IO b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Either SomeException a -> IO () and_then

threadWaitRead :: Fd -> IO () threadWaitRead :: Fd -> IO () threadWaitRead Fd fd #if defined(mingw32_HOST_OS)

| threaded = withThread (waitFd fd False) | otherwise = case fd of 0 -> do _ <- hWaitForInput stdin (-1) return ()

              _ -> errorWithoutStackTrace "threadWaitRead requires -threaded on Windows, or use GHC.System.IO.hWaitForInput"

#else = Fd -> IO () Conc.threadWaitRead Fd fd #endif

threadWaitWrite :: Fd -> IO () threadWaitWrite :: Fd -> IO () threadWaitWrite Fd fd #if defined(mingw32_HOST_OS) | threaded = withThread (waitFd fd True) | otherwise = errorWithoutStackTrace "threadWaitWrite requires -threaded on Windows" #else = Fd -> IO () Conc.threadWaitWrite Fd fd #endif

threadWaitReadSTM :: Fd -> IO (STM (), IO ()) threadWaitReadSTM :: Fd -> IO (STM (), IO ()) threadWaitReadSTM Fd fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing mask_ $ void $ forkIO $ do result <- try (waitFd fd False) atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of Nothing -> retry Just (Right ()) -> return () Just (Left e) -> throwSTM (e :: IOException) let killAction = return () return (waitAction, killAction) | otherwise = errorWithoutStackTrace "threadWaitReadSTM requires -threaded on Windows" #else = Fd -> IO (STM (), IO ()) Conc.threadWaitReadSTM Fd fd #endif

threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) threadWaitWriteSTM :: Fd -> IO (STM (), IO ()) threadWaitWriteSTM Fd fd #if defined(mingw32_HOST_OS) | threaded = do v <- newTVarIO Nothing mask_ $ void $ forkIO $ do result <- try (waitFd fd True) atomically (writeTVar v $ Just result) let waitAction = do result <- readTVar v case result of Nothing -> retry Just (Right ()) -> return () Just (Left e) -> throwSTM (e :: IOException) let killAction = return () return (waitAction, killAction) | otherwise = errorWithoutStackTrace "threadWaitWriteSTM requires -threaded on Windows" #else = Fd -> IO (STM (), IO ()) Conc.threadWaitWriteSTM Fd fd #endif

#if defined(mingw32_HOST_OS) foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool

withThread :: IO a -> IO a withThread io = do m <- newEmptyMVar _ <- mask_ $ forkIO $ try io >>= putMVar m x <- takeMVar m case x of Right a -> return a Left e -> throwIO (e :: IOException)

waitFd :: Fd -> Bool -> IO () waitFd fd write = do throwErrnoIfMinus1_ "fdReady" $ fdReady (fromIntegral fd) (if write then 1 else 0) (-1) 0

foreign import ccall safe "fdReady" fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt #endif