X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=e3f53563791752073418ce1e511dcc4dd7d833c7;hb=ee7be4593b1b17d4ef45c37963b8b19d53865ab6;hp=431882503b10a7f21ee7757614e15f1e5301d8e7;hpb=8afc9fecd586d3c4f7ef9c69fb1686a79e5f441d;p=ghc-base.git diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 4318825..e3f5356 100644 --- 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}