X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=8476498c1f2d1caba26efdd6a7b0d53c3919b417;hb=04a66406a173c23a85081d3768a0364a03d6af5c;hp=eb4c88a7167a0f52084805fc2bde56617f882d12;hpb=e816bd912de53222ae9baf9343236e9bd1462d23;p=ghc-base.git

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index eb4c88a..8476498 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
@@ -14,7 +14,12 @@
 -- 
 -----------------------------------------------------------------------------
 
-#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(..)
 
@@ -53,8 +58,9 @@ 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
+#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
@@ -80,6 +86,7 @@ import GHC.Exception    ( Exception(..), AsyncException(..) )
 import GHC.Pack		( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
+import Data.Typeable
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -91,7 +98,7 @@ infixr 0 `par`, `pseq`
 %************************************************************************
 
 \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.
@@ -201,7 +208,7 @@ TVars are shared memory locations which support atomic memory
 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
@@ -213,7 +220,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 +239,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 )
@@ -255,7 +266,7 @@ 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
 
-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#
@@ -372,25 +383,20 @@ addMVarFinalizer (MVar m) finalizer =
 %************************************************************************
 
 \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
@@ -421,7 +427,7 @@ asyncWriteBA fd isSock len off bufB =
 -- 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 -> 
@@ -433,7 +439,7 @@ threadWaitRead fd
 -- 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 -> 
@@ -454,7 +460,7 @@ threadWaitWrite fd
 --
 threadDelay :: Int -> IO ()
 threadDelay time
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
   | threaded  = waitForDelayEvent time
 #else
   | threaded  = c_Sleep (fromIntegral (time `quot` 1000))
@@ -465,7 +471,7 @@ threadDelay time
 	}}
 
 -- 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
 
@@ -503,7 +509,7 @@ foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 --	- 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 ())
@@ -567,30 +573,32 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
   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'
@@ -599,19 +607,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