- | otherwise = IO $ \s ->
- case fromIntegral fd of { I# fd# ->
- case waitRead# fd# s of { s' -> (# s', () #)
- }}
-
--- | Block the current thread until data can be written to the
--- given file descriptor (GHC only).
-threadWaitWrite :: Fd -> IO ()
-threadWaitWrite fd
-#ifndef mingw32_HOST_OS
- | threaded = waitForWriteEvent fd
-#endif
- | otherwise = IO $ \s ->
- case fromIntegral fd of { I# fd# ->
- case waitWrite# fd# s of { s' -> (# s', () #)
- }}
-
--- | Suspends the current thread for a given number of microseconds
--- (GHC only).
---
--- There is no guarantee that the thread will be rescheduled promptly
--- when the delay has expired, but the thread will never continue to
--- run /earlier/ than specified.
---
-threadDelay :: Int -> IO ()
-threadDelay time
- | threaded = waitForDelayEvent time
- | otherwise = IO $ \s ->
- case fromIntegral time of { I# time# ->
- case delay# time# s of { s' -> (# s', () #)
- }}
-
-
--- | Set the value of returned TVar to True after a given number of
--- microseconds. The caveats associated with threadDelay also apply.
---
-registerDelay :: Int -> IO (TVar Bool)
-registerDelay usecs
- | threaded = waitForDelayEventSTM usecs
- | otherwise = error "registerDelay: requires -threaded"
-
-foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
-
-waitForDelayEvent :: Int -> IO ()
-waitForDelayEvent usecs = do
- m <- newEmptyMVar
- target <- calculateTarget usecs
- atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
- prodServiceThread
- takeMVar m
-
--- Delays for use in STM
-waitForDelayEventSTM :: Int -> IO (TVar Bool)
-waitForDelayEventSTM usecs = do
- t <- atomically $ newTVar False
- target <- calculateTarget usecs
- atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
- prodServiceThread
- return t
-
-calculateTarget :: Int -> IO USecs
-calculateTarget usecs = do
- now <- getUSecOfDay
- return $ now + (fromIntegral usecs)
-
-
--- ----------------------------------------------------------------------------
--- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay
-
--- In the threaded RTS, we employ a single IO Manager thread to wait
--- for all outstanding IO requests (threadWaitRead,threadWaitWrite)
--- and delays (threadDelay).
---
--- We can do this because in the threaded RTS the IO Manager can make
--- a non-blocking call to select(), so we don't have to do select() in
--- the scheduler as we have to in the non-threaded RTS. We get performance
--- benefits from doing it this way, because we only have to restart the select()
--- when a new request arrives, rather than doing one select() each time
--- around the scheduler loop. Furthermore, the scheduler can be simplified
--- by not having to check for completed IO requests.
-
-#ifndef mingw32_HOST_OS
-data IOReq
- = Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
- | Write {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
-#endif
-
-data DelayReq
- = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
- | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
-
-#ifndef mingw32_HOST_OS
-{-# NOINLINE pendingEvents #-}
-pendingEvents :: IORef [IOReq]
-pendingEvents = unsafePerformIO $ do
- m <- newIORef []
- sharedCAF m getOrSetGHCConcPendingEventsStore
-
-foreign import ccall unsafe "getOrSetGHCConcPendingEventsStore"
- getOrSetGHCConcPendingEventsStore :: Ptr a -> IO (Ptr a)
-#endif
-
-{-# NOINLINE pendingDelays #-}
-pendingDelays :: IORef [DelayReq]
-pendingDelays = unsafePerformIO $ do
- m <- newIORef []
- sharedCAF m getOrSetGHCConcPendingDelaysStore
-
-foreign import ccall unsafe "getOrSetGHCConcPendingDelaysStore"
- getOrSetGHCConcPendingDelaysStore :: Ptr a -> IO (Ptr a)
-
-{-# NOINLINE ioManagerThread #-}
-ioManagerThread :: MVar (Maybe ThreadId)
-ioManagerThread = unsafePerformIO $ do
- m <- newMVar Nothing
- sharedCAF m getOrSetGHCConcIOManagerThreadStore
-
-foreign import ccall unsafe "getOrSetGHCConcIOManagerThreadStore"
- getOrSetGHCConcIOManagerThreadStore :: Ptr a -> IO (Ptr a)
-
-ensureIOManagerIsRunning :: IO ()
-ensureIOManagerIsRunning
- | threaded = startIOManagerThread
- | otherwise = return ()
-
-startIOManagerThread :: IO ()
-startIOManagerThread = do
- modifyMVar_ ioManagerThread $ \old -> do
- let create = do t <- forkIO ioManager; return (Just t)
- case old of
- Nothing -> create
- Just t -> do
- s <- threadStatus t
- case s of
- ThreadFinished -> create
- ThreadDied -> create
- _other -> return (Just t)
-
-insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
-insertDelay d [] = [d]
-insertDelay d1 ds@(d2 : rest)
- | delayTime d1 <= delayTime d2 = d1 : ds
- | otherwise = d2 : insertDelay d1 rest
-
-delayTime :: DelayReq -> USecs
-delayTime (Delay t _) = t
-delayTime (DelaySTM t _) = t
-
-type USecs = Word64
-
-foreign import ccall unsafe "getUSecOfDay"
- getUSecOfDay :: IO USecs
-
-{-# NOINLINE prodding #-}
-prodding :: IORef Bool
-prodding = unsafePerformIO $ do
- r <- newIORef False
- sharedCAF r getOrSetGHCConcProddingStore
-
-foreign import ccall unsafe "getOrSetGHCConcProddingStore"
- getOrSetGHCConcProddingStore :: Ptr a -> IO (Ptr a)
-
-prodServiceThread :: IO ()
-prodServiceThread = do
- -- NB. use atomicModifyIORef here, otherwise there are race
- -- conditions in which prodding is left at True but the server is
- -- blocked in select().
- was_set <- atomicModifyIORef prodding $ \b -> (True,b)
- unless was_set wakeupIOManager
-
--- Machinery needed to ensure that we only have one copy of certain
--- CAFs in this module even when the base package is present twice, as
--- it is when base is dynamically loaded into GHCi. The RTS keeps
--- track of the single true value of the CAF, so even when the CAFs in
--- the dynamically-loaded base package are reverted, nothing bad
--- happens.
---
-sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
-sharedCAF a get_or_set =
- block $ do
- stable_ref <- newStablePtr a
- let ref = castPtr (castStablePtrToPtr stable_ref)
- ref2 <- get_or_set ref
- if ref==ref2
- then return a
- else do freeStablePtr stable_ref
- deRefStablePtr (castPtrToStablePtr (castPtr ref2))
-
-#ifdef mingw32_HOST_OS
--- ----------------------------------------------------------------------------
--- Windows IO manager thread
-
-ioManager :: IO ()
-ioManager = do
- wakeup <- c_getIOManagerEvent
- service_loop wakeup []
-
-service_loop :: HANDLE -- read end of pipe
- -> [DelayReq] -- current delay requests
- -> IO ()
-
-service_loop wakeup old_delays = do
- -- pick up new delay requests
- new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
- let delays = foldr insertDelay old_delays new_delays
-
- now <- getUSecOfDay
- (delays', timeout) <- getDelay now delays
-
- r <- c_WaitForSingleObject wakeup timeout
- case r of
- 0xffffffff -> do c_maperrno; throwErrno "service_loop"
- 0 -> do
- r2 <- c_readIOManagerEvent
- exit <-
- case r2 of
- _ | r2 == io_MANAGER_WAKEUP -> return False
- _ | r2 == io_MANAGER_DIE -> return True
- 0 -> return False -- spurious wakeup
- _ -> do start_console_handler (r2 `shiftR` 1); return False
- unless exit $ service_cont wakeup delays'
-
- _other -> service_cont wakeup delays' -- probably timeout
-
-service_cont :: HANDLE -> [DelayReq] -> IO ()
-service_cont wakeup delays = do
- r <- atomicModifyIORef prodding (\_ -> (False,False))
- r `seq` return () -- avoid space leak
- service_loop wakeup delays
-
--- must agree with rts/win32/ThrIOManager.c
-io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
-io_MANAGER_WAKEUP = 0xffffffff
-io_MANAGER_DIE = 0xfffffffe
-
-data ConsoleEvent
- = ControlC
- | Break
- | Close
- -- these are sent to Services only.
- | Logoff
- | Shutdown
- deriving (Eq, Ord, Enum, Show, Read, Typeable)
-
-start_console_handler :: Word32 -> IO ()
-start_console_handler r =
- case toWin32ConsoleEvent r of
- Just x -> withMVar win32ConsoleHandler $ \handler -> do
- _ <- forkIO (handler x)
- return ()
- Nothing -> return ()
-
-toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
-toWin32ConsoleEvent ev =
- case ev of
- 0 {- CTRL_C_EVENT-} -> Just ControlC
- 1 {- CTRL_BREAK_EVENT-} -> Just Break
- 2 {- CTRL_CLOSE_EVENT-} -> Just Close
- 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
- 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
- _ -> Nothing
-
-win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
-win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
-
-wakeupIOManager :: IO ()
-wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
-
--- Walk the queue of pending delays, waking up any that have passed
--- and return the smallest delay to wait for. The queue of pending
--- delays is kept ordered.
-getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
-getDelay _ [] = return ([], iNFINITE)
-getDelay now all@(d : rest)
- = case d of
- Delay time m | now >= time -> do
- putMVar m ()
- getDelay now rest
- DelaySTM time t | now >= time -> do
- atomically $ writeTVar t True
- getDelay now rest
- _otherwise ->
- -- delay is in millisecs for WaitForSingleObject
- let micro_seconds = delayTime d - now
- milli_seconds = (micro_seconds + 999) `div` 1000
- in return (all, fromIntegral milli_seconds)
-
--- ToDo: this just duplicates part of System.Win32.Types, which isn't
--- available yet. We should move some Win32 functionality down here,
--- maybe as part of the grand reorganisation of the base package...
-type HANDLE = Ptr ()
-type DWORD = Word32
-
-iNFINITE :: DWORD
-iNFINITE = 0xFFFFFFFF -- urgh
-
-foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_getIOManagerEvent :: IO HANDLE
-
-foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_readIOManagerEvent :: IO Word32
-
-foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_sendIOManagerEvent :: Word32 -> IO ()
-
-foreign import ccall unsafe "maperrno" -- in Win32Utils.c
- c_maperrno :: IO ()
-
-foreign import stdcall "WaitForSingleObject"
- c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
-
-#else
--- ----------------------------------------------------------------------------
--- Unix IO manager thread, using select()
-
-ioManager :: IO ()
-ioManager = do
- allocaArray 2 $ \fds -> do
- 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
- -- don't want them to block.
- setCloseOnExec rd_end
- setCloseOnExec wr_end
- c_setIOManagerPipe wr_end
- allocaBytes sizeofFdSet $ \readfds -> do
- allocaBytes sizeofFdSet $ \writefds -> do
- allocaBytes sizeofTimeVal $ \timeval -> do
- service_loop (fromIntegral rd_end) readfds writefds timeval [] []
- return ()
-
-service_loop
- :: Fd -- listen to this for wakeup calls
- -> Ptr CFdSet
- -> Ptr CFdSet
- -> Ptr CTimeVal
- -> [IOReq]
- -> [DelayReq]
- -> IO ()
-service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
-
- -- reset prodding before we look at the new requests. If a new
- -- client arrives after this point they will send a wakup which will
- -- cause the server to loop around again, so we can be sure to not
- -- miss any requests.
- --
- -- NB. it's important to do this in the *first* iteration of
- -- service_loop, rather than after calling select(), since a client
- -- may have set prodding to True without sending a wakeup byte down
- -- the pipe, because the pipe wasn't set up.
- atomicModifyIORef prodding (\_ -> (False, ()))
-
- -- pick up new IO requests
- new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))
- let reqs = new_reqs ++ old_reqs
-
- -- pick up new delay requests
- new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
- let delays0 = foldr insertDelay old_delays new_delays
-
- -- build the FDSets for select()
- fdZero readfds
- fdZero writefds
- fdSet wakeup readfds
- maxfd <- buildFdSets 0 readfds writefds reqs
-
- -- perform the select()
- let do_select delays = do
- -- check the current time and wake up any thread in
- -- threadDelay whose timeout has expired. Also find the
- -- timeout value for the select() call.
- now <- getUSecOfDay
- (delays', timeout) <- getDelay now ptimeval delays
-
- res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds
- nullPtr timeout
- if (res == -1)
- then do
- err <- getErrno
- case err of
- _ | err == eINTR -> do_select delays'
- -- EINTR: just redo the select()
- _ | err == eBADF -> return (True, delays)
- -- EBADF: one of the file descriptors is closed or bad,
- -- we don't know which one, so wake everyone up.
- _ | otherwise -> throwErrno "select"
- -- otherwise (ENOMEM or EINVAL) something has gone
- -- wrong; report the error.
- else
- return (False,delays')
-
- (wakeup_all,delays') <- do_select delays0
-
- exit <-
- if wakeup_all then return False
- else do
- b <- fdIsSet wakeup readfds
- if b == 0
- then return False
- else alloca $ \p -> do
- warnErrnoIfMinus1_ "service_loop" $
- c_read (fromIntegral wakeup) p 1
- s <- peek p
- case s of
- _ | s == io_MANAGER_WAKEUP -> return False
- _ | s == io_MANAGER_DIE -> return True
- _ | s == io_MANAGER_SYNC -> do
- mvars <- readIORef sync
- mapM_ (flip putMVar ()) mvars
- return False
- _ -> do
- fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
- withForeignPtr fp $ \p_siginfo -> do
- r <- c_read (fromIntegral wakeup) (castPtr p_siginfo)
- sizeof_siginfo_t
- when (r /= fromIntegral sizeof_siginfo_t) $
- error "failed to read siginfo_t"
- runHandlers' fp (fromIntegral s)
- return False
-
- unless exit $ do
-
- reqs' <- if wakeup_all then do wakeupAll reqs; return []
- else completeRequests reqs readfds writefds []
-
- service_loop wakeup readfds writefds ptimeval reqs' delays'
-
-io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: Word8
-io_MANAGER_WAKEUP = 0xff
-io_MANAGER_DIE = 0xfe
-io_MANAGER_SYNC = 0xfd
-
-{-# NOINLINE sync #-}
-sync :: IORef [MVar ()]
-sync = unsafePerformIO (newIORef [])
-
--- waits for the IO manager to drain the pipe
-syncIOManager :: IO ()
-syncIOManager = do
- m <- newEmptyMVar
- atomicModifyIORef sync (\old -> (m:old,()))
- c_ioManagerSync
- takeMVar m
-
-foreign import ccall unsafe "ioManagerSync" c_ioManagerSync :: IO ()
-foreign import ccall unsafe "ioManagerWakeup" wakeupIOManager :: IO ()
-
--- For the non-threaded RTS
-runHandlers :: Ptr Word8 -> Int -> IO ()
-runHandlers p_info sig = do
- fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
- withForeignPtr fp $ \p -> do
- copyBytes p p_info (fromIntegral sizeof_siginfo_t)
- free p_info
- runHandlers' fp (fromIntegral sig)
-
-runHandlers' :: ForeignPtr Word8 -> Signal -> IO ()
-runHandlers' p_info sig = do
- let int = fromIntegral sig
- withMVar signal_handlers $ \arr ->
- if not (inRange (boundsIOArray arr) int)
- then return ()
- else do handler <- unsafeReadIOArray arr int
- case handler of
- Nothing -> 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 ()
-
-foreign import ccall "__hscore_sizeof_siginfo_t"
- sizeof_siginfo_t :: CSize
-
-type Signal = CInt
-
-maxSig = 64 :: Int
-
-type HandlerFun = ForeignPtr Word8 -> IO ()
-
--- Lock used to protect concurrent access to signal_handlers. Symptom of
--- this race condition is #1922, although that bug was on Windows a similar
--- bug also exists on Unix.
-{-# NOINLINE signal_handlers #-}
-signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
-signal_handlers = unsafePerformIO $ do
- arr <- newIOArray (0,maxSig) Nothing
- m <- newMVar arr
- sharedCAF m getOrSetGHCConcSignalHandlerStore
-
-foreign import ccall unsafe "getOrSetGHCConcSignalHandlerStore"
- getOrSetGHCConcSignalHandlerStore :: Ptr a -> IO (Ptr a)
-
-setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic))
-setHandler sig handler = do
- let int = fromIntegral sig
- withMVar signal_handlers $ \arr ->
- if not (inRange (boundsIOArray arr) int)
- then error "GHC.Conc.setHandler: signal out of range"
- else do old <- unsafeReadIOArray arr int
- unsafeWriteIOArray arr int handler
- return old
-
--- -----------------------------------------------------------------------------
--- IO requests
-
-buildFdSets :: Fd -> Ptr CFdSet -> Ptr CFdSet -> [IOReq] -> IO Fd
-buildFdSets maxfd _ _ [] = return maxfd
-buildFdSets maxfd readfds writefds (Read fd _ : reqs)
- | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
- | otherwise = do
- fdSet fd readfds
- buildFdSets (max maxfd fd) readfds writefds reqs
-buildFdSets maxfd readfds writefds (Write fd _ : reqs)
- | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
- | otherwise = do
- fdSet fd writefds
- buildFdSets (max maxfd fd) readfds writefds reqs
-
-completeRequests :: [IOReq] -> Ptr CFdSet -> Ptr CFdSet -> [IOReq]
- -> IO [IOReq]
-completeRequests [] _ _ reqs' = return reqs'
-completeRequests (Read fd m : reqs) readfds writefds reqs' = do
- b <- fdIsSet fd readfds
- if b /= 0
- then do putMVar m (); completeRequests reqs readfds writefds reqs'
- else completeRequests reqs readfds writefds (Read fd m : reqs')
-completeRequests (Write fd m : reqs) readfds writefds reqs' = do
- b <- fdIsSet fd writefds
- if b /= 0
- then do putMVar m (); completeRequests reqs readfds writefds reqs'
- else completeRequests reqs readfds writefds (Write fd m : reqs')
-
-wakeupAll :: [IOReq] -> IO ()
-wakeupAll [] = return ()
-wakeupAll (Read _ m : reqs) = do putMVar m (); wakeupAll reqs
-wakeupAll (Write _ m : reqs) = do putMVar m (); wakeupAll reqs
-
-waitForReadEvent :: Fd -> IO ()
-waitForReadEvent fd = do
- m <- newEmptyMVar
- atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ()))
- prodServiceThread
- takeMVar m
-
-waitForWriteEvent :: Fd -> IO ()
-waitForWriteEvent fd = do
- m <- newEmptyMVar
- atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ()))
- prodServiceThread
- takeMVar m
-
--- -----------------------------------------------------------------------------
--- Delays
-
--- Walk the queue of pending delays, waking up any that have passed
--- and return the smallest delay to wait for. The queue of pending
--- delays is kept ordered.
-getDelay :: USecs -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
-getDelay _ _ [] = return ([],nullPtr)
-getDelay now ptimeval all@(d : rest)
- = case d of
- Delay time m | now >= time -> do
- putMVar m ()
- getDelay now ptimeval rest
- DelaySTM time t | now >= time -> do
- atomically $ writeTVar t True
- getDelay now ptimeval rest
- _otherwise -> do
- setTimevalTicks ptimeval (delayTime d - now)
- return (all,ptimeval)
-
-data CTimeVal
-
-foreign import ccall unsafe "sizeofTimeVal"
- sizeofTimeVal :: Int
-
-foreign import ccall unsafe "setTimevalTicks"
- setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()
-
-{-
- On Win32 we're going to have a single Pipe, and a
- waitForSingleObject with the delay time. For signals, we send a
- byte down the pipe just like on Unix.
--}
-
--- ----------------------------------------------------------------------------
--- select() interface
-
--- ToDo: move to System.Posix.Internals?
-
-data CFdSet
-
-foreign import ccall safe "__hscore_select"
- c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
- -> IO CInt
-
-foreign import ccall unsafe "hsFD_SETSIZE"
- c_fD_SETSIZE :: CInt
-
-fD_SETSIZE :: Fd
-fD_SETSIZE = fromIntegral c_fD_SETSIZE
-
-foreign import ccall unsafe "hsFD_ISSET"
- c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
-
-fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
-fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset
-
-foreign import ccall unsafe "hsFD_SET"
- c_fdSet :: CInt -> Ptr CFdSet -> IO ()
-
-fdSet :: Fd -> Ptr CFdSet -> IO ()
-fdSet (Fd fd) fdset = c_fdSet fd fdset
-
-foreign import ccall unsafe "hsFD_ZERO"
- fdZero :: Ptr CFdSet -> IO ()
-
-foreign import ccall unsafe "sizeof_fd_set"
- sizeofFdSet :: Int
-
-#endif
-
-reportStackOverflow :: IO ()
-reportStackOverflow = callStackOverflowHook
-
-reportError :: SomeException -> IO ()
-reportError ex = do
- handler <- getUncaughtExceptionHandler
- handler ex
-
--- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
--- the unsafe below.
-foreign import ccall unsafe "stackOverflow"
- callStackOverflowHook :: IO ()
-
-{-# NOINLINE uncaughtExceptionHandler #-}
-uncaughtExceptionHandler :: IORef (SomeException -> IO ())
-uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
- where
- defaultHandler :: SomeException -> IO ()
- defaultHandler se@(SomeException ex) = do
- (hFlush stdout) `catchAny` (\ _ -> return ())
- let msg = case cast ex of
- Just Deadlock -> "no threads to run: infinite loop or deadlock?"
- _ -> case cast ex of
- Just (ErrorCall s) -> s
- _ -> showsPrec 0 se ""
- withCString "%s" $ \cfmt ->
- withCString msg $ \cmsg ->
- errorBelch cfmt cmsg
-
--- don't use errorBelch() directly, because we cannot call varargs functions
--- using the FFI.
-foreign import ccall unsafe "HsBase.h errorBelch2"
- errorBelch :: CString -> CString -> IO ()
-
-setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
-setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
-
-getUncaughtExceptionHandler :: IO (SomeException -> IO ())
-getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler