module GHC.Conc
( ThreadId(..)
- -- Forking and suchlike
+ -- * Forking and suchlike
, forkIO -- :: IO a -> IO ThreadId
, forkOnIO -- :: Int -> IO a -> IO ThreadId
, childHandler -- :: Exception -> IO ()
, yield -- :: IO ()
, labelThread -- :: ThreadId -> String -> IO ()
- -- Waiting
+ -- * Waiting
, threadDelay -- :: Int -> IO ()
, registerDelay -- :: Int -> IO (TVar Bool)
, threadWaitRead -- :: Int -> IO ()
, threadWaitWrite -- :: Int -> IO ()
- -- MVars
+ -- * MVars
, MVar -- abstract
, newMVar -- :: a -> IO (MVar a)
, newEmptyMVar -- :: IO (MVar a)
, isEmptyMVar -- :: MVar a -> IO Bool
, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
- -- TVars
+ -- * TVars
, STM -- abstract
, atomically -- :: STM a -> IO a
, retry -- :: STM a
, writeTVar -- :: a -> TVar a -> STM ()
, unsafeIOToSTM -- :: IO a -> STM a
+ -- * Miscellaneous
#ifdef mingw32_HOST_OS
, asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
, asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
import GHC.Pack ( packCString# )
import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
import GHC.STRef
+import GHC.Show ( Show(..), showString )
import Data.Typeable
infixr 0 `par`, `pseq`
it defines 'ThreadId' as a synonym for ().
-}
+instance Show ThreadId where
+ showsPrec d t =
+ showString "ThreadId " .
+ showsPrec d (getThreadId (id2TSO t))
+
+foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> Int
+
+id2TSO :: ThreadId -> ThreadId#
+id2TSO (ThreadId t) = t
+
+foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
+-- 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
+
{- |
This sparks off a new thread to run the 'IO' computation passed as the
first argument, and returns the 'ThreadId' of the newly created
transactions.
\begin{code}
+-- |A monad supporting atomic memory transactions.
newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) deriving( Typeable )
unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
-- values in TVars which mean that it should not continue (e.g. the TVars
-- represent a shared buffer that is now empty). The implementation may
-- block the thread until one of the TVars that it has read from has been
--- udpated.
+-- udpated. (GHC only)
retry :: STM a
retry = STM $ \s# -> retry# s#
--- |Compose two alternative STM actions. If the first action completes without
--- retrying then it forms the result of the orElse. Otherwise, if the first
--- action retries, then the second action is tried in its place. If both actions
--- retry then the orElse as a whole retries.
+-- |Compose two alternative STM actions (GHC only). If the first action
+-- completes without retrying then it forms the result of the orElse.
+-- Otherwise, if the first action retries, then the second action is
+-- tried in its place. If both actions retry then the orElse as a
+-- whole retries.
orElse :: STM a -> STM a -> STM a
orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
catchSTM :: STM a -> (Exception -> STM a) -> STM a
catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
+-- |Shared memory locations that support atomic memory transactions.
data TVar a = TVar (TVar# RealWorld a) deriving( Typeable )
instance Eq (TVar a) where
case delay# time# s of { s -> (# s, () #)
}}
+registerDelay :: Int -> IO (TVar Bool)
registerDelay usecs
#ifndef mingw32_HOST_OS
| threaded = waitForDelayEventSTM usecs
(wakeup_all,delays') <- do_select delays
- if wakeup_all then return ()
- else do
- b <- fdIsSet wakeup readfds
- if b == 0
- then return ()
- else alloca $ \p -> do
- c_read (fromIntegral wakeup) p 1; return ()
- s <- peek p
- if (s == 0xff)
- then return ()
- else do handler_tbl <- peek handlers
- sp <- peekElemOff handler_tbl (fromIntegral s)
- forkIO (do io <- deRefStablePtr sp; io)
- return ()
+ exit <-
+ if wakeup_all then return False
+ else do
+ b <- fdIsSet wakeup readfds
+ if b == 0
+ then return False
+ else alloca $ \p -> do
+ c_read (fromIntegral wakeup) p 1; return ()
+ s <- peek p
+ case s of
+ _ | s == io_MANAGER_WAKEUP -> return False
+ _ | s == io_MANAGER_DIE -> return True
+ _ -> do handler_tbl <- peek handlers
+ sp <- peekElemOff handler_tbl (fromIntegral s)
+ forkIO (do io <- deRefStablePtr sp; io)
+ return False
+
+ if exit then return () else do
takeMVar prodding
putMVar prodding False
{-# NOINLINE stick #-}
stick = unsafePerformIO (newIORef 0)
+io_MANAGER_WAKEUP = 0xff :: CChar
+io_MANAGER_DIE = 0xfe :: CChar
+
prodding :: MVar Bool
{-# NOINLINE prodding #-}
prodding = unsafePerformIO (newMVar False)
b <- takeMVar prodding
if (not b)
then do fd <- readIORef stick
- with 0xff $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
+ with io_MANAGER_WAKEUP $ \pbuf -> do
+ c_write (fromIntegral fd) pbuf 1; return ()
else return ()
putMVar prodding True
projects / haskell-directory.git / blobdiff