X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=f1b4d616253d6b8fb574276e6d81d96954d8de0a;hb=639511b265b50c78aafb0bd7c872f536dff25e14;hp=edb9679f99874c5a6b17411e14b8c4388344868d;hpb=0d6c1599c246100deb2fa54315811ed94d1a300c;p=haskell-directory.git diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index edb9679..f1b4d61 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -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(..) @@ -55,7 +60,7 @@ module GHC.Conc , 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 @@ -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 @@ -82,7 +91,6 @@ import GHC.Pack ( packCString# ) import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) ) import GHC.STRef import Data.Typeable -#include "Typeable.h" infixr 0 `par`, `pseq` \end{code} @@ -94,7 +102,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. @@ -116,9 +124,6 @@ This misfeature will hopefully be corrected at a later date. it defines 'ThreadId' as a synonym for (). -} -INSTANCE_TYPEABLE0(ThreadId,threadIdTc,"ThreadId") - - --forkIO has now been hoisted out into the Concurrent library. {- | 'killThread' terminates the given thread (GHC only). @@ -141,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, () #) @@ -207,9 +218,7 @@ TVars are shared memory locations which support atomic memory transactions. \begin{code} -newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) - -INSTANCE_TYPEABLE1(STM,stmTc,"STM" ) +newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) deriving( Typeable ) unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #)) unSTM (STM a) = a @@ -267,9 +276,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) - -INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar" ) +data TVar a = TVar (TVar# RealWorld a) deriving( Typeable ) instance Eq (TVar a) where (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2# @@ -309,8 +316,6 @@ writes. \begin{code} --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) -INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) - -- |Create an 'MVar' which is initially empty. newEmptyMVar :: IO (MVar a) newEmptyMVar = IO $ \ s# -> @@ -388,25 +393,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 @@ -437,7 +437,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 -> @@ -449,7 +449,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 -> @@ -470,7 +470,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)) @@ -481,8 +481,8 @@ threadDelay time }} -- On Windows, we just make a safe call to 'Sleep' to implement threadDelay. -#ifdef mingw32_TARGET_OS -foreign import ccall safe "Sleep" c_Sleep :: CInt -> IO () +#ifdef mingw32_HOST_OS +foreign import stdcall safe "Sleep" c_Sleep :: CInt -> IO () #endif foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool @@ -519,7 +519,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 ()) @@ -534,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 @@ -583,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 [] @@ -624,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