\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Conc
, newTVar -- :: a -> STM (TVar a)
, readTVar -- :: TVar a -> STM a
, writeTVar -- :: a -> TVar a -> STM ()
+ , unsafeIOToSTM -- :: IO a -> STM a
#ifdef mingw32_TARGET_OS
, asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
{-# 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 )
res <- do_select
-- 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