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
#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}
real_handler se@(SomeException ex) =
-- ignore thread GC and killThread exceptions:
case cast ex of
- Just BlockedOnDeadMVar -> return ()
+ Just BlockedIndefinitelyOnMVar -> return ()
_ -> case cast ex of
- Just BlockedIndefinitely -> return ()
+ Just BlockedIndefinitelyOnSTM -> return ()
_ -> case cast ex of
Just ThreadKilled -> return ()
_ -> case cast ex of
-- 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
startIOManagerThread :: IO ()
startIOManagerThread = do
wakeup <- c_getIOManagerEvent
- forkIO $ service_loop wakeup []
+ _ <- forkIO $ service_loop wakeup []
return ()
service_loop :: HANDLE -- read end of pipe
_ | 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
start_console_handler r =
case toWin32ConsoleEvent r of
Just x -> withMVar win32ConsoleHandler $ \handler -> do
- forkIO (handler x)
+ _ <- forkIO (handler x)
return ()
Nothing -> return ()
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
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
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
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 []
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 ()
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 ()
data CFdSet
-foreign import ccall safe "select"
+foreign import ccall safe "__hscore_select"
c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
-> IO CInt
#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.
getUncaughtExceptionHandler :: IO (SomeException -> IO ())
getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
+
\end{code}