-{-# INLINE par #-}
-par :: a -> b -> b
-par x y = case (par# x) of { _ -> lazy y }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[stm]{Transactional heap operations}
-%* *
-%************************************************************************
-
-TVars are shared memory locations which support atomic memory
-transactions.
-
-\begin{code}
--- |A monad supporting atomic memory transactions.
-newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
-
-unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
-unSTM (STM a) = a
-
-INSTANCE_TYPEABLE1(STM,stmTc,"STM")
-
-instance Functor STM where
- fmap f x = x >>= (return . f)
-
-instance Monad STM where
- {-# INLINE return #-}
- {-# INLINE (>>) #-}
- {-# INLINE (>>=) #-}
- m >> k = thenSTM m k
- return x = returnSTM x
- m >>= k = bindSTM m k
-
-bindSTM :: STM a -> (a -> STM b) -> STM b
-bindSTM (STM m) k = STM ( \s ->
- case m s of
- (# new_s, a #) -> unSTM (k a) new_s
- )
-
-thenSTM :: STM a -> STM b -> STM b
-thenSTM (STM m) k = STM ( \s ->
- case m s of
- (# new_s, a #) -> unSTM k new_s
- )
-
-returnSTM :: a -> STM a
-returnSTM x = STM (\s -> (# s, x #))
-
--- | Unsafely performs IO in the STM monad.
-unsafeIOToSTM :: IO a -> STM a
-unsafeIOToSTM (IO m) = STM m
-
--- |Perform a series of STM actions atomically.
---
--- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
--- Any attempt to do so will result in a runtime error. (Reason: allowing
--- this would effectively allow a transaction inside a transaction, depending
--- on exactly when the thunk is evaluated.)
---
--- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
--- and which allows top-level TVars to be allocated.
-
-atomically :: STM a -> IO a
-atomically (STM m) = IO (\s -> (atomically# m) s )
-
--- |Retry execution of the current memory transaction because it has seen
--- values in TVars which mean that it should not continue (e.g. the TVars
--- represent a shared buffer that is now empty). The implementation may
--- block the thread until one of the TVars that it has read from has been
--- udpated. (GHC only)
-retry :: STM a
-retry = STM $ \s# -> retry# s#
-
--- |Compose two alternative STM actions (GHC only). If the first action
--- completes without retrying then it forms the result of the orElse.
--- Otherwise, if the first action retries, then the second action is
--- tried in its place. If both actions retry then the orElse as a
--- whole retries.
-orElse :: STM a -> STM a -> STM a
-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 m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
-
--- | Low-level primitive on which always and alwaysSucceeds are built.
--- checkInv differs form these in that (i) the invariant is not
--- checked when checkInv is called, only at the end of this and
--- subsequent transcations, (ii) the invariant failure is indicated
--- by raising an exception.
-checkInv :: STM a -> STM ()
-checkInv (STM m) = STM (\s -> (check# m) s)
-
--- | alwaysSucceeds adds a new invariant that must be true when passed
--- to alwaysSucceeds, at the end of the current transaction, and at
--- the end of every subsequent transaction. If it fails at any
--- 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 () )
- checkInv i
-
--- | always is a variant of alwaysSucceeds in which the invariant is
--- expressed as an STM Bool action that must return True. Returning
--- False or raising an exception are both treated as invariant failures.
-always :: STM Bool -> STM ()
-always i = alwaysSucceeds ( do v <- i
- if (v) then return () else ( error "Transacional invariant violation" ) )
-
--- |Shared memory locations that support atomic memory transactions.
-data TVar a = TVar (TVar# RealWorld a)
-
-INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
-
-instance Eq (TVar a) where
- (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
-
--- |Create a new TVar holding a value supplied
-newTVar :: a -> STM (TVar a)
-newTVar val = STM $ \s1# ->
- case newTVar# val s1# of
- (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
-
--- |@IO@ version of 'newTVar'. This is useful for creating top-level
--- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
--- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
--- possible.
-newTVarIO :: a -> IO (TVar a)
-newTVarIO val = IO $ \s1# ->
- case newTVar# val s1# of
- (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
-
--- |Return the current value stored in a TVar
-readTVar :: TVar a -> STM a
-readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
-
--- |Write the supplied value into a TVar
-writeTVar :: TVar a -> a -> STM ()
-writeTVar (TVar tvar#) val = STM $ \s1# ->
- case writeTVar# tvar# val s1# of
- s2# -> (# s2#, () #)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[mvars]{M-Structures}
-%* *
-%************************************************************************
-
-M-Vars are rendezvous points for concurrent threads. They begin
-empty, and any attempt to read an empty M-Var blocks. When an M-Var
-is written, a single blocked thread may be freed. Reading an M-Var
-toggles its state from full back to empty. Therefore, any value
-written to an M-Var may only be read once. Multiple reads and writes
-are allowed, but there must be at least one read between any two
-writes.
-
-\begin{code}
---Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
-
--- |Create an 'MVar' which is initially empty.
-newEmptyMVar :: IO (MVar a)
-newEmptyMVar = IO $ \ s# ->
- case newMVar# s# of
- (# s2#, svar# #) -> (# s2#, MVar svar# #)
-
--- |Create an 'MVar' which contains the supplied value.
-newMVar :: a -> IO (MVar a)
-newMVar value =
- newEmptyMVar >>= \ mvar ->
- putMVar mvar value >>
- return mvar
-
--- |Return the contents of the 'MVar'. If the 'MVar' is currently
--- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
--- the 'MVar' is left empty.
---
--- There are two further important properties of 'takeMVar':
---
--- * 'takeMVar' is single-wakeup. That is, if there are multiple
--- threads blocked in 'takeMVar', and the 'MVar' becomes full,
--- only one thread will be woken up. The runtime guarantees that
--- the woken thread completes its 'takeMVar' operation.
---
--- * When multiple threads are blocked on an 'MVar', they are
--- woken up in FIFO order. This is useful for providing
--- fairness properties of abstractions built using 'MVar's.
---
-takeMVar :: MVar a -> IO a
-takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
-
--- |Put a value into an 'MVar'. If the 'MVar' is currently full,
--- 'putMVar' will wait until it becomes empty.
---
--- There are two further important properties of 'putMVar':
---
--- * 'putMVar' is single-wakeup. That is, if there are multiple
--- threads blocked in 'putMVar', and the 'MVar' becomes empty,
--- only one thread will be woken up. The runtime guarantees that
--- the woken thread completes its 'putMVar' operation.
---
--- * When multiple threads are blocked on an 'MVar', they are
--- woken up in FIFO order. This is useful for providing
--- fairness properties of abstractions built using 'MVar's.
---
-putMVar :: MVar a -> a -> IO ()
-putMVar (MVar mvar#) x = IO $ \ s# ->
- case putMVar# mvar# x s# of
- s2# -> (# s2#, () #)
-
--- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
--- returns immediately, with 'Nothing' if the 'MVar' was empty, or
--- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
--- the 'MVar' is left empty.
-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
-
--- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
--- attempts to put the value @a@ into the 'MVar', returning 'True' if
--- it was successful, or 'False' otherwise.
-tryPutMVar :: MVar a -> a -> IO Bool
-tryPutMVar (MVar mvar#) x = IO $ \ s# ->
- case tryPutMVar# mvar# x s# of
- (# s, 0# #) -> (# s, False #)
- (# s, _ #) -> (# s, True #)
-
--- |Check whether a given 'MVar' is empty.
---
--- Notice that the boolean value returned is just a snapshot of
--- the state of the MVar. By the time you get to react on its result,
--- the MVar may have been filled (or emptied) - so be extremely
--- careful when using this operation. Use 'tryTakeMVar' instead if possible.
-isEmptyMVar :: MVar a -> IO Bool
-isEmptyMVar (MVar mv#) = IO $ \ s# ->
- case isEmptyMVar# mv# s# of
- (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
-
--- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
--- "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, () #) }
-
-withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io =
- block $ do
- a <- takeMVar m
- b <- catchException (unblock (io a))
- (\e -> do putMVar m a; throw e)
- putMVar m a
- return b
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Thread waiting}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef mingw32_HOST_OS
-
--- Note: threadWaitRead and threadWaitWrite aren't really functional
--- on Win32, but left in there because lib code (still) uses them (the manner
--- in which they're used doesn't cause problems on a Win32 platform though.)
-
-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#) #)
-
-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#) #)
-
-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# #)
-
--- to aid the use of these primops by the IO Handle implementation,
--- provide the following convenience funs:
-
--- this better be a pinned byte array!
-asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
-asyncReadBA fd isSock len off bufB =
- asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
-
-asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
-asyncWriteBA fd isSock len off bufB =
- asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
-
-#endif
-
--- -----------------------------------------------------------------------------
--- Thread IO API
-
--- | Block the current thread until data is available to read on the
--- given file descriptor (GHC only).
-threadWaitRead :: Fd -> IO ()
-threadWaitRead fd
-#ifndef mingw32_HOST_OS
- | threaded = waitForReadEvent fd
-#endif
- | 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.
-
--- Issues, possible problems:
---
--- - we might want bound threads to just do the blocking
--- operation rather than communicating with the IO manager
--- thread. This would prevent simgle-threaded programs which do
--- IO from requiring multiple OS threads. However, it would also
--- prevent bound threads waiting on IO from being killed or sent
--- exceptions.
---
--- - Apprently exec() doesn't work on Linux in a multithreaded program.
--- I couldn't repeat this.
---
--- - How do we handle signal delivery in the multithreaded RTS?
---
--- - forkProcess will kill the IO manager thread. Let's just
--- hope we don't need to do any blocking IO between fork & exec.
-
-#ifndef mingw32_HOST_OS
-data IOReq
- = Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
- | Write {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
-#endif