[Git][ghc/ghc][wip/peer-closed] 2 commits: base/event: Add supportedEvents
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Thu Sep 21 12:57:46 UTC 2023
Ben Gamari pushed to branch wip/peer-closed at Glasgow Haskell Compiler / GHC
Commits:
60a52fc0 by Ben Gamari at 2023-09-21T08:56:42-04:00
base/event: Add supportedEvents
- - - - -
34112e96 by Ben Gamari at 2023-09-21T08:57:23-04:00
base: Introduce evtPeerClosed
As described in #23825, some platforms (currently just Linux via epoll)
expose events which notify socket users when their peer has closed the
read side of their connection. Expose such events through the event
manager as `evtPeerClosed`.
- - - - -
9 changed files:
- libraries/base/GHC/Event.hs
- libraries/base/GHC/Event/EPoll.hsc
- libraries/base/GHC/Event/Internal.hs
- libraries/base/GHC/Event/Internal/Types.hs
- libraries/base/GHC/Event/KQueue.hsc
- libraries/base/GHC/Event/Manager.hs
- libraries/base/GHC/Event/Poll.hsc
- libraries/base/GHC/Event/Thread.hs
- testsuite/tests/interface-stability/base-exports.stdout
Changes:
=====================================
libraries/base/GHC/Event.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Event
, Event
, evtRead
, evtWrite
+ , evtPeerClosed
, IOCallback
, FdKey(keyFd)
, Lifetime(..)
=====================================
libraries/base/GHC/Event/EPoll.hsc
=====================================
@@ -69,8 +69,10 @@ new :: IO E.Backend
new = do
epfd <- epollCreate
evts <- A.new 64
- let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts)
+ let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts) supportedEvents
return be
+ where
+ supportedEvents = evtRead <> evtWrite <> evtClose <> evtPeerClosed
delete :: EPoll -> IO ()
delete be = do
@@ -172,6 +174,7 @@ newtype EventType = EventType {
, epollErr = EPOLLERR
, epollHup = EPOLLHUP
, epollOneShot = EPOLLONESHOT
+ , epollRdHup = EPOLLRDHUP
}
-- | Create a new epoll context, returning a file descriptor associated with the context.
@@ -212,14 +215,16 @@ epollWaitNonBlock (EPollFd epfd) events numEvents =
fromEvent :: E.Event -> EventType
fromEvent e = remap E.evtRead epollIn .|.
- remap E.evtWrite epollOut
+ remap E.evtWrite epollOut .|.
+ remap E.evtPeerClosed epollRdHup
where remap evt to
| e `E.eventIs` evt = to
| otherwise = 0
toEvent :: EventType -> E.Event
toEvent e = remap (epollIn .|. epollErr .|. epollHup) E.evtRead `mappend`
- remap (epollOut .|. epollErr .|. epollHup) E.evtWrite
+ remap (epollOut .|. epollErr .|. epollHup) E.evtWrite `mappend`
+ remap (epollRdHup) E.evtPeerClosed
where remap evt to
| e .&. evt /= 0 = to
| otherwise = mempty
=====================================
libraries/base/GHC/Event/Internal.hs
=====================================
@@ -55,6 +55,7 @@ data Backend = forall a. Backend {
-> IO Bool
, _beDelete :: a -> IO ()
+ , _beSupportedEvents :: !Event
}
backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
@@ -62,31 +63,40 @@ backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (a -> Fd -> Event -> IO Bool)
-> (a -> IO ())
-> a
+ -> Event
-> Backend
-backend bPoll bModifyFd bModifyFdOnce bDelete state =
- Backend state bPoll bModifyFd bModifyFdOnce bDelete
+backend bPoll bModifyFd bModifyFdOnce bDelete state supportedEvents =
+ Backend state bPoll bModifyFd bModifyFdOnce bDelete supportedEvents
{-# INLINE backend #-}
poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
-poll (Backend bState bPoll _ _ _) = bPoll bState
+poll (Backend bState bPoll _ _ _ _) = bPoll bState
{-# INLINE poll #-}
-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
-modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
+modifyFd (Backend bState _ bModifyFd _ _ sup) fd old new
+ | sup `isEvent` new
+ = bModifyFd bState fd old new
+ | otherwise
+ = ioError unsupportedOperation
{-# INLINE modifyFd #-}
-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
-modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
+modifyFdOnce (Backend bState _ _ bModifyFdOnce _ sup) fd ev
+ | sup `isEvent` ev
+ = bModifyFdOnce bState
+ | otherwise
+ = ioError unsupportedOperation
{-# INLINE modifyFdOnce #-}
delete :: Backend -> IO ()
-delete (Backend bState _ _ _ bDelete) = bDelete bState
+delete (Backend bState _ _ _ bDelete _) = bDelete bState
{-# INLINE delete #-}
-- | Throw an 'Prelude.IOError' corresponding to the current value of
=====================================
libraries/base/GHC/Event/Internal/Types.hs
=====================================
@@ -21,6 +21,7 @@ module GHC.Event.Internal.Types
, evtRead
, evtWrite
, evtClose
+ , evtPeerClosed
, evtNothing
, eventIs
-- * Lifetimes
@@ -65,6 +66,13 @@ evtClose :: Event
evtClose = Event 4
{-# INLINE evtClose #-}
+-- | The peer of a socket has closed the read side of its connection.
+--
+-- @since 4.19.0.0
+evtPeerClosed :: Event
+evtPeerClosed = Event 8
+{-# INLINE evtPeerClosed #-}
+
eventIs :: Event -> Event -> Bool
eventIs (Event a) (Event b) = a .&. b /= 0
@@ -73,7 +81,9 @@ instance Show Event where
show e = '[' : (intercalate "," . filter (not . null) $
[evtRead `so` "evtRead",
evtWrite `so` "evtWrite",
- evtClose `so` "evtClose"]) ++ "]"
+ evtClose `so` "evtClose",
+ evtPeerClosed `so` "evtPeerClosed"
+ ]) ++ "]"
where ev `so` disp | e `eventIs` ev = disp
| otherwise = ""
@@ -143,15 +153,15 @@ eventLifetime :: Event -> Lifetime -> EventLifetime
eventLifetime (Event e) l = EL (e .|. lifetimeBit l)
where
lifetimeBit OneShot = 0
- lifetimeBit MultiShot = 8
+ lifetimeBit MultiShot = 16
{-# INLINE eventLifetime #-}
elLifetime :: EventLifetime -> Lifetime
-elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot
+elLifetime (EL x) = if x .&. 16 == 0 then OneShot else MultiShot
{-# INLINE elLifetime #-}
elEvent :: EventLifetime -> Event
-elEvent (EL x) = Event (x .&. 0x7)
+elEvent (EL x) = Event (x .&. 0xf)
{-# INLINE elEvent #-}
-- | A type alias for timeouts, specified in nanoseconds.
=====================================
libraries/base/GHC/Event/KQueue.hsc
=====================================
@@ -79,8 +79,10 @@ new :: IO E.Backend
new = do
kqfd <- kqueue
events <- A.new 64
- let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)
+ let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events) supportedEvents
return be
+ where
+ supportedEvents = evtRead <> evtWrite <> evtClose
delete :: KQueue -> IO ()
delete kq = do
=====================================
libraries/base/GHC/Event/Manager.hs
=====================================
@@ -43,6 +43,7 @@ module GHC.Event.Manager
, Event
, evtRead
, evtWrite
+ , evtPeerClosed
, IOCallback
, FdKey(keyFd)
, FdData
@@ -77,7 +78,8 @@ import GHC.Real (fromIntegral)
import GHC.Show (Show(..))
import GHC.Event.Control
import GHC.Event.IntTable (IntTable)
-import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite,
+import GHC.Event.Internal (Backend,
+ Event, evtClose, evtRead, evtWrite, evtPeerClosed,
Lifetime(..), EventLifetime, Timeout(..))
import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
import System.Posix.Types (Fd)
=====================================
libraries/base/GHC/Event/Poll.hsc
=====================================
@@ -51,8 +51,10 @@ data Poll = Poll {
}
new :: IO E.Backend
-new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM`
+new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) supportedEvents `liftM`
liftM2 Poll (newMVar =<< A.empty) A.empty
+ where
+ supportedEvents = evtRead <> evtWrite <> evtClose
modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool
modifyFd p fd oevt nevt =
=====================================
libraries/base/GHC/Event/Thread.hs
=====================================
@@ -14,8 +14,10 @@ module GHC.Event.Thread
, ioManagerCapabilitiesChanged
, threadWaitRead
, threadWaitWrite
+ , threadWaitPeerClosed
, threadWaitReadSTM
, threadWaitWriteSTM
+ , threadWaitPeerClosedSTM
, closeFdWith
, threadDelay
, registerDelay
@@ -46,8 +48,8 @@ import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray,
import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import GHC.Event.Control (controlWriteFd)
import GHC.Event.Internal (eventIs, evtClose)
-import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
- new, registerFd, unregisterFd_)
+import GHC.Event.Manager (Event, evtRead, evtWrite, evtPeerClosed,
+ loop, EventManager, new, registerFd, unregisterFd_)
import qualified GHC.Event.Manager as M
import qualified GHC.Event.TimerManager as TM
import GHC.Ix (inRange)
@@ -107,6 +109,11 @@ threadWaitWrite :: Fd -> IO ()
threadWaitWrite = threadWait evtWrite
{-# INLINE threadWaitWrite #-}
+-- | Block the current the peer closes their end of the given socket file descriptor.
+threadWaitPeerClosed :: Fd -> IO ()
+threadWaitPeerClosed = threadWait evtPeerClosed
+{-# INLINE threadWaitPeerClosed #-}
+
-- | Close a file descriptor in a concurrency-safe way.
--
-- Any threads that are blocked on the file descriptor via
@@ -207,6 +214,9 @@ threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM = threadWaitSTM evtWrite
{-# INLINE threadWaitWriteSTM #-}
+threadWaitPeerClosedSTM :: Fd -> IO (STM (), IO ())
+threadWaitPeerClosedSTM = threadWaitSTM evtPeerClosed
+{-# INLINE threadWaitPeerClosedSTM #-}
-- | Retrieve the system event manager for the capability on which the
-- calling thread is running.
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -5172,6 +5172,7 @@ module GHC.Event where
type TimerManager :: *
data TimerManager = ...
closeFd :: EventManager -> (System.Posix.Types.Fd -> GHC.Types.IO ()) -> System.Posix.Types.Fd -> GHC.Types.IO ()
+ evtPeerClosed :: Event
evtRead :: Event
evtWrite :: Event
getSystemEventManager :: GHC.Types.IO (GHC.Maybe.Maybe EventManager)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ca59ecf1dbd95566cde3acc92e84b3c9033a467...34112e968ff31ad8d7e6fa4e560ccbdf827a0662
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ca59ecf1dbd95566cde3acc92e84b3c9033a467...34112e968ff31ad8d7e6fa4e560ccbdf827a0662
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230921/c2f2f650/attachment-0001.html>
More information about the ghc-commits
mailing list