X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=02b256a816e1cd87134dbca67c4bb1518040da66;hb=70d7c4b1cdc78fe03f63180c318d2ca15f4f6a26;hp=eb4c88a7167a0f52084805fc2bde56617f882d12;hpb=e816bd912de53222ae9baf9343236e9bd1462d23;p=ghc-base.git

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index eb4c88a..02b256a 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -1,5 +1,5 @@
 \begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Conc
@@ -53,6 +53,7 @@ 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)
@@ -213,7 +214,7 @@ instance  Monad STM  where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
-    m >> k      =  m >>= \_ -> k
+    m >> k      = thenSTM m k
     return x	= returnSTM x
     m >>= k     = bindSTM m k
 
@@ -232,6 +233,10 @@ thenSTM (STM m) k = STM ( \s ->
 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 )
@@ -587,10 +592,10 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
   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'
@@ -599,19 +604,18 @@ stick :: IORef Fd
 {-# 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