+++ /dev/null
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- A common interface to a collection of useful concurrency
--- abstractions.
---
------------------------------------------------------------------------------
-
-module Control.Concurrent (
- -- * Concurrent Haskell
-
- -- $conc_intro
-
- -- * Basic concurrency operations
-
- ThreadId,
-#ifdef __GLASGOW_HASKELL__
- myThreadId,
-#endif
-
- forkIO,
-#ifdef __GLASGOW_HASKELL__
- killThread,
- throwTo,
-#endif
-
- -- * Scheduling
-
- -- $conc_scheduling
- yield, -- :: IO ()
-
- -- ** Blocking
-
- -- $blocking
-
-#ifdef __GLASGOW_HASKELL__
- -- ** Waiting
- threadDelay, -- :: Int -> IO ()
- threadWaitRead, -- :: Int -> IO ()
- threadWaitWrite, -- :: Int -> IO ()
-#endif
-
- -- * Communication abstractions
-
- module Control.Concurrent.MVar,
- module Control.Concurrent.Chan,
- module Control.Concurrent.QSem,
- module Control.Concurrent.QSemN,
- module Control.Concurrent.SampleVar,
-
- -- * Merging of streams
-#ifndef __HUGS__
- mergeIO, -- :: [a] -> [a] -> IO [a]
- nmergeIO, -- :: [[a]] -> IO [a]
-#endif
- -- $merge
-
-#ifdef __GLASGOW_HASKELL__
- -- * Bound Threads
- -- $boundthreads
- rtsSupportsBoundThreads,
- forkOS,
- isCurrentThreadBound,
- runInBoundThread,
- runInUnboundThread
-#endif
-
- -- * GHC's implementation of concurrency
-
- -- |This section describes features specific to GHC's
- -- implementation of Concurrent Haskell.
-
- -- ** Haskell threads and Operating System threads
-
- -- $osthreads
-
- -- ** Terminating the program
-
- -- $termination
-
- -- ** Pre-emption
-
- -- $preemption
- ) where
-
-import Prelude
-
-import Control.Exception.Base as Exception
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Exception
-import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield,
- threadDelay, forkIO, childHandler )
-import qualified GHC.Conc
-import GHC.IOBase ( IO(..) )
-import GHC.IOBase ( unsafeInterleaveIO )
-import GHC.IOBase ( newIORef, readIORef, writeIORef )
-import GHC.Base
-
-import System.Posix.Types ( Fd )
-import Foreign.StablePtr
-import Foreign.C.Types ( CInt )
-import Control.Monad ( when )
-
-#ifdef mingw32_HOST_OS
-import Foreign.C
-import System.IO
-import GHC.Handle
-#endif
-#endif
-
-#ifdef __HUGS__
-import Hugs.ConcBase
-#endif
-
-import Control.Concurrent.MVar
-import Control.Concurrent.Chan
-import Control.Concurrent.QSem
-import Control.Concurrent.QSemN
-import Control.Concurrent.SampleVar
-
-#ifdef __HUGS__
-type ThreadId = ()
-#endif
-
-{- $conc_intro
-
-The concurrency extension for Haskell is described in the paper
-/Concurrent Haskell/
-<http://www.haskell.org/ghc/docs/papers/concurrent-haskell.ps.gz>.
-
-Concurrency is \"lightweight\", which means that both thread creation
-and context switching overheads are extremely low. Scheduling of
-Haskell threads is done internally in the Haskell runtime system, and
-doesn't make use of any operating system-supplied thread packages.
-
-However, if you want to interact with a foreign library that expects your
-program to use the operating system-supplied thread package, you can do so
-by using 'forkOS' instead of 'forkIO'.
-
-Haskell threads can communicate via 'MVar's, a kind of synchronised
-mutable variable (see "Control.Concurrent.MVar"). Several common
-concurrency abstractions can be built from 'MVar's, and these are
-provided by the "Control.Concurrent" library.
-In GHC, threads may also communicate via exceptions.
--}
-
-{- $conc_scheduling
-
- Scheduling may be either pre-emptive or co-operative,
- depending on the implementation of Concurrent Haskell (see below
- for information related to specific compilers). In a co-operative
- system, context switches only occur when you use one of the
- primitives defined in this module. This means that programs such
- as:
-
-
-> main = forkIO (write 'a') >> write 'b'
-> where write c = putChar c >> write c
-
- will print either @aaaaaaaaaaaaaa...@ or @bbbbbbbbbbbb...@,
- instead of some random interleaving of @a@s and @b@s. In
- practice, cooperative multitasking is sufficient for writing
- simple graphical user interfaces.
--}
-
-{- $blocking
-Different Haskell implementations have different characteristics with
-regard to which operations block /all/ threads.
-
-Using GHC without the @-threaded@ option, all foreign calls will block
-all other Haskell threads in the system, although I\/O operations will
-not. With the @-threaded@ option, only foreign calls with the @unsafe@
-attribute will block all other threads.
-
-Using Hugs, all I\/O operations and foreign calls will block all other
-Haskell threads.
--}
-
-#ifndef __HUGS__
-max_buff_size :: Int
-max_buff_size = 1
-
-mergeIO :: [a] -> [a] -> IO [a]
-nmergeIO :: [[a]] -> IO [a]
-
--- $merge
--- The 'mergeIO' and 'nmergeIO' functions fork one thread for each
--- input list that concurrently evaluates that list; the results are
--- merged into a single output list.
---
--- Note: Hugs does not provide these functions, since they require
--- preemptive multitasking.
-
-mergeIO ls rs
- = newEmptyMVar >>= \ tail_node ->
- newMVar tail_node >>= \ tail_list ->
- newQSem max_buff_size >>= \ e ->
- newMVar 2 >>= \ branches_running ->
- let
- buff = (tail_list,e)
- in
- forkIO (suckIO branches_running buff ls) >>
- forkIO (suckIO branches_running buff rs) >>
- takeMVar tail_node >>= \ val ->
- signalQSem e >>
- return val
-
-type Buffer a
- = (MVar (MVar [a]), QSem)
-
-suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
-
-suckIO branches_running buff@(tail_list,e) vs
- = case vs of
- [] -> takeMVar branches_running >>= \ val ->
- if val == 1 then
- takeMVar tail_list >>= \ node ->
- putMVar node [] >>
- putMVar tail_list node
- else
- putMVar branches_running (val-1)
- (x:xs) ->
- waitQSem e >>
- takeMVar tail_list >>= \ node ->
- newEmptyMVar >>= \ next_node ->
- unsafeInterleaveIO (
- takeMVar next_node >>= \ y ->
- signalQSem e >>
- return y) >>= \ next_node_val ->
- putMVar node (x:next_node_val) >>
- putMVar tail_list next_node >>
- suckIO branches_running buff xs
-
-nmergeIO lss
- = let
- len = length lss
- in
- newEmptyMVar >>= \ tail_node ->
- newMVar tail_node >>= \ tail_list ->
- newQSem max_buff_size >>= \ e ->
- newMVar len >>= \ branches_running ->
- let
- buff = (tail_list,e)
- in
- mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
- takeMVar tail_node >>= \ val ->
- signalQSem e >>
- return val
- where
- mapIO f xs = sequence (map f xs)
-#endif /* __HUGS__ */
-
-#ifdef __GLASGOW_HASKELL__
--- ---------------------------------------------------------------------------
--- Bound Threads
-
-{- $boundthreads
- #boundthreads#
-
-Support for multiple operating system threads and bound threads as described
-below is currently only available in the GHC runtime system if you use the
-/-threaded/ option when linking.
-
-Other Haskell systems do not currently support multiple operating system threads.
-
-A bound thread is a haskell thread that is /bound/ to an operating system
-thread. While the bound thread is still scheduled by the Haskell run-time
-system, the operating system thread takes care of all the foreign calls made
-by the bound thread.
-
-To a foreign library, the bound thread will look exactly like an ordinary
-operating system thread created using OS functions like @pthread_create@
-or @CreateThread@.
-
-Bound threads can be created using the 'forkOS' function below. All foreign
-exported functions are run in a bound thread (bound to the OS thread that
-called the function). Also, the @main@ action of every Haskell program is
-run in a bound thread.
-
-Why do we need this? Because if a foreign library is called from a thread
-created using 'forkIO', it won't have access to any /thread-local state/ -
-state variables that have specific values for each OS thread
-(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some
-libraries (OpenGL, for example) will not work from a thread created using
-'forkIO'. They work fine in threads created using 'forkOS' or when called
-from @main@ or from a @foreign export@.
-
-In terms of performance, 'forkOS' (aka bound) threads are much more
-expensive than 'forkIO' (aka unbound) threads, because a 'forkOS'
-thread is tied to a particular OS thread, whereas a 'forkIO' thread
-can be run by any OS thread. Context-switching between a 'forkOS'
-thread and a 'forkIO' thread is many times more expensive than between
-two 'forkIO' threads.
-
-Note in particular that the main program thread (the thread running
-@Main.main@) is always a bound thread, so for good concurrency
-performance you should ensure that the main thread is not doing
-repeated communication with other threads in the system. Typically
-this means forking subthreads to do the work using 'forkIO', and
-waiting for the results in the main thread.
-
--}
-
--- | 'True' if bound threads are supported.
--- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
--- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
--- fail.
-foreign import ccall rtsSupportsBoundThreads :: Bool
-
-
-{- |
-Like 'forkIO', this sparks off a new thread to run the 'IO'
-computation passed as the first argument, and returns the 'ThreadId'
-of the newly created thread.
-
-However, 'forkOS' creates a /bound/ thread, which is necessary if you
-need to call foreign (non-Haskell) libraries that make use of
-thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads").
-
-Using 'forkOS' instead of 'forkIO' makes no difference at all to the
-scheduling behaviour of the Haskell runtime system. It is a common
-misconception that you need to use 'forkOS' instead of 'forkIO' to
-avoid blocking all the Haskell threads when making a foreign call;
-this isn't the case. To allow foreign calls to be made without
-blocking all the Haskell threads (with GHC), it is only necessary to
-use the @-threaded@ option when linking your program, and to make sure
-the foreign import is not marked @unsafe@.
--}
-
-forkOS :: IO () -> IO ThreadId
-
-foreign export ccall forkOS_entry
- :: StablePtr (IO ()) -> IO ()
-
-foreign import ccall "forkOS_entry" forkOS_entry_reimported
- :: StablePtr (IO ()) -> IO ()
-
-forkOS_entry :: StablePtr (IO ()) -> IO ()
-forkOS_entry stableAction = do
- action <- deRefStablePtr stableAction
- action
-
-foreign import ccall forkOS_createThread
- :: StablePtr (IO ()) -> IO CInt
-
-failNonThreaded :: IO a
-failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
- ++"(use ghc -threaded when linking)"
-
-forkOS action0
- | rtsSupportsBoundThreads = do
- mv <- newEmptyMVar
- b <- Exception.blocked
- let
- -- async exceptions are blocked in the child if they are blocked
- -- in the parent, as for forkIO (see #1048). forkOS_createThread
- -- creates a thread with exceptions blocked by default.
- action1 | b = action0
- | otherwise = unblock action0
-
- action_plus = Exception.catch action1 childHandler
-
- entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
- err <- forkOS_createThread entry
- when (err /= 0) $ fail "Cannot create OS thread."
- tid <- takeMVar mv
- freeStablePtr entry
- return tid
- | otherwise = failNonThreaded
-
--- | Returns 'True' if the calling thread is /bound/, that is, if it is
--- safe to use foreign libraries that rely on thread-local state from the
--- calling thread.
-isCurrentThreadBound :: IO Bool
-isCurrentThreadBound = IO $ \ s# ->
- case isCurrentThreadBound# s# of
- (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
-
-
-{- |
-Run the 'IO' computation passed as the first argument. If the calling thread
-is not /bound/, a bound thread is created temporarily. @runInBoundThread@
-doesn't finish until the 'IO' computation finishes.
-
-You can wrap a series of foreign function calls that rely on thread-local state
-with @runInBoundThread@ so that you can use them without knowing whether the
-current thread is /bound/.
--}
-runInBoundThread :: IO a -> IO a
-
-runInBoundThread action
- | rtsSupportsBoundThreads = do
- bound <- isCurrentThreadBound
- if bound
- then action
- else do
- ref <- newIORef undefined
- let action_plus = Exception.try action >>= writeIORef ref
- resultOrException <-
- bracket (newStablePtr action_plus)
- freeStablePtr
- (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref)
- case resultOrException of
- Left exception -> Exception.throw (exception :: SomeException)
- Right result -> return result
- | otherwise = failNonThreaded
-
-{- |
-Run the 'IO' computation passed as the first argument. If the calling thread
-is /bound/, an unbound thread is created temporarily using 'forkIO'.
-@runInBoundThread@ doesn't finish until the 'IO' computation finishes.
-
-Use this function /only/ in the rare case that you have actually observed a
-performance loss due to the use of bound threads. A program that
-doesn't need it's main thread to be bound and makes /heavy/ use of concurrency
-(e.g. a web server), might want to wrap it's @main@ action in
-@runInUnboundThread@.
--}
-runInUnboundThread :: IO a -> IO a
-
-runInUnboundThread action = do
- bound <- isCurrentThreadBound
- if bound
- then do
- mv <- newEmptyMVar
- forkIO (Exception.try action >>= putMVar mv)
- takeMVar mv >>= \ei -> case ei of
- Left exception -> Exception.throw (exception :: SomeException)
- Right result -> return result
- else action
-
-#endif /* __GLASGOW_HASKELL__ */
-
-#ifdef __GLASGOW_HASKELL__
--- ---------------------------------------------------------------------------
--- threadWaitRead/threadWaitWrite
-
--- | Block the current thread until data is available to read on the
--- given file descriptor (GHC only).
-threadWaitRead :: Fd -> IO ()
-threadWaitRead fd
-#ifdef mingw32_HOST_OS
- -- we have no IO manager implementing threadWaitRead on Windows.
- -- fdReady does the right thing, but we have to call it in a
- -- separate thread, otherwise threadWaitRead won't be interruptible,
- -- and this only works with -threaded.
- | threaded = withThread (waitFd fd 0)
- | otherwise = case fd of
- 0 -> do hWaitForInput stdin (-1); return ()
- -- hWaitForInput does work properly, but we can only
- -- do this for stdin since we know its FD.
- _ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput"
-#else
- = GHC.Conc.threadWaitRead fd
-#endif
-
--- | Block the current thread until data can be written to the
--- given file descriptor (GHC only).
-threadWaitWrite :: Fd -> IO ()
-threadWaitWrite fd
-#ifdef mingw32_HOST_OS
- | threaded = withThread (waitFd fd 1)
- | otherwise = error "threadWaitWrite requires -threaded on Windows"
-#else
- = GHC.Conc.threadWaitWrite fd
-#endif
-
-#ifdef mingw32_HOST_OS
-foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
-
-withThread :: IO a -> IO a
-withThread io = do
- m <- newEmptyMVar
- forkIO $ try io >>= putMVar m
- x <- takeMVar m
- case x of
- Right a -> return a
- Left e -> throwIO (e :: IOException)
-
-waitFd :: Fd -> CInt -> IO ()
-waitFd fd write = do
- throwErrnoIfMinus1 "fdReady" $
- fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0
- return ()
-
-iNFINITE :: CInt
-iNFINITE = 0xFFFFFFFF -- urgh
-
-foreign import ccall safe "fdReady"
- fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
-#endif
-
--- ---------------------------------------------------------------------------
--- More docs
-
-{- $osthreads
-
- #osthreads# In GHC, threads created by 'forkIO' are lightweight threads, and
- are managed entirely by the GHC runtime. Typically Haskell
- threads are an order of magnitude or two more efficient (in
- terms of both time and space) than operating system threads.
-
- The downside of having lightweight threads is that only one can
- run at a time, so if one thread blocks in a foreign call, for
- example, the other threads cannot continue. The GHC runtime
- works around this by making use of full OS threads where
- necessary. When the program is built with the @-threaded@
- option (to link against the multithreaded version of the
- runtime), a thread making a @safe@ foreign call will not block
- the other threads in the system; another OS thread will take
- over running Haskell threads until the original call returns.
- The runtime maintains a pool of these /worker/ threads so that
- multiple Haskell threads can be involved in external calls
- simultaneously.
-
- The "System.IO" library manages multiplexing in its own way. On
- Windows systems it uses @safe@ foreign calls to ensure that
- threads doing I\/O operations don't block the whole runtime,
- whereas on Unix systems all the currently blocked I\/O reqwests
- are managed by a single thread (the /IO manager thread/) using
- @select@.
-
- The runtime will run a Haskell thread using any of the available
- worker OS threads. If you need control over which particular OS
- thread is used to run a given Haskell thread, perhaps because
- you need to call a foreign library that uses OS-thread-local
- state, then you need bound threads (see "Control.Concurrent#boundthreads").
-
- If you don't use the @-threaded@ option, then the runtime does
- not make use of multiple OS threads. Foreign calls will block
- all other running Haskell threads until the call returns. The
- "System.IO" library still does multiplexing, so there can be multiple
- threads doing I\/O, and this is handled internally by the runtime using
- @select@.
--}
-
-{- $termination
-
- In a standalone GHC program, only the main thread is
- required to terminate in order for the process to terminate.
- Thus all other forked threads will simply terminate at the same
- time as the main thread (the terminology for this kind of
- behaviour is \"daemonic threads\").
-
- If you want the program to wait for child threads to
- finish before exiting, you need to program this yourself. A
- simple mechanism is to have each child thread write to an
- 'MVar' when it completes, and have the main
- thread wait on all the 'MVar's before
- exiting:
-
-> myForkIO :: IO () -> IO (MVar ())
-> myForkIO io = do
-> mvar <- newEmptyMVar
-> forkIO (io `finally` putMVar mvar ())
-> return mvar
-
- Note that we use 'finally' from the
- "Control.Exception" module to make sure that the
- 'MVar' is written to even if the thread dies or
- is killed for some reason.
-
- A better method is to keep a global list of all child
- threads which we should wait for at the end of the program:
-
-> children :: MVar [MVar ()]
-> children = unsafePerformIO (newMVar [])
->
-> waitForChildren :: IO ()
-> waitForChildren = do
-> cs <- takeMVar children
-> case cs of
-> [] -> return ()
-> m:ms -> do
-> putMVar children ms
-> takeMVar m
-> waitForChildren
->
-> forkChild :: IO () -> IO ThreadId
-> forkChild io = do
-> mvar <- newEmptyMVar
-> childs <- takeMVar children
-> putMVar children (mvar:childs)
-> forkIO (io `finally` putMVar mvar ())
->
-> main =
-> later waitForChildren $
-> ...
-
- The main thread principle also applies to calls to Haskell from
- outside, using @foreign export@. When the @foreign export@ed
- function is invoked, it starts a new main thread, and it returns
- when this main thread terminates. If the call causes new
- threads to be forked, they may remain in the system after the
- @foreign export@ed function has returned.
--}
-
-{- $preemption
-
- GHC implements pre-emptive multitasking: the execution of
- threads are interleaved in a random fashion. More specifically,
- a thread may be pre-empted whenever it allocates some memory,
- which unfortunately means that tight loops which do no
- allocation tend to lock out other threads (this only seems to
- happen with pathological benchmark-style code, however).
-
- The rescheduling timer runs on a 20ms granularity by
- default, but this may be altered using the
- @-i\<n\>@ RTS option. After a rescheduling
- \"tick\" the running thread is pre-empted as soon as
- possible.
-
- One final note: the
- @aaaa@ @bbbb@ example may not
- work too well on GHC (see Scheduling, above), due
- to the locking on a 'System.IO.Handle'. Only one thread
- may hold the lock on a 'System.IO.Handle' at any one
- time, so if a reschedule happens while a thread is holding the
- lock, the other thread won't be able to run. The upshot is that
- the switch from @aaaa@ to
- @bbbbb@ happens infrequently. It can be
- improved by lowering the reschedule tick period. We also have a
- patch that causes a reschedule whenever a thread waiting on a
- lock is woken up, but haven't found it to be useful for anything
- other than this example :-)
--}
-#endif /* __GLASGOW_HASKELL__ */
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.Chan
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Unbounded channels.
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.Chan
- (
- -- * The 'Chan' type
- Chan, -- abstract
-
- -- * Operations
- newChan, -- :: IO (Chan a)
- writeChan, -- :: Chan a -> a -> IO ()
- readChan, -- :: Chan a -> IO a
- dupChan, -- :: Chan a -> IO (Chan a)
- unGetChan, -- :: Chan a -> a -> IO ()
- isEmptyChan, -- :: Chan a -> IO Bool
-
- -- * Stream interface
- getChanContents, -- :: Chan a -> IO [a]
- writeList2Chan, -- :: Chan a -> [a] -> IO ()
- ) where
-
-import Prelude
-
-import System.IO.Unsafe ( unsafeInterleaveIO )
-import Control.Concurrent.MVar
-import Data.Typeable
-
-#include "Typeable.h"
-
--- A channel is represented by two @MVar@s keeping track of the two ends
--- of the channel contents,i.e., the read- and write ends. Empty @MVar@s
--- are used to handle consumers trying to read from an empty channel.
-
--- |'Chan' is an abstract type representing an unbounded FIFO channel.
-data Chan a
- = Chan (MVar (Stream a))
- (MVar (Stream a))
-
-INSTANCE_TYPEABLE1(Chan,chanTc,"Chan")
-
-type Stream a = MVar (ChItem a)
-
-data ChItem a = ChItem a (Stream a)
-
--- See the Concurrent Haskell paper for a diagram explaining the
--- how the different channel operations proceed.
-
--- @newChan@ sets up the read and write end of a channel by initialising
--- these two @MVar@s with an empty @MVar@.
-
--- |Build and returns a new instance of 'Chan'.
-newChan :: IO (Chan a)
-newChan = do
- hole <- newEmptyMVar
- readVar <- newMVar hole
- writeVar <- newMVar hole
- return (Chan readVar writeVar)
-
--- To put an element on a channel, a new hole at the write end is created.
--- What was previously the empty @MVar@ at the back of the channel is then
--- filled in with a new stream element holding the entered value and the
--- new hole.
-
--- |Write a value to a 'Chan'.
-writeChan :: Chan a -> a -> IO ()
-writeChan (Chan _ writeVar) val = do
- new_hole <- newEmptyMVar
- modifyMVar_ writeVar $ \old_hole -> do
- putMVar old_hole (ChItem val new_hole)
- return new_hole
-
--- |Read the next value from the 'Chan'.
-readChan :: Chan a -> IO a
-readChan (Chan readVar _) = do
- modifyMVar readVar $ \read_end -> do
- (ChItem val new_read_end) <- readMVar read_end
- -- Use readMVar here, not takeMVar,
- -- else dupChan doesn't work
- return (new_read_end, val)
-
--- |Duplicate a 'Chan': the duplicate channel begins empty, but data written to
--- either channel from then on will be available from both. Hence this creates
--- a kind of broadcast channel, where data written by anyone is seen by
--- everyone else.
-dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan _ writeVar) = do
- hole <- readMVar writeVar
- newReadVar <- newMVar hole
- return (Chan newReadVar writeVar)
-
--- |Put a data item back onto a channel, where it will be the next item read.
-unGetChan :: Chan a -> a -> IO ()
-unGetChan (Chan readVar _) val = do
- new_read_end <- newEmptyMVar
- modifyMVar_ readVar $ \read_end -> do
- putMVar new_read_end (ChItem val read_end)
- return new_read_end
-
--- |Returns 'True' if the supplied 'Chan' is empty.
-isEmptyChan :: Chan a -> IO Bool
-isEmptyChan (Chan readVar writeVar) = do
- withMVar readVar $ \r -> do
- w <- readMVar writeVar
- let eq = r == w
- eq `seq` return eq
-
--- Operators for interfacing with functional streams.
-
--- |Return a lazy list representing the contents of the supplied
--- 'Chan', much like 'System.IO.hGetContents'.
-getChanContents :: Chan a -> IO [a]
-getChanContents ch
- = unsafeInterleaveIO (do
- x <- readChan ch
- xs <- getChanContents ch
- return (x:xs)
- )
-
--- |Write an entire list of items to a 'Chan'.
-writeList2Chan :: Chan a -> [a] -> IO ()
-writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.MVar
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Synchronising variables
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.MVar
- (
- -- * @MVar@s
- MVar -- abstract
- , newEmptyMVar -- :: IO (MVar a)
- , newMVar -- :: a -> IO (MVar a)
- , takeMVar -- :: MVar a -> IO a
- , putMVar -- :: MVar a -> a -> IO ()
- , readMVar -- :: MVar a -> IO a
- , swapMVar -- :: MVar a -> a -> IO a
- , tryTakeMVar -- :: MVar a -> IO (Maybe a)
- , tryPutMVar -- :: MVar a -> a -> IO Bool
- , isEmptyMVar -- :: MVar a -> IO Bool
- , withMVar -- :: MVar a -> (a -> IO b) -> IO b
- , modifyMVar_ -- :: MVar a -> (a -> IO a) -> IO ()
- , modifyMVar -- :: MVar a -> (a -> IO (a,b)) -> IO b
-#ifndef __HUGS__
- , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
-#endif
- ) where
-
-#ifdef __HUGS__
-import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
- tryTakeMVar, tryPutMVar, isEmptyMVar,
- )
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
- tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
- )
-#endif
-
-import Prelude
-import Control.Exception.Base
-
-{-|
- This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
- from the 'MVar', puts it back, and also returns it.
--}
-readMVar :: MVar a -> IO a
-readMVar m =
- block $ do
- a <- takeMVar m
- putMVar m a
- return a
-
-{-|
- Take a value from an 'MVar', put a new value into the 'MVar' and
- return the value taken. Note that there is a race condition whereby
- another process can put something in the 'MVar' after the take
- happens but before the put does.
--}
-swapMVar :: MVar a -> a -> IO a
-swapMVar mvar new =
- block $ do
- old <- takeMVar mvar
- putMVar mvar new
- return old
-
-{-|
- 'withMVar' is a safe wrapper for operating on the contents of an
- 'MVar'. This operation is exception-safe: it will replace the
- original contents of the 'MVar' if an exception is raised (see
- "Control.Exception").
--}
-{-# INLINE withMVar #-}
--- inlining has been reported to have dramatic effects; see
--- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
-withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io =
- block $ do
- a <- takeMVar m
- b <- unblock (io a) `onException` putMVar m a
- putMVar m a
- return b
-
-{-|
- A safe wrapper for modifying the contents of an 'MVar'. Like 'withMVar',
- 'modifyMVar' will replace the original contents of the 'MVar' if an
- exception is raised during the operation.
--}
-{-# INLINE modifyMVar_ #-}
-modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
-modifyMVar_ m io =
- block $ do
- a <- takeMVar m
- a' <- unblock (io a) `onException` putMVar m a
- putMVar m a'
-
-{-|
- A slight variation on 'modifyMVar_' that allows a value to be
- returned (@b@) in addition to the modified value of the 'MVar'.
--}
-{-# INLINE modifyMVar #-}
-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
-modifyMVar m io =
- block $ do
- a <- takeMVar m
- (a',b) <- unblock (io a) `onException` putMVar m a
- putMVar m a'
- return b
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.QSem
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Simple quantity semaphores.
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.QSem
- ( -- * Simple Quantity Semaphores
- QSem, -- abstract
- newQSem, -- :: Int -> IO QSem
- waitQSem, -- :: QSem -> IO ()
- signalQSem -- :: QSem -> IO ()
- ) where
-
-import Prelude
-import Control.Concurrent.MVar
-import Data.Typeable
-
-#include "Typeable.h"
-
--- General semaphores are also implemented readily in terms of shared
--- @MVar@s, only have to catch the case when the semaphore is tried
--- waited on when it is empty (==0). Implement this in the same way as
--- shared variables are implemented - maintaining a list of @MVar@s
--- representing threads currently waiting. The counter is a shared
--- variable, ensuring the mutual exclusion on its access.
-
--- |A 'QSem' is a simple quantity semaphore, in which the available
--- \"quantity\" is always dealt with in units of one.
-newtype QSem = QSem (MVar (Int, [MVar ()]))
-
-INSTANCE_TYPEABLE0(QSem,qSemTc,"QSem")
-
--- |Build a new 'QSem'
-newQSem :: Int -> IO QSem
-newQSem initial = do
- sem <- newMVar (initial, [])
- return (QSem sem)
-
--- |Wait for a unit to become available
-waitQSem :: QSem -> IO ()
-waitQSem (QSem sem) = do
- (avail,blocked) <- takeMVar sem -- gain ex. access
- if avail > 0 then
- putMVar sem (avail-1,[])
- else do
- block <- newEmptyMVar
- {-
- Stuff the reader at the back of the queue,
- so as to preserve waiting order. A signalling
- process then only have to pick the MVar at the
- front of the blocked list.
-
- The version of waitQSem given in the paper could
- lead to starvation.
- -}
- putMVar sem (0, blocked++[block])
- takeMVar block
-
--- |Signal that a unit of the 'QSem' is available
-signalQSem :: QSem -> IO ()
-signalQSem (QSem sem) = do
- (avail,blocked) <- takeMVar sem
- case blocked of
- [] -> putMVar sem (avail+1,[])
-
- (block:blocked') -> do
- putMVar sem (0,blocked')
- putMVar block ()
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.QSemN
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Quantity semaphores in which each thread may wait for an arbitrary
--- \"amount\".
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.QSemN
- ( -- * General Quantity Semaphores
- QSemN, -- abstract
- newQSemN, -- :: Int -> IO QSemN
- waitQSemN, -- :: QSemN -> Int -> IO ()
- signalQSemN -- :: QSemN -> Int -> IO ()
- ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-import Data.Typeable
-
-#include "Typeable.h"
-
--- |A 'QSemN' is a quantity semaphore, in which the available
--- \"quantity\" may be signalled or waited for in arbitrary amounts.
-newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
-
-INSTANCE_TYPEABLE0(QSemN,qSemNTc,"QSemN")
-
--- |Build a new 'QSemN' with a supplied initial quantity.
-newQSemN :: Int -> IO QSemN
-newQSemN initial = do
- sem <- newMVar (initial, [])
- return (QSemN sem)
-
--- |Wait for the specified quantity to become available
-waitQSemN :: QSemN -> Int -> IO ()
-waitQSemN (QSemN sem) sz = do
- (avail,blocked) <- takeMVar sem -- gain ex. access
- if (avail - sz) >= 0 then
- -- discharging 'sz' still leaves the semaphore
- -- in an 'unblocked' state.
- putMVar sem (avail-sz,blocked)
- else do
- block <- newEmptyMVar
- putMVar sem (avail, blocked++[(sz,block)])
- takeMVar block
-
--- |Signal that a given quantity is now available from the 'QSemN'.
-signalQSemN :: QSemN -> Int -> IO ()
-signalQSemN (QSemN sem) n = do
- (avail,blocked) <- takeMVar sem
- (avail',blocked') <- free (avail+n) blocked
- putMVar sem (avail',blocked')
- where
- free avail [] = return (avail,[])
- free avail ((req,block):blocked)
- | avail >= req = do
- putMVar block ()
- free (avail-req) blocked
- | otherwise = do
- (avail',blocked') <- free avail blocked
- return (avail',(req,block):blocked')
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Control.Concurrent.SampleVar
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (concurrency)
---
--- Sample variables
---
------------------------------------------------------------------------------
-
-module Control.Concurrent.SampleVar
- (
- -- * Sample Variables
- SampleVar, -- :: type _ =
-
- newEmptySampleVar, -- :: IO (SampleVar a)
- newSampleVar, -- :: a -> IO (SampleVar a)
- emptySampleVar, -- :: SampleVar a -> IO ()
- readSampleVar, -- :: SampleVar a -> IO a
- writeSampleVar, -- :: SampleVar a -> a -> IO ()
- isEmptySampleVar, -- :: SampleVar a -> IO Bool
-
- ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-
--- |
--- Sample variables are slightly different from a normal 'MVar':
---
--- * Reading an empty 'SampleVar' causes the reader to block.
--- (same as 'takeMVar' on empty 'MVar')
---
--- * Reading a filled 'SampleVar' empties it and returns value.
--- (same as 'takeMVar')
---
--- * Writing to an empty 'SampleVar' fills it with a value, and
--- potentially, wakes up a blocked reader (same as for 'putMVar' on
--- empty 'MVar').
---
--- * Writing to a filled 'SampleVar' overwrites the current value.
--- (different from 'putMVar' on full 'MVar'.)
-
-type SampleVar a
- = MVar (Int, -- 1 == full
- -- 0 == empty
- -- <0 no of readers blocked
- MVar a)
-
--- |Build a new, empty, 'SampleVar'
-newEmptySampleVar :: IO (SampleVar a)
-newEmptySampleVar = do
- v <- newEmptyMVar
- newMVar (0,v)
-
--- |Build a 'SampleVar' with an initial value.
-newSampleVar :: a -> IO (SampleVar a)
-newSampleVar a = do
- v <- newEmptyMVar
- putMVar v a
- newMVar (1,v)
-
--- |If the SampleVar is full, leave it empty. Otherwise, do nothing.
-emptySampleVar :: SampleVar a -> IO ()
-emptySampleVar v = do
- (readers, var) <- takeMVar v
- if readers > 0 then do
- takeMVar var
- putMVar v (0,var)
- else
- putMVar v (readers,var)
-
--- |Wait for a value to become available, then take it and return.
-readSampleVar :: SampleVar a -> IO a
-readSampleVar svar = do
---
--- filled => make empty and grab sample
--- not filled => try to grab value, empty when read val.
---
- (readers,val) <- takeMVar svar
- putMVar svar (readers-1,val)
- takeMVar val
-
--- |Write a value into the 'SampleVar', overwriting any previous value that
--- was there.
-writeSampleVar :: SampleVar a -> a -> IO ()
-writeSampleVar svar v = do
---
--- filled => overwrite
--- not filled => fill, write val
---
- (readers,val) <- takeMVar svar
- case readers of
- 1 ->
- swapMVar val v >>
- putMVar svar (1,val)
- _ ->
- putMVar val v >>
- putMVar svar (min 1 (readers+1), val)
-
--- | Returns 'True' if the 'SampleVar' is currently empty.
---
--- Note that this function is only useful if you know that no other
--- threads can be modifying the state of the 'SampleVar', because
--- otherwise the state of the 'SampleVar' may have changed by the time
--- you see the result of 'isEmptySampleVar'.
---
-isEmptySampleVar :: SampleVar a -> IO Bool
-isEmptySampleVar svar = do
- (readers, _) <- readMVar svar
- return (readers == 0)
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Data.Unique
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable
---
--- An abstract interface to a unique symbol generator.
---
------------------------------------------------------------------------------
-
-module Data.Unique (
- -- * Unique objects
- Unique, -- instance (Eq, Ord)
- newUnique, -- :: IO Unique
- hashUnique -- :: Unique -> Int
- ) where
-
-import Prelude
-
-import Control.Concurrent.MVar
-import System.IO.Unsafe (unsafePerformIO)
-
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.Num
-#endif
-
--- | An abstract unique object. Objects of type 'Unique' may be
--- compared for equality and ordering and hashed into 'Int'.
-newtype Unique = Unique Integer deriving (Eq,Ord)
-
-uniqSource :: MVar Integer
-uniqSource = unsafePerformIO (newMVar 0)
-{-# NOINLINE uniqSource #-}
-
--- | Creates a new object of type 'Unique'. The value returned will
--- not compare equal to any other value of type 'Unique' returned by
--- previous calls to 'newUnique'. There is no limit on the number of
--- times 'newUnique' may be called.
-newUnique :: IO Unique
-newUnique = do
- val <- takeMVar uniqSource
- let next = val+1
- putMVar uniqSource next
- return (Unique next)
-
--- | Hashes a 'Unique' into an 'Int'. Two 'Unique's may hash to the
--- same value, although in practice this is unlikely. The 'Int'
--- returned makes a good hash key.
-hashUnique :: Unique -> Int
-#if defined(__GLASGOW_HASKELL__)
-hashUnique (Unique i) = I# (hashInteger i)
-#else
-hashUnique (Unique u) = fromInteger (u `mod` (toInteger (maxBound :: Int) + 1))
-#endif
+++ /dev/null
--------------------------------------------------------------------------------
--- |
--- Module : System.Timeout
--- Copyright : (c) The University of Glasgow 2007
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable
---
--- Attach a timeout event to arbitrary 'IO' computations.
---
--------------------------------------------------------------------------------
-
-#ifdef __GLASGOW_HASKELL__
-#include "Typeable.h"
-#endif
-
-module System.Timeout ( timeout ) where
-
-#ifdef __GLASGOW_HASKELL__
-import Prelude (Show(show), IO, Ord((<)), Eq((==)), Int,
- otherwise, fmap)
-import Data.Maybe (Maybe(..))
-import Control.Monad (Monad(..))
-import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
-import Control.Exception (Exception, handleJust, throwTo, bracket)
-import Data.Typeable
-import Data.Unique (Unique, newUnique)
-
--- An internal type that is thrown as a dynamic exception to
--- interrupt the running IO computation when the timeout has
--- expired.
-
-data Timeout = Timeout Unique deriving Eq
-INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout")
-
-instance Show Timeout where
- show _ = "<<timeout>>"
-
-instance Exception Timeout
-#endif /* !__GLASGOW_HASKELL__ */
-
--- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
--- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
--- is available before the timeout expires, @Just a@ is returned. A negative
--- timeout interval means \"wait indefinitely\". When specifying long timeouts,
--- be careful not to exceed @maxBound :: Int@.
---
--- The design of this combinator was guided by the objective that @timeout n f@
--- should behave exactly the same as @f@ as long as @f@ doesn't time out. This
--- means that @f@ has the same 'myThreadId' it would have without the timeout
--- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate
--- further up. It also possible for @f@ to receive exceptions thrown to it by
--- another thread.
---
--- A tricky implementation detail is the question of how to abort an @IO@
--- computation. This combinator relies on asynchronous exceptions internally.
--- The technique works very well for computations executing inside of the
--- Haskell runtime system, but it doesn't work at all for non-Haskell code.
--- Foreign function calls, for example, cannot be timed out with this
--- combinator simply because an arbitrary C function cannot receive
--- asynchronous exceptions. When @timeout@ is used to wrap an FFI call that
--- blocks, no timeout event can be delivered until the FFI call returns, which
--- pretty much negates the purpose of the combinator. In practice, however,
--- this limitation is less severe than it may sound. Standard I\/O functions
--- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', Network.Socket.accept, or
--- 'System.IO.hWaitForInput' appear to be blocking, but they really don't
--- because the runtime system uses scheduling mechanisms like @select(2)@ to
--- perform asynchronous I\/O, so it is possible to interrupt standard socket
--- I\/O or file I\/O using this combinator.
-
-timeout :: Int -> IO a -> IO (Maybe a)
-#ifdef __GLASGOW_HASKELL__
-timeout n f
- | n < 0 = fmap Just f
- | n == 0 = return Nothing
- | otherwise = do
- pid <- myThreadId
- ex <- fmap Timeout newUnique
- handleJust (\e -> if e == ex then Just () else Nothing)
- (\_ -> return Nothing)
- (bracket (forkIO (threadDelay n >> throwTo pid ex))
- (killThread)
- (\_ -> fmap Just f))
-#else
-timeout n f = fmap Just f
-#endif /* !__GLASGOW_HASKELL__ */
GHC.TopHandler,
GHC.Unicode,
GHC.Weak,
- GHC.Word,
- System.Timeout
+ GHC.Word
extensions: MagicHash, ExistentialQuantification, Rank2Types,
ScopedTypeVariables, UnboxedTuples,
ForeignFunctionInterface, UnliftedFFITypes,
Control.Applicative,
Control.Arrow,
Control.Category,
- Control.Concurrent,
- Control.Concurrent.Chan,
- Control.Concurrent.MVar,
- Control.Concurrent.QSem,
- Control.Concurrent.QSemN,
- Control.Concurrent.SampleVar,
Control.Exception,
Control.Exception.Base
Control.OldException,
Data.Traversable
Data.Tuple,
Data.Typeable,
- Data.Unique,
Data.Version,
Data.Word,
Debug.Trace,
projects / ghc-base.git / commitdiff