diff options
Diffstat (limited to 'libraries/base/GHC/Event')
| -rw-r--r-- | libraries/base/GHC/Event/Internal.hs | 138 | ||||
| -rw-r--r-- | libraries/base/GHC/Event/Thread.hs | 2 | ||||
| -rw-r--r-- | libraries/base/GHC/Event/TimerManager.hs | 16 |
3 files changed, 5 insertions, 151 deletions
diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs index 5778c6f3fe..2ed8d2e66c 100644 --- a/libraries/base/GHC/Event/Internal.hs +++ b/libraries/base/GHC/Event/Internal.hs @@ -10,150 +10,16 @@ module GHC.Event.Internal , poll , modifyFd , modifyFdOnce - -- * Event type - , Event - , evtRead - , evtWrite - , evtClose - , eventIs - -- * Lifetimes - , Lifetime(..) - , EventLifetime - , eventLifetime - , elLifetime - , elEvent - -- * Timeout type - , Timeout(..) + , module GHC.Event.Internal.Types -- * Helpers , throwErrnoIfMinus1NoRetry ) where -import Data.Bits ((.|.), (.&.)) -import Data.OldList (foldl', filter, intercalate, null) import Foreign.C.Error (eINTR, getErrno, throwErrno) import System.Posix.Types (Fd) import GHC.Base -import GHC.Word (Word64) import GHC.Num (Num(..)) -import GHC.Show (Show(..)) -import Data.Semigroup.Internal (stimesMonoid) - --- | An I\/O event. -newtype Event = Event Int - deriving Eq -- ^ @since 4.4.0.0 - -evtNothing :: Event -evtNothing = Event 0 -{-# INLINE evtNothing #-} - --- | Data is available to be read. -evtRead :: Event -evtRead = Event 1 -{-# INLINE evtRead #-} - --- | The file descriptor is ready to accept a write. -evtWrite :: Event -evtWrite = Event 2 -{-# INLINE evtWrite #-} - --- | Another thread closed the file descriptor. -evtClose :: Event -evtClose = Event 4 -{-# INLINE evtClose #-} - -eventIs :: Event -> Event -> Bool -eventIs (Event a) (Event b) = a .&. b /= 0 - --- | @since 4.4.0.0 -instance Show Event where - show e = '[' : (intercalate "," . filter (not . null) $ - [evtRead `so` "evtRead", - evtWrite `so` "evtWrite", - evtClose `so` "evtClose"]) ++ "]" - where ev `so` disp | e `eventIs` ev = disp - | otherwise = "" - --- | @since 4.10.0.0 -instance Semigroup Event where - (<>) = evtCombine - stimes = stimesMonoid - --- | @since 4.4.0.0 -instance Monoid Event where - mempty = evtNothing - mconcat = evtConcat - -evtCombine :: Event -> Event -> Event -evtCombine (Event a) (Event b) = Event (a .|. b) -{-# INLINE evtCombine #-} - -evtConcat :: [Event] -> Event -evtConcat = foldl' evtCombine evtNothing -{-# INLINE evtConcat #-} - --- | The lifetime of an event registration. --- --- @since 4.8.1.0 -data Lifetime = OneShot -- ^ the registration will be active for only one - -- event - | MultiShot -- ^ the registration will trigger multiple times - deriving ( Show -- ^ @since 4.8.1.0 - , Eq -- ^ @since 4.8.1.0 - ) - --- | The longer of two lifetimes. -elSupremum :: Lifetime -> Lifetime -> Lifetime -elSupremum OneShot OneShot = OneShot -elSupremum _ _ = MultiShot -{-# INLINE elSupremum #-} - --- | @since 4.10.0.0 -instance Semigroup Lifetime where - (<>) = elSupremum - stimes = stimesMonoid - --- | @mappend@ takes the longer of two lifetimes. --- --- @since 4.8.0.0 -instance Monoid Lifetime where - mempty = OneShot - --- | A pair of an event and lifetime --- --- Here we encode the event in the bottom three bits and the lifetime --- in the fourth bit. -newtype EventLifetime = EL Int - deriving ( Show -- ^ @since 4.8.0.0 - , Eq -- ^ @since 4.8.0.0 - ) - --- | @since 4.11.0.0 -instance Semigroup EventLifetime where - EL a <> EL b = EL (a .|. b) - --- | @since 4.8.0.0 -instance Monoid EventLifetime where - mempty = EL 0 - -eventLifetime :: Event -> Lifetime -> EventLifetime -eventLifetime (Event e) l = EL (e .|. lifetimeBit l) - where - lifetimeBit OneShot = 0 - lifetimeBit MultiShot = 8 -{-# INLINE eventLifetime #-} - -elLifetime :: EventLifetime -> Lifetime -elLifetime (EL x) = if x .&. 8 == 0 then OneShot else MultiShot -{-# INLINE elLifetime #-} - -elEvent :: EventLifetime -> Event -elEvent (EL x) = Event (x .&. 0x7) -{-# INLINE elEvent #-} - --- | A type alias for timeouts, specified in nanoseconds. -data Timeout = Timeout {-# UNPACK #-} !Word64 - | Forever - deriving Show -- ^ @since 4.4.0.0 +import GHC.Event.Internal.Types -- | Event notification backend. data Backend = forall a. Backend { diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index ad922d73f2..19b6cd4117 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -15,7 +15,7 @@ module GHC.Event.Thread , registerDelay , blockedOnBadFD -- used by RTS ) where - +-- TODO: Use new Windows I/O manager import Control.Exception (finally, SomeException, toException) import Data.Foldable (forM_, mapM_, sequence_) import Data.IORef (IORef, newIORef, readIORef, writeIORef) diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index 946f2333bf..f23d632b21 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -6,7 +6,7 @@ , TypeSynonymInstances , FlexibleInstances #-} - +-- TODO: use the new Windows IO manager module GHC.Event.TimerManager ( -- * Types TimerManager @@ -52,6 +52,7 @@ import GHC.Show (Show(..)) import GHC.Event.Control import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..)) import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) +import GHC.Event.TimeOut import System.Posix.Types (Fd) import qualified GHC.Event.Internal as I @@ -66,13 +67,6 @@ import qualified GHC.Event.Poll as Poll ------------------------------------------------------------------------ -- Types --- | A timeout registration cookie. -newtype TimeoutKey = TK Unique - deriving Eq -- ^ @since 4.7.0.0 - --- | Callback invoked on timeout events. -type TimeoutCallback = IO () - data State = Created | Running | Dying @@ -81,12 +75,6 @@ data State = Created , Show -- ^ @since 4.7.0.0 ) --- | A priority search queue, with timeouts as priorities. -type TimeoutQueue = Q.PSQ TimeoutCallback - --- | An edit to apply to a 'TimeoutQueue'. -type TimeoutEdit = TimeoutQueue -> TimeoutQueue - -- | The event manager state. data TimerManager = TimerManager { emBackend :: !Backend |