--
-----------------------------------------------------------------------------
+#include "config.h"
module GHC.Conc
( ThreadId(..)
, par -- :: a -> b -> b
, pseq -- :: a -> b -> b
, yield -- :: IO ()
- , labelThread -- :: String -> IO ()
- , forkProcess -- :: IO Int
+ , labelThread -- :: ThreadId -> String -> IO ()
+ , forkProcessPrim -- :: IO 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)
+ , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO 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.Err ( parError, seqError )
-import GHC.IOBase ( IO(..), MVar(..) )
+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, FunPtr(..) )
infixr 0 `par`, `pseq`
\end{code}
useful when debugging or diagnosing the behaviour of a concurrent
program.
-NOTE: in GHC, if you have a 'ThreadId', you essentially have
+/Note/: in GHC, if you have a 'ThreadId', you essentially have
a pointer to the thread itself. This means the thread itself can\'t be
garbage collected until you drop the 'ThreadId'.
This misfeature will hopefully be corrected at a later date.
+
+/Note/: Hugs does not provide any operations on other threads;
+it defines 'ThreadId' as a synonym for ().
-}
--forkIO has now been hoisted out into the Concurrent library.
-{- | 'killThread' terminates the given thread (Note: 'killThread' is
-not implemented in Hugs). Any work already done by the thread isn\'t
+{- | 'killThread' terminates the given thread (GHC only).
+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 = throwTo (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.
+{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
'throwTo' does not return until the exception has been raised in the
target thread. The calling thread can thus be certain that the target
throwTo (ThreadId id) ex = IO $ \ s ->
case (killThread# id ex s) of s1 -> (# s1, () #)
--- | Returns the 'ThreadId' of the calling thread.
+-- | Returns the 'ThreadId' of the calling thread (GHC only).
myThreadId :: IO ThreadId
myThreadId = IO $ \s ->
case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
yield = IO $ \s ->
case (yield# s) of s1 -> (# s1, () #)
-labelThread :: String -> IO ()
-labelThread str = IO $ \ s ->
+{- | 'labelThread' stores a string as identifier for this thread if
+you built a RTS with debugging support. This identifier will be used in
+the debugging output to make distinction of different threads easier
+(otherwise you only have the thread state object\'s address in the heap).
+
+Other applications like the graphical Concurrent Haskell Debugger
+(<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
+'labelThread' for their purposes as well.
+-}
+
+labelThread :: ThreadId -> String -> IO ()
+labelThread (ThreadId t) str = IO $ \ s ->
let ps = packCString# str
adr = byteArrayContents# ps in
- case (labelThread# adr s) of s1 -> (# s1, () #)
+ case (labelThread# t adr s) of s1 -> (# s1, () #)
+
+{- | 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
+that only the desired thread is running after the fork().
-forkProcess :: IO Int
-forkProcess = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
+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) #)
-- Nota Bene: 'pseq' used to be 'seq'
-- but 'seq' is now defined in PrelGHC
--
-- "pseq" is defined a bit weirdly (see below)
--
--- The reason for the strange "0# -> parError" case is that
--- it fools the compiler into thinking that seq is non-strict in
--- its second argument (even if it inlines seq at the call site).
--- If it thinks seq is strict in "y", then it often evaluates
+-- The reason for the strange "lazy" call is that
+-- it fools the compiler into thinking that pseq and par are non-strict in
+-- their second argument (even if it inlines pseq at the call site).
+-- If it thinks pseq is strict in "y", then it often evaluates
-- "y" before "x", which is totally wrong.
---
--- Just before converting from Core to STG there's a bit of magic
--- that recognises the seq# and eliminates the duff case.
{-# INLINE pseq #-}
pseq :: a -> b -> b
-pseq x y = case (seq# x) of { 0# -> seqError; _ -> y }
+pseq x y = x `seq` lazy y
{-# INLINE par #-}
par :: a -> b -> b
-par x y = case (par# x) of { 0# -> parError; _ -> y }
+par x y = case (par# x) of { _ -> lazy y }
\end{code}
%************************************************************************
case isEmptyMVar# mv# s# of
(# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
--- |Add a finalizer to an 'MVar'. See "Foreign.ForeignPtr" and
+-- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
-- "System.Mem.Weak" for more about finalizers.
addMVarFinalizer :: MVar a -> IO () -> IO ()
addMVarFinalizer (MVar m) finalizer =
\begin{code}
-- |The 'threadDelay' operation will cause the current thread to
--- suspend for a given number of microseconds. Note that the resolution
+-- suspend for a given number of microseconds (GHC only).
+--
+-- Note that the resolution
-- used by the Haskell runtime system\'s internal timer together with the
-- fact that the thread may take some time to be rescheduled after the
-- time has expired, means that the accuracy is more like 1\/50 second.
threadDelay :: Int -> IO ()
-- | Block the current thread until data is available to read on the
--- given file descriptor.
+-- given file descriptor (GHC only).
threadWaitRead :: Int -> IO ()
-- | Block the current thread until data can be written to the
--- given file descriptor.
+-- given file descriptor (GHC only).
threadWaitWrite :: Int -> IO ()
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#) #)
+
+asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
+asyncDoProc (FunPtr proc) (Ptr param) =
+ -- the 'length' value is ignored; simplifies implementation of
+ -- the async*# primops to have them all return the same result.
+ IO $ \s -> case asyncDoProc# proc param s of
+ (# s, len#, err# #) -> (# s, 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