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

File expose-threadWaitSTM-on-master.3.patch, 6.3 KB (added by AndreasVoellmy, 5 months ago)

  • Control/Concurrent.hs 

    From 8e516baa061c9572f77ad51e5c57e302b6b80c5d Mon Sep 17 00:00:00 2001
From: Andreas Voellmy <andreas.voellmy@gmail.com>
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        |   43 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 94 insertions(+), 1 deletion(-)

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 100ccc5..3733a07 100644
    a b  
    6666        threadDelay, 
    6767        threadWaitRead, 
    6868        threadWaitWrite, 
     69        threadWaitReadSTM, 
     70        threadWaitWriteSTM, 
    6971#endif 
    7072 
    7173        -- * Communication abstractions 
    … …  
    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 ) 
    … …  
    130133#ifdef mingw32_HOST_OS 
    131134import Foreign.C 
    132135import System.IO 
     136import Data.Maybe (Maybe(..)) 
    133137#endif 
    134138#endif 
    135139 
    … …  
    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  
    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  
    3838        , registerDelay 
    3939        , threadWaitRead 
    4040        , threadWaitWrite 
     41        , threadWaitReadSTM 
     42        , threadWaitWriteSTM 
    4143        , closeFdWith 
    4244 
    4345#ifdef mingw32_HOST_OS 
    … …  
    5456#endif 
    5557        ) where 
    5658 
     59import Data.Maybe (Maybe(..), maybe) 
    5760import Foreign 
    5861import GHC.Base 
    5962import GHC.Conc.Sync as Sync 
    … …  
    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