From: Ian Lynagh Date: Sun, 24 Aug 2008 12:39:56 +0000 (+0000) Subject: Split off the concurrent hierarchy (concurrent, unique, timeout) X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=92411e7c816490869b36b8aa4c37fec985d16756;p=ghc-base.git Split off the concurrent hierarchy (concurrent, unique, timeout) --- diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs deleted file mode 100644 index 7f252f2..0000000 --- a/Control/Concurrent.hs +++ /dev/null @@ -1,636 +0,0 @@ -{-# 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/ -. - -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\@ 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__ */ diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs deleted file mode 100644 index 12f75c9..0000000 --- a/Control/Concurrent/Chan.hs +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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) diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs deleted file mode 100644 index 3513bbd..0000000 --- a/Control/Concurrent/MVar.hs +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs deleted file mode 100644 index 87f5543..0000000 --- a/Control/Concurrent/QSem.hs +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 () diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs deleted file mode 100644 index 014a72c..0000000 --- a/Control/Concurrent/QSemN.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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') diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs deleted file mode 100644 index 69c29c2..0000000 --- a/Control/Concurrent/SampleVar.hs +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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) - diff --git a/Data/Unique.hs b/Data/Unique.hs deleted file mode 100644 index 6f8c24f..0000000 --- a/Data/Unique.hs +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 diff --git a/System/Timeout.hs b/System/Timeout.hs deleted file mode 100644 index 431f709..0000000 --- a/System/Timeout.hs +++ /dev/null @@ -1,88 +0,0 @@ -------------------------------------------------------------------------------- --- | --- 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 _ = "<>" - -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__ */ diff --git a/base.cabal b/base.cabal index 973cae3..d47e9fb 100644 --- a/base.cabal +++ b/base.cabal @@ -59,8 +59,7 @@ Library { GHC.TopHandler, GHC.Unicode, GHC.Weak, - GHC.Word, - System.Timeout + GHC.Word extensions: MagicHash, ExistentialQuantification, Rank2Types, ScopedTypeVariables, UnboxedTuples, ForeignFunctionInterface, UnliftedFFITypes, @@ -72,12 +71,6 @@ Library { 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, @@ -107,7 +100,6 @@ Library { Data.Traversable Data.Tuple, Data.Typeable, - Data.Unique, Data.Version, Data.Word, Debug.Trace,