X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent.hs;h=8df665e37cae5166202a7cd46ebac4a89ef1d8c8;hb=b73537367458c1307177d60d44b85516b661bd99;hp=c5fbaa2b9c70524673dd14029f56c71bf1663745;hpb=c661d1f356bae58fdd38110f358c080bb976e086;p=ghc-base.git

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index c5fbaa2..8df665e 100644
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -68,7 +68,8 @@ module Control.Concurrent (
 	rtsSupportsBoundThreads,
 	forkOS,
 	isCurrentThreadBound,
-	runInBoundThread
+	runInBoundThread,
+	runInUnboundThread
 #endif
 
 	-- * GHC's implementation of concurrency
@@ -90,7 +91,8 @@ import Prelude
 import Control.Exception as Exception
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Conc
+import GHC.Conc		( ThreadId(..), myThreadId, killThread, yield,
+			  threadDelay, threadWaitRead, threadWaitWrite )
 import GHC.TopHandler   ( reportStackOverflow, reportError )
 import GHC.IOBase	( IO(..) )
 import GHC.IOBase	( unsafeInterleaveIO )
@@ -142,7 +144,7 @@ In GHC, threads may also communicate via exceptions.
 
     Scheduling may be either pre-emptive or co-operative,
     depending on the implementation of Concurrent Haskell (see below
-    for imformation related to specific compilers).  In a co-operative
+    for information related to specific compilers).  In a co-operative
     system, context switches only occur when you use one of the
     primitives defined in this module.  This means that programs such
     as:
@@ -224,12 +226,12 @@ real_handler ex =
   case ex of
 	-- ignore thread GC and killThread exceptions:
 	BlockedOnDeadMVar            -> return ()
+	BlockedIndefinitely          -> return ()
 	AsyncException ThreadKilled  -> return ()
 
 	-- report all others:
-	AsyncException StackOverflow -> reportStackOverflow False
-	ErrorCall s -> reportError False s
-	other       -> reportError False (showsPrec 0 other "\n")
+	AsyncException StackOverflow -> reportStackOverflow
+	other       -> reportError other
 
 #endif /* __GLASGOW_HASKELL__ */
 
@@ -314,12 +316,8 @@ nmergeIO lss
 {- $boundthreads
 
 Support for multiple operating system threads and bound threads as described
-below is currently only available in the GHC runtime system when the runtime system
-has been compiled using a special option.
-
-When recompiling GHC, use .\/configure --enable-threaded-rts to enable this.
-To find your GHC has already been compiled that way, use
-'rtsSupportsBoundThreads' from GHCi.
+below is currently only available in the GHC runtime system if you use the
+/-threaded/ option when linking.
 
 Other Haskell systems do not currently support multiple operating system threads.
 
@@ -382,6 +380,9 @@ forkOS_entry stableAction = do
 foreign import ccall forkOS_createThread
     :: StablePtr (IO ()) -> IO CInt
 
+failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
+                       ++"(use ghc -threaded when linking)"
+    
 forkOS action 
     | rtsSupportsBoundThreads = do
 	mv <- newEmptyMVar
@@ -392,7 +393,7 @@ forkOS action
 	tid <- takeMVar mv
 	freeStablePtr entry
 	return tid
-    | otherwise = fail "RTS not built to support multiple OS threads."
+    | otherwise = failNonThreaded
 
 -- | Returns 'True' if the calling thread is /bound/, that is, if it is
 -- safe to use foreign libraries that rely on thread-local state from the
@@ -429,7 +430,7 @@ runInBoundThread action
 		case resultOrException of
 		    Left exception -> Exception.throw exception
 		    Right result -> return result
-    | otherwise = fail "RTS not built to support multiple OS threads."
+    | otherwise = failNonThreaded
 
 {- | 
 Run the 'IO' computation passed as the first argument. If the calling thread
@@ -477,8 +478,8 @@ runInUnboundThread action = do
 
 >   myForkIO :: IO () -> IO (MVar ())
 >   myForkIO io = do
->     mvar \<- newEmptyMVar
->     forkIO (io \`finally\` putMVar mvar ())
+>     mvar <- newEmptyMVar
+>     forkIO (io `finally` putMVar mvar ())
 >     return mvar
 
       Note that we use 'finally' from the
@@ -489,25 +490,26 @@ runInUnboundThread action = do
       A better method is to keep a global list of all child
       threads which we should wait for at the end of the program:
 
->     children :: MVar [MVar ()]
->     children = unsafePerformIO (newMVar [])
->     
->     waitForChildren :: IO ()
->     waitForChildren = do
->     	(mvar:mvars) \<- takeMVar children
->     	putMVar children mvars
->     	takeMVar mvar
->     	waitForChildren
->     
->     forkChild :: IO () -> IO ()
->     forkChild io = do
->     	 mvar \<- newEmptyMVar
->     	 forkIO (p \`finally\` putMVar mvar ())
->     	 childs \<- takeMVar children
->     	 putMVar children (mvar:childs)
->     
->     later = flip finally
->     
+>    children :: MVar [MVar ()]
+>    children = unsafePerformIO (newMVar [])
+>    
+>    waitForChildren :: IO ()
+>    waitForChildren = do
+>      cs <- takeMVar children
+>      case cs of
+>        []   -> return ()
+>        m:ms -> do
+>    	    putMVar children ms
+>    	    takeMVar m
+>    	    waitForChildren
+>    
+>    forkChild :: IO () -> IO ()
+>    forkChild io = do
+>    	 mvar <- newEmptyMVar
+>    	 childs <- takeMVar children
+>    	 putMVar children (mvar:childs)
+>    	 forkIO (io `finally` putMVar mvar ())
+>
 >     main =
 >     	later waitForChildren $
 >     	...
@@ -527,7 +529,7 @@ runInUnboundThread action = do
       a thread may be pre-empted whenever it allocates some memory,
       which unfortunately means that tight loops which do no
       allocation tend to lock out other threads (this only seems to
-      happen with pathalogical benchmark-style code, however).
+      happen with pathological benchmark-style code, however).
 
       The rescheduling timer runs on a 20ms granularity by
       default, but this may be altered using the