\begin{code}
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
-- |
, newTVar -- :: a -> STM (TVar a)
, newTVarIO -- :: a -> STM (TVar a)
, readTVar -- :: TVar a -> STM a
+ , readTVarIO -- :: TVar a -> IO a
, writeTVar -- :: a -> TVar a -> STM ()
, unsafeIOToSTM -- :: IO a -> STM a
, win32ConsoleHandler
, toWin32ConsoleEvent
#endif
+ , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO ()
+ , getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
+
+ , reportError, reportStackOverflow
) where
import System.Posix.Types
import Foreign
import Foreign.C
-#ifndef __HADDOCK__
-import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow )
-#endif
-
import Data.Maybe
import GHC.Base
+import {-# SOURCE #-} GHC.Handle
import GHC.IOBase
import GHC.Num ( Num(..) )
-import GHC.Real ( fromIntegral, div )
-#ifndef mingw32_HOST_OS
-import GHC.Base ( Int(..) )
+import GHC.Real ( fromIntegral )
+#ifdef mingw32_HOST_OS
+import GHC.Real ( div )
+import GHC.Ptr ( plusPtr, FunPtr(..) )
#endif
#ifdef mingw32_HOST_OS
import GHC.Read ( Read )
import GHC.Enum ( Enum )
#endif
-import GHC.Exception
+import GHC.Exception ( SomeException(..), throw )
import GHC.Pack ( packCString# )
-import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
+import GHC.Ptr ( Ptr(..) )
import GHC.STRef
import GHC.Show ( Show(..), showString )
import Data.Typeable
+import GHC.Err
infixr 0 `par`, `pseq`
\end{code}
-}
forkIO :: IO () -> IO ThreadId
forkIO action = IO $ \ s ->
- case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
where
action_plus = catchException action childHandler
-}
forkOnIO :: Int -> IO () -> IO ThreadId
forkOnIO (I# cpu) action = IO $ \ s ->
- case (forkOn# cpu action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
where
action_plus = catchException action childHandler
foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
-childHandler :: Exception -> IO ()
+childHandler :: SomeException -> IO ()
childHandler err = catchException (real_handler err) childHandler
-real_handler :: Exception -> IO ()
-real_handler ex =
- case ex of
- -- ignore thread GC and killThread exceptions:
- BlockedOnDeadMVar -> return ()
- BlockedIndefinitely -> return ()
- AsyncException ThreadKilled -> return ()
-
- -- report all others:
- AsyncException StackOverflow -> reportStackOverflow
- other -> reportError other
+real_handler :: SomeException -> IO ()
+real_handler se@(SomeException ex) =
+ -- ignore thread GC and killThread exceptions:
+ case cast ex of
+ Just BlockedOnDeadMVar -> return ()
+ _ -> case cast ex of
+ Just BlockedIndefinitely -> return ()
+ _ -> case cast ex of
+ Just ThreadKilled -> return ()
+ _ -> case cast ex of
+ -- report all others:
+ Just StackOverflow -> reportStackOverflow
+ _ -> reportError se
{- | 'killThread' terminates the given thread (GHC only).
Any work already done by the thread isn\'t
referenced from anywhere. The 'killThread' function is defined in
terms of 'throwTo':
-> killThread tid = throwTo tid (AsyncException ThreadKilled)
+> killThread tid = throwTo tid ThreadKilled
+Killthread is a no-op if the target thread has already completed.
-}
killThread :: ThreadId -> IO ()
-killThread tid = throwTo tid (AsyncException ThreadKilled)
+killThread tid = throwTo tid ThreadKilled
{- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
a pending 'throwTo'. This is arguably undesirable behaviour.
-}
-throwTo :: ThreadId -> Exception -> IO ()
-throwTo (ThreadId id) ex = IO $ \ s ->
- case (killThread# id ex s) of s1 -> (# s1, () #)
+throwTo :: Exception e => ThreadId -> e -> IO ()
+throwTo (ThreadId tid) ex = IO $ \ s ->
+ case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
-- | Returns the 'ThreadId' of the calling thread (GHC only).
myThreadId :: IO ThreadId
myThreadId = IO $ \s ->
- case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
+ case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
-- |The 'yield' action allows (forces, in a co-operative multitasking
-- ^currently in a foreign call
| BlockedOnOther
-- ^blocked on some other resource. Without @-threaded@,
- -- I/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
+ -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
-- they show up as 'BlockedOnMVar'.
deriving (Eq,Ord,Show)
thenSTM :: STM a -> STM b -> STM b
thenSTM (STM m) k = STM ( \s ->
case m s of
- (# new_s, a #) -> unSTM k new_s
+ (# new_s, _ #) -> unSTM k new_s
)
returnSTM :: a -> STM a
returnSTM x = STM (\s -> (# s, x #))
--- | Unsafely performs IO in the STM monad.
+-- | Unsafely performs IO in the STM monad. Beware: this is a highly
+-- dangerous thing to do.
+--
+-- * The STM implementation will often run transactions multiple
+-- times, so you need to be prepared for this if your IO has any
+-- side effects.
+--
+-- * The STM implementation will abort transactions that are known to
+-- be invalid and need to be restarted. This may happen in the middle
+-- of `unsafeIOToSTM`, so make sure you don't acquire any resources
+-- that need releasing (exception handlers are ignored when aborting
+-- the transaction). That includes doing any IO using Handles, for
+-- example. Getting this wrong will probably lead to random deadlocks.
+--
+-- * The transaction may have seen an inconsistent view of memory when
+-- the IO runs. Invariants that you expect to be true throughout
+-- your program may not be true inside a transaction, due to the
+-- way transactions are implemented. Normally this wouldn't be visible
+-- to the programmer, but using `unsafeIOToSTM` can expose it.
+--
unsafeIOToSTM :: IO a -> STM a
unsafeIOToSTM (IO m) = STM m
orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
-- |Exception handling within STM actions.
-catchSTM :: STM a -> (Exception -> STM a) -> STM a
+catchSTM :: STM a -> (SomeException -> STM a) -> STM a
catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
-- | Low-level primitive on which always and alwaysSucceeds are built.
case newTVar# val s1# of
(# s2#, tvar# #) -> (# s2#, TVar tvar# #)
+-- |Return the current value stored in a TVar.
+-- This is equivalent to
+--
+-- > readTVarIO = atomically . readTVar
+--
+-- but works much faster, because it doesn't perform a complete
+-- transaction, it just reads the current value of the 'TVar'.
+readTVarIO :: TVar a -> IO a
+readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
+
-- |Return the current value stored in a TVar
readTVar :: TVar a -> STM a
readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
tryTakeMVar :: MVar a -> IO (Maybe a)
tryTakeMVar (MVar m) = IO $ \ s ->
case tryTakeMVar# m s of
- (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty
- (# s, _, a #) -> (# s, Just a #) -- MVar is full
+ (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty
+ (# s', _, a #) -> (# s', Just a #) -- MVar is full
-- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
-- attempts to put the value @a@ into the 'MVar', returning 'True' if
-- "System.Mem.Weak" for more about finalizers.
addMVarFinalizer :: MVar a -> IO () -> IO ()
addMVarFinalizer (MVar m) finalizer =
- IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
+ IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }
withMVar :: MVar a -> (a -> IO b) -> IO b
withMVar m io =
block $ do
a <- takeMVar m
- b <- catchException (unblock (io a))
+ b <- catchAny (unblock (io a))
(\e -> do putMVar m a; throw e)
putMVar m a
return b
asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
IO $ \s -> case asyncRead# fd isSock len buf s of
- (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
+ (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
IO $ \s -> case asyncWrite# fd isSock len buf s of
- (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
+ (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
asyncDoProc (FunPtr proc) (Ptr param) =
-- the 'length' value is ignored; simplifies implementation of
-- the async*# primops to have them all return the same result.
IO $ \s -> case asyncDoProc# proc param s of
- (# s, len#, err# #) -> (# s, I# err# #)
+ (# s', _len#, err# #) -> (# s', I# err# #)
-- to aid the use of these primops by the IO Handle implementation,
-- provide the following convenience funs:
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
- case waitRead# fd# s of { s -> (# s, () #)
+ case waitRead# fd# s of { s' -> (# s', () #)
}}
-- | Block the current thread until data can be written to the
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
- case waitWrite# fd# s of { s -> (# s, () #)
+ case waitWrite# fd# s of { s' -> (# s', () #)
}}
-- | Suspends the current thread for a given number of microseconds
| threaded = waitForDelayEvent time
| otherwise = IO $ \s ->
case fromIntegral time of { I# time# ->
- case delay# time# s of { s -> (# s, () #)
+ case delay# time# s of { s' -> (# s', () #)
}}
case r of
0xffffffff -> do c_maperrno; throwErrno "service_loop"
0 -> do
- r <- c_readIOManagerEvent
+ r2 <- c_readIOManagerEvent
exit <-
- case r of
- _ | r == io_MANAGER_WAKEUP -> return False
- _ | r == io_MANAGER_DIE -> return True
+ case r2 of
+ _ | r2 == io_MANAGER_WAKEUP -> return False
+ _ | r2 == io_MANAGER_DIE -> return True
0 -> return False -- spurious wakeup
- r -> do start_console_handler (r `shiftR` 1); return False
+ _ -> do start_console_handler (r2 `shiftR` 1); return False
if exit
then return ()
else service_cont wakeup delays'
_other -> service_cont wakeup delays' -- probably timeout
+service_cont :: HANDLE -> [DelayReq] -> IO ()
service_cont wakeup delays = do
atomicModifyIORef prodding (\_ -> (False,False))
service_loop wakeup delays
-- must agree with rts/win32/ThrIOManager.c
-io_MANAGER_WAKEUP = 0xffffffff :: Word32
-io_MANAGER_DIE = 0xfffffffe :: Word32
+io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
+io_MANAGER_WAKEUP = 0xffffffff
+io_MANAGER_DIE = 0xfffffffe
data ConsoleEvent
= ControlC
return ()
Nothing -> return ()
+toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
toWin32ConsoleEvent ev =
case ev of
0 {- CTRL_C_EVENT-} -> Just ControlC
win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
+-- XXX Is this actually needed?
stick :: IORef HANDLE
{-# NOINLINE stick #-}
stick = unsafePerformIO (newIORef nullPtr)
+wakeupIOManager :: IO ()
wakeupIOManager = do
- hdl <- readIORef stick
+ _hdl <- readIORef stick
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 now [] = return ([], iNFINITE)
+getDelay _ [] = return ([], iNFINITE)
getDelay now all@(d : rest)
= case d of
Delay time m | now >= time -> do
type HANDLE = Ptr ()
type DWORD = Word32
-iNFINITE = 0xFFFFFFFF :: DWORD -- urgh
+iNFINITE :: DWORD
+iNFINITE = 0xFFFFFFFF -- urgh
foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
c_getIOManagerEvent :: IO HANDLE
-- pick up new delay requests
new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
- let delays = foldr insertDelay old_delays new_delays
+ let delays0 = foldr insertDelay old_delays new_delays
-- build the FDSets for select()
fdZero readfds
else
return (False,delays')
- (wakeup_all,delays') <- do_select delays
+ (wakeup_all,delays') <- do_select delays0
exit <-
if wakeup_all then return False
service_loop wakeup readfds writefds ptimeval reqs' delays'
-io_MANAGER_WAKEUP = 0xff :: CChar
-io_MANAGER_DIE = 0xfe :: CChar
+io_MANAGER_WAKEUP, io_MANAGER_DIE :: CChar
+io_MANAGER_WAKEUP = 0xff
+io_MANAGER_DIE = 0xfe
stick :: IORef Fd
{-# NOINLINE stick #-}
-- -----------------------------------------------------------------------------
-- IO requests
-buildFdSets maxfd readfds writefds [] = return maxfd
-buildFdSets maxfd readfds writefds (Read fd m : reqs)
+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 m : 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
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 fd m : reqs) = do putMVar m (); wakeupAll reqs
-wakeupAll (Write fd m : reqs) = do putMVar m (); wakeupAll reqs
+wakeupAll (Read _ m : reqs) = do putMVar m (); wakeupAll reqs
+wakeupAll (Write _ m : reqs) = do putMVar m (); wakeupAll reqs
waitForReadEvent :: Fd -> IO ()
waitForReadEvent fd = do
-- 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 now ptimeval [] = return ([],nullPtr)
+getDelay _ _ [] = return ([],nullPtr)
getDelay now ptimeval all@(d : rest)
= case d of
Delay time m | now >= time -> do
setTimevalTicks ptimeval (delayTime d - now)
return (all,ptimeval)
-newtype CTimeVal = CTimeVal ()
+data CTimeVal
foreign import ccall unsafe "sizeofTimeVal"
sizeofTimeVal :: Int
-- ToDo: move to System.Posix.Internals?
-newtype CFdSet = CFdSet ()
+data CFdSet
foreign import ccall safe "select"
c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
fD_SETSIZE :: Fd
fD_SETSIZE = fromIntegral c_fD_SETSIZE
-foreign import ccall unsafe "hsFD_CLR"
- c_fdClr :: CInt -> Ptr CFdSet -> IO ()
-
-fdClr :: Fd -> Ptr CFdSet -> IO ()
-fdClr (Fd fd) fdset = c_fdClr fd fdset
-
foreign import ccall unsafe "hsFD_ISSET"
c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
#endif
+reportStackOverflow :: IO a
+reportStackOverflow = do callStackOverflowHook; return undefined
+
+reportError :: SomeException -> IO a
+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.
+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
\end{code}