make Control.Monad.Instances compilable by nhc98

[haskell-directory.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index f3c57cc..0b6bc91 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -23,7 +23,7 @@
 module GHC.Conc
        ( ThreadId(..)
 
-       -- Forking and suchlike
+       -- * Forking and suchlike
        , forkIO        -- :: IO a -> IO ThreadId
        , forkOnIO      -- :: Int -> IO a -> IO ThreadId
        , childHandler  -- :: Exception -> IO ()
@@ -35,13 +35,13 @@ module GHC.Conc
        , yield         -- :: IO ()
        , labelThread   -- :: ThreadId -> String -> IO ()
 
-       -- Waiting
+       -- * Waiting
        , threadDelay           -- :: Int -> IO ()
        , registerDelay         -- :: Int -> IO (TVar Bool)
        , threadWaitRead        -- :: Int -> IO ()
        , threadWaitWrite       -- :: Int -> IO ()
 
-       -- MVars
+       -- * MVars
        , MVar          -- abstract
        , newMVar       -- :: a -> IO (MVar a)
        , newEmptyMVar  -- :: IO (MVar a)
@@ -52,7 +52,7 @@ module GHC.Conc
        , isEmptyMVar   -- :: MVar a -> IO Bool
        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
 
-       -- TVars
+       -- * TVars
        , STM           -- abstract
        , atomically    -- :: STM a -> IO a
        , retry         -- :: STM a
@@ -65,6 +65,7 @@ module GHC.Conc
        , writeTVar     -- :: a -> TVar a -> STM ()
        , unsafeIOToSTM -- :: IO a -> STM a
 
+       -- * Miscellaneous
 #ifdef mingw32_HOST_OS
        , asyncRead     -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
        , asyncWrite    -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
@@ -290,6 +291,7 @@ TVars are shared memory locations which support atomic memory
 transactions.
 
 \begin{code}
+-- |A monad supporting atomic memory transactions.
 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) deriving( Typeable )
 
 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
@@ -333,14 +335,15 @@ atomically (STM m) = IO (\s -> (atomically# m) s )
 -- values in TVars which mean that it should not continue (e.g. the TVars
 -- represent a shared buffer that is now empty).  The implementation may
 -- block the thread until one of the TVars that it has read from has been
--- udpated.
+-- udpated. (GHC only)
 retry :: STM a
 retry = STM $ \s# -> retry# s#
 
--- |Compose two alternative STM actions.  If the first action completes without
--- retrying then it forms the result of the orElse.  Otherwise, if the first
--- action retries, then the second action is tried in its place.  If both actions
--- retry then the orElse as a whole retries.
+-- |Compose two alternative STM actions (GHC only).  If the first action
+-- completes without retrying then it forms the result of the orElse.
+-- Otherwise, if the first action retries, then the second action is
+-- tried in its place.  If both actions retry then the orElse as a
+-- whole retries.
 orElse :: STM a -> STM a -> STM a
 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 
@@ -348,6 +351,7 @@ orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 catchSTM :: STM a -> (Exception -> STM a) -> STM a
 catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
 
+-- |Shared memory locations that support atomic memory transactions.
 data TVar a = TVar (TVar# RealWorld a) deriving( Typeable )
 
 instance Eq (TVar a) where
@@ -579,6 +583,7 @@ threadDelay time
        case delay# time# s of { s -> (# s, () #)
        }}
 
+registerDelay :: Int -> IO (TVar Bool)
 registerDelay usecs 
 #ifndef mingw32_HOST_OS
   | threaded = waitForDelayEventSTM usecs
@@ -720,20 +725,24 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 
   (wakeup_all,delays') <- do_select delays
 
-  if wakeup_all then return ()
-    else do
-      b <- fdIsSet wakeup readfds
-      if b == 0 
-        then return ()
-        else alloca $ \p -> do 
-           c_read (fromIntegral wakeup) p 1; return ()
-           s <- peek p         
-           if (s == 0xff) 
-             then return ()
-             else do handler_tbl <- peek handlers
-                     sp <- peekElemOff handler_tbl (fromIntegral s)
-                     forkIO (do io <- deRefStablePtr sp; io)
-                     return ()
+  exit <-
+    if wakeup_all then return False
+      else do
+        b <- fdIsSet wakeup readfds
+        if b == 0 
+          then return False
+          else alloca $ \p -> do 
+                c_read (fromIntegral wakeup) p 1; return ()
+                s <- peek p            
+                case s of
+                 _ | s == io_MANAGER_WAKEUP -> return False
+                 _ | s == io_MANAGER_DIE    -> return True
+                 _ -> do handler_tbl <- peek handlers
+                         sp <- peekElemOff handler_tbl (fromIntegral s)
+                         forkIO (do io <- deRefStablePtr sp; io)
+                         return False
+
+  if exit then return () else do
 
   takeMVar prodding
   putMVar prodding False
@@ -747,6 +756,9 @@ stick :: IORef Fd
 {-# NOINLINE stick #-}
 stick = unsafePerformIO (newIORef 0)
 
+io_MANAGER_WAKEUP = 0xff :: CChar
+io_MANAGER_DIE    = 0xfe :: CChar
+
 prodding :: MVar Bool
 {-# NOINLINE prodding #-}
 prodding = unsafePerformIO (newMVar False)
@@ -756,7 +768,8 @@ prodServiceThread = do
   b <- takeMVar prodding
   if (not b) 
     then do fd <- readIORef stick
-           with 0xff $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
+           with io_MANAGER_WAKEUP $ \pbuf -> do 
+               c_write (fromIntegral fd) pbuf 1; return ()
     else return ()
   putMVar prodding True