[project @ 2005-09-29 09:31:58 by ross]

[haskell-directory.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 4286566..f56cf61 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -15,6 +15,10 @@
 -----------------------------------------------------------------------------
 
 -- 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(..)
@@ -64,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
@@ -520,20 +528,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 
@@ -569,29 +583,39 @@ 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 c_startSignalHandler (fromIntegral s)
+
+  takeMVar prodding
   putMVar prodding False
 
   reqs' <- completeRequests reqs readfds writefds []
@@ -610,10 +634,16 @@ 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 unsafe "startSignalHandler"
+  c_startSignalHandler :: CInt -> IO ()
+
+foreign import ccall "setIOManagerPipe"
+  c_setIOManagerPipe :: CInt -> IO ()
+
 -- -----------------------------------------------------------------------------
 -- IO requests