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

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

    From 7b339bec17d6a9b4a9882346873edd8c203d8ad5 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).
    
    Supports threadWaitReadSTM and threadWaitWriteSTM on Windows with the threaded runtime system.
    ---
     Control/Concurrent.hs |   50 ++++++++++++++++++++++++++++++++++++++++++++++++-
     GHC/Conc.lhs          |    2 ++
     GHC/Conc/IO.hs        |   40 +++++++++++++++++++++++++++++++++++++++
     3 files changed, 91 insertions(+), 1 deletion(-)
    
    diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
    index 100ccc5..3733a07 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 0)
     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..a99b334 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
    threadWaitWrite fd 
    108110        case waitWrite# fd# s of { s' -> (# s', () #)
    109111        }}
    110112
     113-- | Returns an STM action that can be used to wait for data
     114-- to read from a file descriptor. The second returned value
     115-- is an IO action that can be used to deregister interest
     116-- in the file descriptor.
     117threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())
     118threadWaitReadSTM fd
     119#ifndef mingw32_HOST_OS
     120  | threaded  = Event.threadWaitReadSTM fd
     121#endif
     122  | otherwise = do
     123      m <- Sync.newTVarIO False
     124      Sync.forkIO $ do
     125        threadWaitRead fd
     126        Sync.atomically $ Sync.writeTVar m True
     127      let waitAction = do b <- Sync.readTVar m
     128                          if b then return () else retry
     129      let killAction = return ()
     130      return (waitAction, killAction)
     131
     132-- | Returns an STM action that can be used to wait until data
     133-- can be written to a file descriptor. The second returned value
     134-- is an IO action that can be used to deregister interest
     135-- in the file descriptor.
     136threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
     137threadWaitWriteSTM fd
     138#ifndef mingw32_HOST_OS
     139  | threaded  = Event.threadWaitWriteSTM fd
     140#endif
     141  | otherwise = do
     142      m <- Sync.newTVarIO False
     143      Sync.forkIO $ do
     144        threadWaitWrite fd
     145        Sync.atomically $ Sync.writeTVar m True
     146      let waitAction = do b <- Sync.readTVar m
     147                          if b then return () else retry
     148      let killAction = return ()
     149      return (waitAction, killAction)
     150
    111151-- | Close a file descriptor in a concurrency-safe way (GHC only).  If
    112152-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
    113153-- blocking I\/O, you /must/ use this function to close file