Ticket #7216: expose-threadWaitSTM-on-master.2.patch

File expose-threadWaitSTM-on-master.2.patch, 6.3 KB (added by AndreasVoellmy, 3 years ago)
  • Control/Concurrent.hs

    From 7d63ab7d01013a11654df796f6bbbf5cb3452105 Mon Sep 17 00:00:00 2001
    From: Andreas Voellmy <[email protected]>
    Date: Sun, 30 Dec 2012 22:11:56 +0100
    Subject: [PATCH] Expose new threadWaitSTM functions in Control.Concurrent
     (see #7216).
    
    Includes support for threadWaitReadSTM and threadWaitWriteSTM on Windows with the threaded runtime system.
    ---
     Control/Concurrent.hs |   50 ++++++++++++++++++++++++++++++++++++++++++++++++-
     GHC/Conc.lhs          |    2 ++
     GHC/Conc/IO.hs        |   43 ++++++++++++++++++++++++++++++++++++++++++
     3 files changed, 94 insertions(+), 1 deletion(-)
    
    diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
    index 100ccc5..11b1ceb 100644
    a b module Control.Concurrent ( 
    6666        threadDelay,
    6767        threadWaitRead,
    6868        threadWaitWrite,
     69        threadWaitReadSTM,
     70        threadWaitWriteSTM,
    6971#endif
    7072
    7173        -- * Communication abstractions
    import Control.Exception.Base as Exception 
    116118
    117119#ifdef __GLASGOW_HASKELL__
    118120import GHC.Exception
    119 import GHC.Conc hiding (threadWaitRead, threadWaitWrite)
     121import GHC.Conc hiding (threadWaitRead, threadWaitWrite,
     122                        threadWaitReadSTM, threadWaitWriteSTM)
    120123import qualified GHC.Conc
    121124import GHC.IO           ( IO(..), unsafeInterleaveIO, unsafeUnmask )
    122125import GHC.IORef        ( newIORef, readIORef, writeIORef )
    import Control.Monad ( when ) 
    130133#ifdef mingw32_HOST_OS
    131134import Foreign.C
    132135import System.IO
     136import Data.Maybe (Maybe(..))
    133137#endif
    134138#endif
    135139
    threadWaitWrite fd 
    448452  = GHC.Conc.threadWaitWrite fd
    449453#endif
    450454
     455-- | Returns an STM action that can be used to wait for data
     456-- to read from a file descriptor. The second returned value
     457-- is an IO action that can be used to deregister interest
     458-- in the file descriptor.
     459threadWaitReadSTM :: Fd -> IO (STM (), IO ())
     460threadWaitReadSTM fd
     461#ifdef mingw32_HOST_OS
     462  | threaded = do v <- newTVarIO Nothing
     463                  mask_ $ forkIO $ do result <- try (waitFd fd 1)
     464                                      atomically (writeTVar v $ Just result)
     465                  let waitAction = do result <- readTVar v
     466                                      case result of
     467                                        Nothing         -> retry
     468                                        Just (Right ()) -> return ()
     469                                        Just (Left e)   -> throwSTM e
     470                  let killAction = return ()
     471                  return (waitAction, killAction)
     472  | otherwise = error "threadWaitReadSTM requires -threaded on Windows"
     473#else
     474  = GHC.Conc.threadWaitReadSTM fd
     475#endif
     476
     477-- | Returns an STM action that can be used to wait until data
     478-- can be written to a file descriptor. The second returned value
     479-- is an IO action that can be used to deregister interest
     480-- in the file descriptor.
     481threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
     482threadWaitWriteSTM fd
     483#ifdef mingw32_HOST_OS
     484  | threaded = do v <- newTVarIO Nothing
     485                  mask_ $ forkIO $ do result <- try (waitFd fd 1)
     486                                      atomically (writeTVar v $ Just result)
     487                  let waitAction = do result <- readTVar v
     488                                      case result of
     489                                        Nothing         -> retry
     490                                        Just (Right ()) -> return ()
     491                                        Just (Left e)   -> throwSTM e
     492                  let killAction = return ()
     493                  return (waitAction, killAction)
     494  | otherwise = error "threadWaitWriteSTM requires -threaded on Windows"
     495#else
     496  = GHC.Conc.threadWaitWriteSTM fd
     497#endif
     498
    451499#ifdef mingw32_HOST_OS
    452500foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
    453501
  • GHC/Conc.lhs

    diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
    index 914db3f..f5fb275 100644
    a b module GHC.Conc 
    6262        , registerDelay
    6363        , threadWaitRead
    6464        , threadWaitWrite
     65        , threadWaitReadSTM
     66        , threadWaitWriteSTM
    6567        , closeFdWith
    6668
    6769        -- * TVars
  • GHC/Conc/IO.hs

    diff --git a/GHC/Conc/IO.hs b/GHC/Conc/IO.hs
    index 94a63a9..4a0c083 100644
    a b module GHC.Conc.IO 
    3838        , registerDelay
    3939        , threadWaitRead
    4040        , threadWaitWrite
     41        , threadWaitReadSTM
     42        , threadWaitWriteSTM
    4143        , closeFdWith
    4244
    4345#ifdef mingw32_HOST_OS
    module GHC.Conc.IO 
    5456#endif
    5557        ) where
    5658
     59import Data.Maybe (Maybe(..), maybe)
    5760import Foreign
    5861import GHC.Base
    5962import GHC.Conc.Sync as Sync
    threadWaitWrite fd 
    108111        case waitWrite# fd# s of { s' -> (# s', () #)
    109112        }}
    110113
     114-- | Returns an STM action that can be used to wait for data
     115-- to read from a file descriptor. The second returned value
     116-- is an IO action that can be used to deregister interest
     117-- in the file descriptor.
     118threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())
     119threadWaitReadSTM fd
     120#ifndef mingw32_HOST_OS
     121  | threaded  = Event.threadWaitReadSTM fd
     122#endif
     123  | otherwise = do
     124      m <- Sync.newTVarIO Nothing
     125      Sync.forkIO $ do
     126        threadWaitRead fd
     127        Sync.atomically $ Sync.writeTVar m (Just ())
     128      let waitAction = do
     129            e <- Sync.readTVar m
     130            maybe Sync.retry return e
     131      let killAction = return ()
     132      return (waitAction, killAction)
     133
     134-- | Returns an STM action that can be used to wait until data
     135-- can be written to a file descriptor. The second returned value
     136-- is an IO action that can be used to deregister interest
     137-- in the file descriptor.
     138threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
     139threadWaitWriteSTM fd
     140#ifndef mingw32_HOST_OS
     141  | threaded  = Event.threadWaitWriteSTM fd
     142#endif
     143  | otherwise = do
     144      m <- Sync.newTVarIO Nothing
     145      Sync.forkIO $ do
     146        threadWaitWrite fd
     147        Sync.atomically $ Sync.writeTVar m (Just ())
     148      let waitAction = do
     149            e <- Sync.readTVar m
     150            maybe Sync.retry return e
     151      let killAction = return ()
     152      return (waitAction, killAction)
     153
    111154-- | Close a file descriptor in a concurrency-safe way (GHC only).  If
    112155-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
    113156-- blocking I\/O, you /must/ use this function to close file