--
-----------------------------------------------------------------------------
+#include "config.h"
module GHC.Conc
( ThreadId(..)
, yield -- :: IO ()
, labelThread -- :: ThreadId -> String -> IO ()
, forkProcessPrim -- :: IO Int
- , forkProcess -- :: IO (Maybe Int)
-- Waiting
, threadDelay -- :: Int -> IO ()
, isEmptyMVar -- :: MVar a -> IO Bool
, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
- ) where
+#ifdef mingw32_TARGET_OS
+ , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
+ , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
+
+ , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
+ , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
+#endif
+ ) where
import Data.Maybe
import GHC.Base
import GHC.IOBase ( IO(..), MVar(..), ioException, IOException(..), IOErrorType(..) )
import GHC.Num ( fromInteger, negate )
+import GHC.Real ( fromIntegral )
import GHC.Base ( Int(..) )
import GHC.Exception ( Exception(..), AsyncException(..) )
import GHC.Pack ( packCString# )
+import GHC.Ptr ( Ptr(..), plusPtr )
infixr 0 `par`, `pseq`
\end{code}
not implemented in Hugs). Any work already done by the thread isn\'t
lost: the computation is suspended until required by another thread.
The memory used by the thread will be garbage collected if it isn\'t
-referenced from anywhere. The 'killThread' function may be defined in
+referenced from anywhere. The 'killThread' function is defined in
terms of 'throwTo':
-> killThread tid = throwTo tid (AsyncException ThreadKilled)
+> killThread tid = throwTo tid (AsyncException ThreadKilled)
+
-}
killThread :: ThreadId -> IO ()
-killThread (ThreadId id) = IO $ \ s ->
- case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
+killThread tid = throwTo tid (AsyncException ThreadKilled)
{- | 'throwTo' raises an arbitrary exception in the target thread.
adr = byteArrayContents# ps in
case (labelThread# t adr s) of s1 -> (# s1, () #)
-{- | This function is a replacement for "Posix.forkProcess": This implementation
-/will stop all other Concurrent Haskell threads/ in the (heavyweight) forked copy.
-'forkProcessPrim' returns the pid of the child process to the parent, 0 to the child,
-and a value less than 0 in case of errors. See also: 'forkProcess'.
+{- | This function is a replacement for 'System.Posix.Process.forkProcessAll':
+This implementation /will stop all other Concurrent Haskell threads/ in the
+(heavyweight) forked copy.
+'forkProcessPrim' returns the pid of the child process to the parent, 0 to the
+child, and a value less than 0 in case of errors. See also:
+'System.Posix.Process.forkProcess' in package @unix@.
Without this function, you need excessive and often impractical
explicit synchronization using the regular Concurrent Haskell constructs to assure
The stopped threads are /not/ garbage collected! This behaviour may change in
future releases.
+
+NOTE: currently, main threads are not stopped in the child process.
+To work around this problem, call 'forkProcessPrim' from the main thread.
-}
+-- XXX RTS should know about 'pid_t'.
+
forkProcessPrim :: IO Int
forkProcessPrim = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
-{- | 'forkProcess' is a wrapper around 'forkProcessPrim' similar to the one found in
-"Posix.forkProcess" which returns a Maybe-type. The child receives @Nothing@, the
-parent @Just (pid::Int)@. In case of an error, an exception is thrown.
--}
-
-forkProcess :: IO (Maybe Int)
-forkProcess = do
- pid <- forkProcessPrim
- case pid of
- -1 -> ioException (IOError Nothing -- stolen from hslibs/posix/PosixUtil
- SystemError
- "forkProcess"
- ""
- Nothing)
- 0 -> return Nothing
- _ -> return (Just pid)
-
-- Nota Bene: 'pseq' used to be 'seq'
-- but 'seq' is now defined in PrelGHC
--
threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #)
threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #)
threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
+
+#ifdef mingw32_TARGET_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) =
+ 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
+ (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
+
+-- to aid the use of these primops by the IO Handle implementation,
+-- provide the following convenience funs:
+
+-- this better be a pinned byte array!
+asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
+asyncReadBA fd isSock len off bufB =
+ asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
+
+asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
+asyncWriteBA fd isSock len off bufB =
+ asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
+
+#endif
\end{code}
projects / ghc-base.git / blobdiff