#endif
-- $merge
+#ifdef __GLASGOW_HASKELL__
-- * Bound Threads
-- $boundthreads
-#ifdef __GLASGOW_HASKELL__
rtsSupportsBoundThreads,
forkOS,
isCurrentThreadBound,
- runInBoundThread
+ runInBoundThread,
+ runInUnboundThread
#endif
-- * GHC's implementation of concurrency
import Control.Exception as Exception
#ifdef __GLASGOW_HASKELL__
-import GHC.Conc
+import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield,
+ threadDelay, threadWaitRead, threadWaitWrite,
+ forkIO, childHandler )
import GHC.TopHandler ( reportStackOverflow, reportError )
import GHC.IOBase ( IO(..) )
import GHC.IOBase ( unsafeInterleaveIO )
-import GHC.IOBase ( newIORef, readIORef, writeIORef )
+import GHC.IOBase ( newIORef, readIORef, writeIORef )
import GHC.Base
import Foreign.StablePtr
Scheduling may be either pre-emptive or co-operative,
depending on the implementation of Concurrent Haskell (see below
- for imformation related to specific compilers). In a co-operative
+ 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:
functions blocks only the thread making the call.
-}
--- Thread Ids, specifically the instances of Eq and Ord for these things.
--- The ThreadId type itself is defined in std/PrelConc.lhs.
-
--- Rather than define a new primitve, we use a little helper function
--- cmp_thread in the RTS.
-
-#ifdef __GLASGOW_HASKELL__
-id2TSO :: ThreadId -> ThreadId#
-id2TSO (ThreadId t) = t
-
-foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> Int
--- Returns -1, 0, 1
-
-cmpThread :: ThreadId -> ThreadId -> Ordering
-cmpThread t1 t2 =
- case cmp_thread (id2TSO t1) (id2TSO t2) of
- -1 -> LT
- 0 -> EQ
- _ -> GT -- must be 1
-
-instance Eq ThreadId where
- t1 == t2 =
- case t1 `cmpThread` t2 of
- EQ -> True
- _ -> False
-
-instance Ord ThreadId where
- compare = cmpThread
-
-foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> Int
-
-instance Show ThreadId where
- showsPrec d t =
- showString "ThreadId " .
- showsPrec d (getThreadId (id2TSO t))
-
-{- |
-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.
-
-The new thread will be a lightweight thread; if you want to use a foreign
-library that uses thread-local storage, use 'forkOS' instead.
--}
-forkIO :: IO () -> IO ThreadId
-forkIO action = IO $ \ s ->
- case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
- where
- action_plus = Exception.catch action childHandler
-
-childHandler :: Exception -> IO ()
-childHandler err = Exception.catch (real_handler err) childHandler
-
-real_handler :: Exception -> IO ()
-real_handler ex =
- case ex of
- -- ignore thread GC and killThread exceptions:
- BlockedOnDeadMVar -> return ()
- AsyncException ThreadKilled -> return ()
-
- -- report all others:
- AsyncException StackOverflow -> reportStackOverflow False
- ErrorCall s -> reportError False s
- other -> reportError False (showsPrec 0 other "\n")
-
-#endif /* __GLASGOW_HASKELL__ */
-
#ifndef __HUGS__
max_buff_size :: Int
max_buff_size = 1
mapIO f xs = sequence (map f xs)
#endif /* __HUGS__ */
+#ifdef __GLASGOW_HASKELL__
-- ---------------------------------------------------------------------------
-- Bound Threads
{- $boundthreads
Support for multiple operating system threads and bound threads as described
-below is currently only available in the GHC runtime system when the runtime system
-has been compiled using a special option.
-
-When recompiling GHC, use ./configure --enable-threaded-rts to enable this.
-To find your GHC has already been compiled that way, use
-'rtsSupportsBoundThreads' from GHCi.
+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.
from @main@ or from a @foreign export@.
-}
-#ifdef __GLASGOW_HASKELL__
-
-- | 'True' if bound threads are supported.
-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound'
-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will
foreign import ccall forkOS_createThread
:: StablePtr (IO ()) -> IO CInt
+failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
+ ++"(use ghc -threaded when linking)"
+
forkOS action
| rtsSupportsBoundThreads = do
mv <- newEmptyMVar
tid <- takeMVar mv
freeStablePtr entry
return tid
- | otherwise = fail "RTS not built to support multiple OS threads."
+ | 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
case resultOrException of
Left exception -> Exception.throw exception
Right result -> return result
- | otherwise = fail "RTS not built to support multiple OS threads."
+ | otherwise = failNonThreaded
{- |
Run the 'IO' computation passed as the first argument. If the calling thread
runInUnboundThread :: IO a -> IO a
runInUnboundThread action = do
- bound <- isCurrentThreadBound
- if bound
- then do
- mv <- newEmptyMVar
- forkIO (Exception.try action >>= putMVar mv)
- takeMVar mv >>= \either -> case either of
- Left exception -> Exception.throw exception
- Right result -> return result
- else action
+ bound <- isCurrentThreadBound
+ if bound
+ then do
+ mv <- newEmptyMVar
+ forkIO (Exception.try action >>= putMVar mv)
+ takeMVar mv >>= \either -> case either of
+ Left exception -> Exception.throw exception
+ Right result -> return result
+ else action
-#endif
+#endif /* __GLASGOW_HASKELL__ */
-- ---------------------------------------------------------------------------
-- More docs
> myForkIO :: IO () -> IO (MVar ())
> myForkIO io = do
-> mvar \<- newEmptyMVar
-> forkIO (io \`finally\` putMVar mvar ())
+> mvar <- newEmptyMVar
+> forkIO (io `finally` putMVar mvar ())
> return mvar
Note that we use 'finally' from the
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
-> (mvar:mvars) \<- takeMVar children
-> putMVar children mvars
-> takeMVar mvar
-> waitForChildren
->
-> forkChild :: IO () -> IO ()
-> forkChild io = do
-> mvar \<- newEmptyMVar
-> forkIO (p \`finally\` putMVar mvar ())
-> childs \<- takeMVar children
-> putMVar children (mvar:childs)
->
-> later = flip finally
->
+> 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 ()
+> forkChild io = do
+> mvar <- newEmptyMVar
+> childs <- takeMVar children
+> putMVar children (mvar:childs)
+> forkIO (io `finally` putMVar mvar ())
+>
> main =
> later waitForChildren $
> ...
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 pathalogical benchmark-style code, however).
+ happen with pathological benchmark-style code, however).
The rescheduling timer runs on a 20ms granularity by
default, but this may be altered using the
projects / haskell-directory.git / blobdiff