X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=f1b4d616253d6b8fb574276e6d81d96954d8de0a;hb=639511b265b50c78aafb0bd7c872f536dff25e14;hp=6dbe99147b67fe0a70a892df44e174e6459fc1ff;hpb=d9a0d6f44a930da4ae49678908e37793d693467c;p=haskell-directory.git

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 6dbe991..f1b4d61 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -14,7 +14,12 @@
 -- 
 -----------------------------------------------------------------------------
 
--- #hide
+-- 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(..)
 
@@ -63,6 +68,10 @@ module GHC.Conc
 	, asyncReadBA   -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
 	, asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
 #endif
+
+#ifndef mingw32_HOST_OS
+	, ensureIOManagerIsRunning
+#endif
         ) where
 
 import System.Posix.Types
@@ -137,7 +146,13 @@ target thread.  The calling thread can thus be certain that the target
 thread has received the exception.  This is a useful property to know
 when dealing with race conditions: eg. if there are two threads that
 can kill each other, it is guaranteed that only one of the threads
-will get to kill the other. -}
+will get to kill the other.
+
+If the target thread is currently making a foreign call, then the
+exception will not be raised (and hence 'throwTo' will not return)
+until the call has completed.  This is the case regardless of whether
+the call is inside a 'block' or not.
+ -}
 throwTo :: ThreadId -> Exception -> IO ()
 throwTo (ThreadId id) ex = IO $ \ s ->
    case (killThread# id ex s) of s1 -> (# s1, () #)
@@ -467,7 +482,7 @@ threadDelay time
 
 -- On Windows, we just make a safe call to 'Sleep' to implement threadDelay.
 #ifdef mingw32_HOST_OS
-foreign import ccall safe "Sleep" c_Sleep :: CInt -> IO ()
+foreign import stdcall safe "Sleep" c_Sleep :: CInt -> IO ()
 #endif
 
 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
@@ -519,20 +534,26 @@ pendingDelays :: IORef [DelayReq]
 {-# NOINLINE pendingEvents #-}
 {-# NOINLINE pendingDelays #-}
 (pendingEvents,pendingDelays) = unsafePerformIO $ do
-  startIOServiceThread
+  startIOManagerThread
   reqs <- newIORef []
   dels <- newIORef []
   return (reqs, dels)
 	-- the first time we schedule an IO request, the service thread
 	-- will be created (cool, huh?)
 
-startIOServiceThread :: IO ()
-startIOServiceThread = do
+ensureIOManagerIsRunning :: IO ()
+ensureIOManagerIsRunning 
+  | threaded  = seq pendingEvents $ return ()
+  | otherwise = return ()
+
+startIOManagerThread :: IO ()
+startIOManagerThread = do
         allocaArray 2 $ \fds -> do
-	throwErrnoIfMinus1 "startIOServiceThread" (c_pipe fds)
+	throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
 	rd_end <- peekElemOff fds 0
 	wr_end <- peekElemOff fds 1
 	writeIORef stick (fromIntegral wr_end)
+	c_setIOManagerPipe wr_end
 	quickForkIO $ do
 	    allocaBytes sizeofFdSet   $ \readfds -> do
 	    allocaBytes sizeofFdSet   $ \writefds -> do 
@@ -568,29 +589,41 @@ 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
 
-  b <- takeMVar prodding
-  if b then alloca $ \p -> do c_read (fromIntegral wakeup) p 1; return ()
-       else return ()
+  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 sp <- peekElemOff handlers (fromIntegral s)
+		      quickForkIO (deRefStablePtr sp)
+		      return ()
+
+  takeMVar prodding
   putMVar prodding False
 
   reqs' <- completeRequests reqs readfds writefds []
@@ -609,10 +642,15 @@ prodServiceThread = do
   b <- takeMVar prodding
   if (not b) 
     then do fd <- readIORef stick
-	    with 42 $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
+	    with 0xff $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
     else return ()
   putMVar prodding True
 
+foreign import ccall "&signal_handlers" handlers :: Ptr (StablePtr (IO ()))
+
+foreign import ccall "setIOManagerPipe"
+  c_setIOManagerPipe :: CInt -> IO ()
+
 -- -----------------------------------------------------------------------------
 -- IO requests