Export Unicode and newline functionality from System.IO; update Haddock docs

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

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 4318825..e3f5356 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -104,13 +104,20 @@ import System.Posix.Internals
 import Foreign
 import Foreign.C
 
+#ifdef mingw32_HOST_OS
+import Data.Typeable
+#endif
+
 #ifndef mingw32_HOST_OS
 import Data.Dynamic
-import Control.Monad
 #endif
+import Control.Monad
 import Data.Maybe
 
 import GHC.Base
+#ifndef mingw32_HOST_OS
+import GHC.Debug
+#endif
 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
 import GHC.IO
@@ -126,17 +133,14 @@ import GHC.Arr          ( inRange )
 #endif
 #ifdef mingw32_HOST_OS
 import GHC.Real         ( div )
-import GHC.Ptr          ( FunPtr(..) )
+import GHC.Ptr
 #endif
 #ifdef mingw32_HOST_OS
 import GHC.Read         ( Read )
 import GHC.Enum         ( Enum )
 #endif
 import GHC.Pack         ( packCString# )
-import GHC.Ptr          ( Ptr(..) )
 import GHC.Show         ( Show(..), showString )
-import Data.Typeable
-import GHC.Err
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -538,7 +542,7 @@ checkInv (STM m) = STM (\s -> (check# m) s)
 -- of those points then the transaction violating it is aborted
 -- and the exception raised by the invariant is propagated.
 alwaysSucceeds :: STM a -> STM ()
-alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () ) 
+alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) 
                       checkInv i
 
 -- | always is a variant of alwaysSucceeds in which the invariant is
@@ -819,7 +823,7 @@ prodServiceThread = do
 startIOManagerThread :: IO ()
 startIOManagerThread = do
   wakeup <- c_getIOManagerEvent
-  forkIO $ service_loop wakeup []
+  _ <- forkIO $ service_loop wakeup []
   return ()
 
 service_loop :: HANDLE          -- read end of pipe
@@ -845,9 +849,7 @@ service_loop wakeup old_delays = do
                 _ | r2 == io_MANAGER_DIE    -> return True
                 0 -> return False -- spurious wakeup
                 _ -> do start_console_handler (r2 `shiftR` 1); return False
-        if exit
-          then return ()
-          else service_cont wakeup delays'
+        unless exit $ service_cont wakeup delays'
 
     _other -> service_cont wakeup delays' -- probably timeout        
 
@@ -875,7 +877,7 @@ start_console_handler :: Word32 -> IO ()
 start_console_handler r =
   case toWin32ConsoleEvent r of
      Just x  -> withMVar win32ConsoleHandler $ \handler -> do
-                    forkIO (handler x)
+                    _ <- forkIO (handler x)
                     return ()
      Nothing -> return ()
 
@@ -952,7 +954,7 @@ foreign import stdcall "WaitForSingleObject"
 startIOManagerThread :: IO ()
 startIOManagerThread = do
         allocaArray 2 $ \fds -> do
-        throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
+        throwErrnoIfMinus1_ "startIOManagerThread" (c_pipe fds)
         rd_end <- peekElemOff fds 0
         wr_end <- peekElemOff fds 1
         setNonBlockingFD wr_end True -- writes happen in a signal handler, we
@@ -961,7 +963,7 @@ startIOManagerThread = do
         setCloseOnExec wr_end
         writeIORef stick (fromIntegral wr_end)
         c_setIOManagerPipe wr_end
-        forkIO $ do
+        _ <- forkIO $ do
             allocaBytes sizeofFdSet   $ \readfds -> do
             allocaBytes sizeofFdSet   $ \writefds -> do 
             allocaBytes sizeofTimeVal $ \timeval -> do
@@ -1026,7 +1028,8 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
         if b == 0 
           then return False
           else alloca $ \p -> do 
-                 c_read (fromIntegral wakeup) p 1
+                 warnErrnoIfMinus1_ "service_loop" $
+                     c_read (fromIntegral wakeup) p 1
                  s <- peek p            
                  case s of
                   _ | s == io_MANAGER_WAKEUP -> return False
@@ -1045,9 +1048,9 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
                        runHandlers' fp (fromIntegral s)
                        return False
 
-  if exit then return () else do
+  unless exit $ do
 
-  atomicModifyIORef prodding (\_ -> (False,False))
+  atomicModifyIORef prodding (\_ -> (False, ()))
 
   reqs' <- if wakeup_all then do wakeupAll reqs; return []
                          else completeRequests reqs readfds writefds []
@@ -1075,14 +1078,14 @@ syncIOManager = do
   atomicModifyIORef sync (\old -> (m:old,()))
   fd <- readIORef stick
   with io_MANAGER_SYNC $ \pbuf -> do 
-    c_write (fromIntegral fd) pbuf 1; return ()
+    warnErrnoIfMinus1_ "syncIOManager" $ c_write (fromIntegral fd) pbuf 1
   takeMVar m
 
 wakeupIOManager :: IO ()
 wakeupIOManager = do
   fd <- readIORef stick
   with io_MANAGER_WAKEUP $ \pbuf -> do 
-    c_write (fromIntegral fd) pbuf 1; return ()
+    warnErrnoIfMinus1_ "wakeupIOManager" $ c_write (fromIntegral fd) pbuf 1
 
 -- For the non-threaded RTS
 runHandlers :: Ptr Word8 -> Int -> IO ()
@@ -1102,7 +1105,19 @@ runHandlers' p_info sig = do
          else do handler <- unsafeReadIOArray arr int
                  case handler of
                     Nothing -> return ()
-                    Just (f,_)  -> do forkIO (f p_info); return ()
+                    Just (f,_)  -> do _ <- forkIO (f p_info)
+                                      return ()
+
+warnErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
+warnErrnoIfMinus1_ what io
+    = do r <- io
+         when (r == -1) $ do
+             errno <- getErrno
+             str <- strerror errno >>= peekCString
+             when (r == -1) $
+                 debugErrLn ("Warning: " ++ what ++ " failed: " ++ str)
+
+foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)
 
 foreign import ccall "setIOManagerPipe"
   c_setIOManagerPipe :: CInt -> IO ()
@@ -1266,14 +1281,13 @@ foreign import ccall unsafe "sizeof_fd_set"
 
 #endif
 
-reportStackOverflow :: IO a
-reportStackOverflow = do callStackOverflowHook; return undefined
+reportStackOverflow :: IO ()
+reportStackOverflow = callStackOverflowHook
 
-reportError :: SomeException -> IO a
+reportError :: SomeException -> IO ()
 reportError ex = do
    handler <- getUncaughtExceptionHandler
    handler ex
-   return undefined
 
 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
 -- the unsafe below.
@@ -1306,4 +1320,5 @@ setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
 
 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
+
 \end{code}