X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=8476498c1f2d1caba26efdd6a7b0d53c3919b417;hb=88b22778e7c06909683b493e037605a249ae37ad;hp=ee9477707779bf5349fc1ace5c2e200e61ae5017;hpb=c71f875f0b7d51cb6a61396d5f3cc5771a638728;p=ghc-base.git diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index ee94777..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(..) @@ -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 @@ -80,6 +85,8 @@ import GHC.Base ( Int(..) ) 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 @@ -259,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# @@ -376,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 @@ -425,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 -> @@ -437,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 -> @@ -458,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)) @@ -469,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 @@ -507,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 ()) @@ -571,24 +573,26 @@ 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