[project @ 2003-03-09 20:19:27 by panne]

[ghc-base.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 49689a3..7c97ddd 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -14,6 +14,7 @@
 -- 
 -----------------------------------------------------------------------------
 
 -- 
 -----------------------------------------------------------------------------
 

+#include "config.h"

 module GHC.Conc
        ( ThreadId(..)
 
 module GHC.Conc
        ( ThreadId(..)
 

@@ -26,7 +27,6 @@ module GHC.Conc
        , yield         -- :: IO ()
        , labelThread   -- :: ThreadId -> String -> IO ()
        , forkProcessPrim -- :: IO Int
        , yield         -- :: IO ()
        , labelThread   -- :: ThreadId -> String -> IO ()
        , forkProcessPrim -- :: IO Int

-       , forkProcess   -- :: IO (Maybe Int)

 
        -- Waiting
        , threadDelay           -- :: Int -> IO ()
 
        -- Waiting
        , threadDelay           -- :: Int -> IO ()

@@ -44,16 +44,25 @@ module GHC.Conc
        , isEmptyMVar   -- :: MVar a -> IO Bool
        , addMVarFinalizer -- :: MVar a -> IO () -> 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 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.Base                ( Int(..) )
 import GHC.Exception    ( Exception(..), AsyncException(..) )
 import GHC.Pack                ( packCString# )

+import GHC.Ptr          ( Ptr(..), plusPtr )

 
 infixr 0 `par`, `pseq`
 \end{code}
 
 infixr 0 `par`, `pseq`
 \end{code}

@@ -141,10 +150,12 @@ labelThread (ThreadId t) str = IO $ \ s ->
        adr = byteArrayContents# ps in
      case (labelThread# t adr s) of s1 -> (# s1, () #)
 
        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
 
 Without this function, you need excessive and often impractical
 explicit synchronization using the regular Concurrent Haskell constructs to assure

@@ -152,28 +163,16 @@ that only the desired thread is running after the fork().
 
 The stopped threads are /not/ garbage collected! This behaviour may change in
 future releases.
 
 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) #)
 
 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
 --
 --     Nota Bene: 'pseq' used to be 'seq'
 --                but 'seq' is now defined in PrelGHC
 --

@@ -310,4 +309,34 @@ 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, () #)
 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}
 \end{code}