\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Conc
--
-----------------------------------------------------------------------------
-#include "ghcconfig.h"
+-- No: #hide, because bits of this module are exposed by the stm package.
+-- However, we don't want this module to be the home location for the
+-- bits it exports, we'd rather have Control.Concurrent and the other
+-- higher level modules be the home. Hence:
+
+-- #not-home
module GHC.Conc
( ThreadId(..)
, newTVar -- :: a -> STM (TVar a)
, readTVar -- :: TVar a -> STM a
, writeTVar -- :: a -> TVar a -> STM ()
+ , unsafeIOToSTM -- :: IO a -> STM a
-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS
, asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
, asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
, asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
import GHC.Pack ( packCString# )
import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
import GHC.STRef
+import Data.Typeable
infixr 0 `par`, `pseq`
\end{code}
%************************************************************************
\begin{code}
-data ThreadId = ThreadId ThreadId#
+data ThreadId = ThreadId ThreadId# deriving( Typeable )
-- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
-- But since ThreadId# is unlifted, the Weak type must use open
-- type variables.
transactions.
\begin{code}
-newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
+newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) deriving( Typeable )
unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
unSTM (STM a) = a
{-# INLINE return #-}
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
- m >> k = m >>= \_ -> k
+ m >> k = thenSTM m k
return x = returnSTM x
m >>= k = bindSTM m k
returnSTM :: a -> STM a
returnSTM x = STM (\s -> (# s, x #))
+-- | Unsafely performs IO in the STM monad.
+unsafeIOToSTM :: IO a -> STM a
+unsafeIOToSTM (IO m) = STM m
+
-- |Perform a series of STM actions atomically.
atomically :: STM a -> IO a
atomically (STM m) = IO (\s -> (atomically# m) s )
catchSTM :: STM a -> (Exception -> STM a) -> STM a
catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
-data TVar a = TVar (TVar# RealWorld a)
+data TVar a = TVar (TVar# RealWorld a) deriving( Typeable )
instance Eq (TVar a) where
(TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
%************************************************************************
\begin{code}
-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS
-- Note: threadDelay, threadWaitRead and threadWaitWrite aren't really functional
-- on Win32, but left in there because lib code (still) uses them (the manner
-- in which they're used doesn't cause problems on a Win32 platform though.)
asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
-asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = do
- (l, rc) <- IO (\s -> case asyncRead# fd isSock len buf s of
- (# s, len#, err# #) -> (# s, (I# len#, I# err#) #))
- -- special handling for Ctrl+C-aborted 'standard input' reads;
- -- see rts/win32/ConsoleHandler.c for details.
- if (l == 0 && rc == -2)
- then asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf)
- else return (l,rc)
+asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
+ IO $ \s -> case asyncRead# fd isSock len buf s of
+ (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
-asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
- IO $ \s -> case asyncWrite# fd isSock len buf s of
+asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
+ IO $ \s -> case asyncWrite# fd isSock len buf s of
(# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
-- given file descriptor (GHC only).
threadWaitRead :: Fd -> IO ()
threadWaitRead fd
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
| threaded = waitForReadEvent fd
#endif
| otherwise = IO $ \s ->
-- given file descriptor (GHC only).
threadWaitWrite :: Fd -> IO ()
threadWaitWrite fd
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
| threaded = waitForWriteEvent fd
#endif
| otherwise = IO $ \s ->
--
threadDelay :: Int -> IO ()
threadDelay time
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
| threaded = waitForDelayEvent time
#else
| threaded = c_Sleep (fromIntegral (time `quot` 1000))
}}
-- On Windows, we just make a safe call to 'Sleep' to implement threadDelay.
-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS
foreign import ccall safe "Sleep" c_Sleep :: CInt -> IO ()
#endif
-- - forkProcess will kill the IO manager thread. Let's just
-- hope we don't need to do any blocking IO between fork & exec.
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
data IOReq
= Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
fdSet wakeup readfds
maxfd <- buildFdSets 0 readfds writefds reqs
- -- check the current time and wake up any thread in threadDelay whose
- -- timeout has expired. Also find the timeout value for the select() call.
- now <- getTicksOfDay
- (delays', timeout) <- getDelay now ptimeval delays
-
-- perform the select()
- let do_select = do
+ let do_select delays = do
+ -- check the current time and wake up any thread in
+ -- threadDelay whose timeout has expired. Also find the
+ -- timeout value for the select() call.
+ now <- getTicksOfDay
+ (delays', timeout) <- getDelay now ptimeval delays
+
res <- c_select ((max wakeup maxfd)+1) readfds writefds
nullPtr timeout
if (res == -1)
then do
err <- getErrno
if err == eINTR
- then do_select
- else return res
+ then do_select delays'
+ else return (res,delays')
else
- return res
- res <- do_select
+ return (res,delays')
+
+ (res,delays') <- do_select delays
-- ToDo: check result
- old <- atomicModifyIORef prodding (\old -> (False,old))
- if old
- then alloca $ \p -> do c_read (fromIntegral wakeup) p 1; return ()
- else return ()
+ b <- takeMVar prodding
+ if b then alloca $ \p -> do c_read (fromIntegral wakeup) p 1; return ()
+ else return ()
+ putMVar prodding False
reqs' <- completeRequests reqs readfds writefds []
service_loop wakeup readfds writefds ptimeval reqs' delays'
{-# NOINLINE stick #-}
stick = unsafePerformIO (newIORef 0)
-prodding :: IORef Bool
+prodding :: MVar Bool
{-# NOINLINE prodding #-}
-prodding = unsafePerformIO (newIORef False)
+prodding = unsafePerformIO (newMVar False)
prodServiceThread :: IO ()
prodServiceThread = do
- b <- atomicModifyIORef prodding (\old -> (True,old)) -- compare & swap!
- if (not b)
- then do
- fd <- readIORef stick
- with 42 $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
- else
- return ()
+ b <- takeMVar prodding
+ if (not b)
+ then do fd <- readIORef stick
+ with 42 $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
+ else return ()
+ putMVar prodding True
-- -----------------------------------------------------------------------------
-- IO requests
projects / ghc-base.git / blobdiff