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

File expose-threadWaitSTM-on-master.4.patch, 6.1 KB (added by AndreasVoellmy, 2 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