X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=7c97ddd46d38e1634e259e0126f22884681c5c75;hb=13c9517f61fe8104395ca08c2a378211458618be;hp=49689a3d77dd5e489b0babc015420008cd545c8d;hpb=c5c19001cb060d8dc966736209bb1c153060f924;p=ghc-base.git

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 49689a3..7c97ddd 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -14,6 +14,7 @@
 -- 
 -----------------------------------------------------------------------------
 
+#include "config.h"
 module GHC.Conc
 	( ThreadId(..)
 
@@ -26,7 +27,6 @@ module GHC.Conc
 	, yield         -- :: IO ()
 	, labelThread	-- :: ThreadId -> String -> IO ()
 	, forkProcessPrim -- :: IO Int
-	, forkProcess	-- :: IO (Maybe Int)
 
 	-- Waiting
 	, threadDelay	  	-- :: Int -> IO ()
@@ -44,16 +44,25 @@ module GHC.Conc
 	, 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}
@@ -141,10 +150,12 @@ labelThread (ThreadId t) str = IO $ \ s ->
        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
@@ -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.
+
+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
 --
@@ -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, () #)
+
+#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}