Ticket #7216: threadWaitSTM.patch

File threadWaitSTM.patch, 5.4 KB (added by AndreasVoellmy, 3 years ago)

Return an unregistration function with the threadWait*STM functions; added some haddock comments.

  • GHC/Event/Thread.hs

    From dedd802749c8002ff24504727d81d2c0f7f5ab52 Mon Sep 17 00:00:00 2001
    From: Andreas Voellmy <[email protected]>
    Date: Tue, 28 Aug 2012 23:44:30 -0400
    Subject: [PATCH 1/2] Added threadWait functions to wait on FD readiness with
     STM actions.
    
    ---
     GHC/Event/Thread.hs |   28 +++++++++++++++++++++++++++-
     1 file changed, 27 insertions(+), 1 deletion(-)
    
    diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
    index 2643950..794f01e 100644
    a b module GHC.Event.Thread 
    66    , ensureIOManagerIsRunning
    77    , threadWaitRead
    88    , threadWaitWrite
     9    , threadWaitReadSTM
     10    , threadWaitWriteSTM
    911    , closeFdWith
    1012    , threadDelay
    1113    , registerDelay
    import Foreign.Ptr (Ptr) 
    1820import GHC.Base
    1921import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
    2022                      labelThread, modifyMVar_, newTVar, sharedCAF,
    21                       threadStatus, writeTVar)
     23                      threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM)
    2224import GHC.IO (mask_, onException)
    2325import GHC.IO.Exception (ioError)
    2426import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
    threadWait evt fd = mask_ $ do 
    9496    then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
    9597    else return ()
    9698
     99
     100threadWaitSTM :: Event -> Fd -> IO (STM ())
     101threadWaitSTM evt fd = mask_ $ do
     102  m <- newTVarIO Nothing
     103  Just mgr <- getSystemEventManager
     104  registerFd mgr (\reg e -> unregisterFd_ mgr reg >> atomically (writeTVar m (Just e))) fd evt
     105  return (do mevt <- readTVar m
     106             case mevt of
     107               Nothing -> retry
     108               Just evt ->
     109                 if evt `eventIs` evtClose
     110                 then throwSTM $ errnoToIOError "threadWait" eBADF Nothing Nothing
     111                 else return ()
     112         )
     113
     114threadWaitReadSTM :: Fd -> IO (STM ())
     115threadWaitReadSTM = threadWaitSTM evtRead
     116{-# INLINE threadWaitReadSTM #-}
     117
     118threadWaitWriteSTM :: Fd -> IO (STM ())
     119threadWaitWriteSTM = threadWaitSTM evtWrite
     120{-# INLINE threadWaitWriteSTM #-}
     121
     122
    97123-- | Retrieve the system event manager.
    98124--
    99125-- This function always returns 'Just' the system event manager when using the
  • GHC/Event/Thread.hs

    -- 
    1.7.10.2 (Apple Git-33)
    
    
    From cb37f8bdeda63057273d95a52a06d4d2fd779b29 Mon Sep 17 00:00:00 2001
    From: Andreas Voellmy <[email protected]>
    Date: Wed, 17 Oct 2012 11:02:12 -0400
    Subject: [PATCH 2/2] Added the unregistration command to the return value of
     threadWait*STM functions.
    
    This allows the calling thread to unregister interest in the file, e.g. in the case
    of an exception in the thread.
    ---
     GHC/Event/Thread.hs |   43 ++++++++++++++++++++++++++++++-------------
     1 file changed, 30 insertions(+), 13 deletions(-)
    
    diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
    index 794f01e..bca0565 100644
    a b threadWait evt fd = mask_ $ do 
    9797    else return ()
    9898
    9999
    100 threadWaitSTM :: Event -> Fd -> IO (STM ())
     100threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
    101101threadWaitSTM evt fd = mask_ $ do
    102102  m <- newTVarIO Nothing
    103103  Just mgr <- getSystemEventManager
    104   registerFd mgr (\reg e -> unregisterFd_ mgr reg >> atomically (writeTVar m (Just e))) fd evt
    105   return (do mevt <- readTVar m
    106              case mevt of
    107                Nothing -> retry
    108                Just evt ->
    109                  if evt `eventIs` evtClose
    110                  then throwSTM $ errnoToIOError "threadWait" eBADF Nothing Nothing
    111                  else return ()
    112          )
    113 
    114 threadWaitReadSTM :: Fd -> IO (STM ())
     104  reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> atomically (writeTVar m (Just e))) fd evt
     105  let waitAction =
     106        do mevt <- readTVar m
     107           case mevt of
     108             Nothing -> retry
     109             Just evt ->
     110               if evt `eventIs` evtClose
     111               then throwSTM $ errnoToIOError "threadWaitSTM" eBADF Nothing Nothing
     112               else return ()
     113  return (waitAction, unregisterFd_ mgr reg >> return ())
     114
     115-- | Allows a thread to use an STM action to wait for a file descriptor to be readable.
     116-- The STM action will retry until the file descriptor has data ready.
     117-- The second element of the return value pair is an IO action that can be used
     118-- to deregister interest in the file descriptor.
     119--
     120-- The STM action will throw an 'IOError' if the file descriptor was closed
     121-- while the STM action is being executed.  To safely close a file descriptor
     122-- that has been used with 'threadWaitReadSTM', use 'closeFdWith'.
     123threadWaitReadSTM :: Fd -> IO (STM (), IO ())
    115124threadWaitReadSTM = threadWaitSTM evtRead
    116125{-# INLINE threadWaitReadSTM #-}
    117126
    118 threadWaitWriteSTM :: Fd -> IO (STM ())
     127-- | Allows a thread to use an STM action to wait until a file descriptor can accept a write.
     128-- The STM action will retry while the file until the given file descriptor can accept a write.
     129-- The second element of the return value pair is an IO action that can be used to deregister
     130-- interest in the file descriptor.
     131--
     132-- The STM action will throw an 'IOError' if the file descriptor was closed
     133-- while the STM action is being executed.  To safely close a file descriptor
     134-- that has been used with 'threadWaitWriteSTM', use 'closeFdWith'.
     135threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
    119136threadWaitWriteSTM = threadWaitSTM evtWrite
    120137{-# INLINE threadWaitWriteSTM #-}
    121138