projects
/
haskell-directory.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2005-10-25 11:13:53 by simonmar]
[haskell-directory.git]
/
GHC
/
Conc.lhs
diff --git
a/GHC/Conc.lhs
b/GHC/Conc.lhs
index
0e74dc7
..
f1b4d61
100644
(file)
--- a/
GHC/Conc.lhs
+++ b/
GHC/Conc.lhs
@@
-14,6
+14,12
@@
--
-----------------------------------------------------------------------------
--
-----------------------------------------------------------------------------
+-- 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(..)
module GHC.Conc
( ThreadId(..)
@@
-62,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
, 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
) where
import System.Posix.Types
@@
-136,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
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, () #)
throwTo :: ThreadId -> Exception -> IO ()
throwTo (ThreadId id) ex = IO $ \ s ->
case (killThread# id ex s) of s1 -> (# s1, () #)
@@
-466,7
+482,7
@@
threadDelay time
-- On Windows, we just make a safe call to 'Sleep' to implement threadDelay.
#ifdef mingw32_HOST_OS
-- 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
#endif
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
@@
-518,20
+534,26
@@
pendingDelays :: IORef [DelayReq]
{-# NOINLINE pendingEvents #-}
{-# NOINLINE pendingDelays #-}
(pendingEvents,pendingDelays) = unsafePerformIO $ do
{-# 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?)
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
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)
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
quickForkIO $ do
allocaBytes sizeofFdSet $ \readfds -> do
allocaBytes sizeofFdSet $ \writefds -> do
@@
-567,29
+589,41
@@
service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
fdSet wakeup readfds
maxfd <- buildFdSets 0 readfds writefds reqs
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()
-- 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
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
else
- return res
- res <- do_select
+ return (res,delays')
+
+ (res,delays') <- do_select delays
-- ToDo: check result
-- 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 []
putMVar prodding False
reqs' <- completeRequests reqs readfds writefds []
@@
-608,10
+642,15
@@
prodServiceThread = do
b <- takeMVar prodding
if (not b)
then do fd <- readIORef stick
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
else return ()
putMVar prodding True
+foreign import ccall "&signal_handlers" handlers :: Ptr (StablePtr (IO ()))
+
+foreign import ccall "setIOManagerPipe"
+ c_setIOManagerPipe :: CInt -> IO ()
+
-- -----------------------------------------------------------------------------
-- IO requests
-- -----------------------------------------------------------------------------
-- IO requests