module GHC.Event.Manager
(
EventManager
, new
, newWith
, newDefaultBackend
, finished
, loop
, step
, shutdown
, release
, cleanup
, wakeManager
, callbackTableVar
, emControl
, Lifetime (..)
, Event
, evtRead
, evtWrite
, IOCallback
, FdKey(keyFd)
, FdData
, registerFd
, unregisterFd_
, unregisterFd
, closeFd
, closeFd_
) where
#include "EventConfig.h"
import Control.Concurrent.MVar (MVar, newMVar, putMVar,
tryPutMVar, takeMVar, withMVar)
import Control.Exception (onException)
import Data.Bits ((.&.))
import Data.Foldable (forM_)
import Data.Functor (void)
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
writeIORef)
import Data.Maybe (maybe)
import Data.OldList (partition)
import GHC.Arr (Array, (!), listArray)
import GHC.Base
import GHC.Conc.Sync (yield)
import GHC.List (filter, replicate)
import GHC.Num (Num(..))
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,
Lifetime(..), EventLifetime, Timeout(..))
import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique)
import System.Posix.Types (Fd)
import qualified GHC.Event.IntTable as IT
import qualified GHC.Event.Internal as I
#if defined(HAVE_KQUEUE)
import qualified GHC.Event.KQueue as KQueue
#elif defined(HAVE_EPOLL)
import qualified GHC.Event.EPoll as EPoll
#elif defined(HAVE_POLL)
import qualified GHC.Event.Poll as Poll
#else
# error not implemented for this operating system
#endif
data FdData = FdData {
fdKey :: !FdKey
, fdEvents :: !EventLifetime
, _fdCallback :: !IOCallback
}
data FdKey = FdKey {
keyFd :: !Fd
, keyUnique :: !Unique
} deriving ( Eq
, Show
)
type IOCallback = FdKey -> Event -> IO ()
data State = Created
| Running
| Dying
| Releasing
| Finished
deriving ( Eq
, Show
)
data EventManager = EventManager
{ emBackend :: !Backend
, emFds :: !(Array Int (MVar (IntTable [FdData])))
, emState :: !(IORef State)
, emUniqueSource :: !UniqueSource
, emControl :: !Control
, emLock :: !(MVar ())
}
callbackArraySize :: Int
callbackArraySize = 32
hashFd :: Fd -> Int
hashFd fd = fromIntegral fd .&. (callbackArraySize 1)
callbackTableVar :: EventManager -> Fd -> MVar (IntTable [FdData])
callbackTableVar mgr fd = emFds mgr ! hashFd fd
haveOneShot :: Bool
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
haveOneShot = False
#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
haveOneShot = True
#else
haveOneShot = False
#endif
handleControlEvent :: EventManager -> Fd -> Event -> IO ()
handleControlEvent mgr fd _evt = do
msg <- readControlMessage (emControl mgr) fd
case msg of
CMsgWakeup -> return ()
CMsgDie -> writeIORef (emState mgr) Finished
_ -> return ()
newDefaultBackend :: IO Backend
#if defined(HAVE_KQUEUE)
newDefaultBackend = KQueue.new
#elif defined(HAVE_EPOLL)
newDefaultBackend = EPoll.new
#elif defined(HAVE_POLL)
newDefaultBackend = Poll.new
#else
newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
#endif
new :: IO EventManager
new = newWith =<< newDefaultBackend
newWith :: Backend -> IO EventManager
newWith be = do
iofds <- fmap (listArray (0, callbackArraySize1)) $
replicateM callbackArraySize (newMVar =<< IT.new 8)
ctrl <- newControl False
state <- newIORef Created
us <- newSource
_ <- mkWeakIORef state $ do
st <- atomicModifyIORef' state $ \s -> (Finished, s)
when (st /= Finished) $ do
I.delete be
closeControl ctrl
lockVar <- newMVar ()
let mgr = EventManager { emBackend = be
, emFds = iofds
, emState = state
, emUniqueSource = us
, emControl = ctrl
, emLock = lockVar
}
registerControlFd mgr (controlReadFd ctrl) evtRead
registerControlFd mgr (wakeupReadFd ctrl) evtRead
return mgr
where
replicateM n x = sequence (replicate n x)
failOnInvalidFile :: String -> Fd -> IO Bool -> IO ()
failOnInvalidFile loc fd m = do
ok <- m
when (not ok) $
let msg = "Failed while attempting to modify registration of file " ++
show fd ++ " at location " ++ loc
in errorWithoutStackTrace msg
registerControlFd :: EventManager -> Fd -> Event -> IO ()
registerControlFd mgr fd evs =
failOnInvalidFile "registerControlFd" fd $
I.modifyFd (emBackend mgr) fd mempty evs
shutdown :: EventManager -> IO ()
shutdown mgr = do
state <- atomicModifyIORef' (emState mgr) $ \s -> (Dying, s)
when (state == Running) $ sendDie (emControl mgr)
release :: EventManager -> IO ()
release EventManager{..} = do
state <- atomicModifyIORef' emState $ \s -> (Releasing, s)
when (state == Running) $ sendWakeup emControl
finished :: EventManager -> IO Bool
finished mgr = (== Finished) `liftM` readIORef (emState mgr)
cleanup :: EventManager -> IO ()
cleanup EventManager{..} = do
writeIORef emState Finished
void $ tryPutMVar emLock ()
I.delete emBackend
closeControl emControl
loop :: EventManager -> IO ()
loop mgr@EventManager{..} = do
void $ takeMVar emLock
state <- atomicModifyIORef' emState $ \s -> case s of
Created -> (Running, s)
Releasing -> (Running, s)
_ -> (s, s)
case state of
Created -> go `onException` cleanup mgr
Releasing -> go `onException` cleanup mgr
Dying -> cleanup mgr
Finished -> return ()
_ -> do cleanup mgr
errorWithoutStackTrace $ "GHC.Event.Manager.loop: state is already " ++
show state
where
go = do state <- step mgr
case state of
Running -> yield >> go
Releasing -> putMVar emLock ()
_ -> cleanup mgr
step :: EventManager -> IO State
step mgr@EventManager{..} = do
waitForIO
state <- readIORef emState
state `seq` return state
where
waitForIO = do
n1 <- I.poll emBackend Nothing (onFdEvent mgr)
when (n1 <= 0) $ do
yield
n2 <- I.poll emBackend Nothing (onFdEvent mgr)
when (n2 <= 0) $ do
_ <- I.poll emBackend (Just Forever) (onFdEvent mgr)
return ()
registerFd_ :: EventManager -> IOCallback -> Fd -> Event -> Lifetime
-> IO (FdKey, Bool)
registerFd_ mgr@(EventManager{..}) cb fd evs lt = do
u <- newUnique emUniqueSource
let fd' = fromIntegral fd
reg = FdKey fd u
el = I.eventLifetime evs lt
!fdd = FdData reg el cb
(modify,ok) <- withMVar (callbackTableVar mgr fd) $ \tbl -> do
oldFdd <- IT.insertWith (++) fd' [fdd] tbl
let prevEvs :: EventLifetime
prevEvs = maybe mempty eventsOf oldFdd
el' :: EventLifetime
el' = prevEvs `mappend` el
case I.elLifetime el' of
OneShot | haveOneShot -> do
ok <- I.modifyFdOnce emBackend fd (I.elEvent el')
if ok
then return (False, True)
else IT.reset fd' oldFdd tbl >> return (False, False)
_ -> do
let modify = prevEvs /= el'
ok <- if modify
then let newEvs = I.elEvent el'
oldEvs = I.elEvent prevEvs
in I.modifyFd emBackend fd oldEvs newEvs
else return True
if ok
then return (modify, True)
else IT.reset fd' oldFdd tbl >> return (False, False)
when (not ok) (cb reg evs)
return (reg,modify)
registerFd :: EventManager -> IOCallback -> Fd -> Event -> Lifetime -> IO FdKey
registerFd mgr cb fd evs lt = do
(r, wake) <- registerFd_ mgr cb fd evs lt
when wake $ wakeManager mgr
return r
wakeManager :: EventManager -> IO ()
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
wakeManager mgr = sendWakeup (emControl mgr)
#elif defined(HAVE_EPOLL) || defined(HAVE_KQUEUE)
wakeManager _ = return ()
#else
wakeManager mgr = sendWakeup (emControl mgr)
#endif
eventsOf :: [FdData] -> EventLifetime
eventsOf [fdd] = fdEvents fdd
eventsOf fdds = mconcat $ map fdEvents fdds
unregisterFd_ :: EventManager -> FdKey -> IO Bool
unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) =
withMVar (callbackTableVar mgr fd) $ \tbl -> do
let dropReg = nullToNothing . filter ((/= u) . keyUnique . fdKey)
fd' = fromIntegral fd
pairEvents :: [FdData] -> IO (EventLifetime, EventLifetime)
pairEvents prev = do
r <- maybe mempty eventsOf `fmap` IT.lookup fd' tbl
return (eventsOf prev, r)
(oldEls, newEls) <- IT.updateWith dropReg fd' tbl >>=
maybe (return (mempty, mempty)) pairEvents
let modify = oldEls /= newEls
when modify $ failOnInvalidFile "unregisterFd_" fd $
case I.elLifetime newEls of
OneShot | I.elEvent newEls /= mempty, haveOneShot ->
I.modifyFdOnce emBackend fd (I.elEvent newEls)
_ ->
I.modifyFd emBackend fd (I.elEvent oldEls) (I.elEvent newEls)
return modify
unregisterFd :: EventManager -> FdKey -> IO ()
unregisterFd mgr reg = do
wake <- unregisterFd_ mgr reg
when wake $ wakeManager mgr
closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()
closeFd mgr close fd = do
fds <- withMVar (callbackTableVar mgr fd) $ \tbl -> do
prev <- IT.delete (fromIntegral fd) tbl
case prev of
Nothing -> close fd >> return []
Just fds -> do
let oldEls = eventsOf fds
when (I.elEvent oldEls /= mempty) $ do
_ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty
wakeManager mgr
close fd
return fds
forM_ fds $ \(FdData reg el cb) -> cb reg (I.elEvent el `mappend` evtClose)
closeFd_ :: EventManager
-> IntTable [FdData]
-> Fd
-> IO (IO ())
closeFd_ mgr tbl fd = do
prev <- IT.delete (fromIntegral fd) tbl
case prev of
Nothing -> return (return ())
Just fds -> do
let oldEls = eventsOf fds
when (oldEls /= mempty) $ do
_ <- I.modifyFd (emBackend mgr) fd (I.elEvent oldEls) mempty
wakeManager mgr
return $
forM_ fds $ \(FdData reg el cb) ->
cb reg (I.elEvent el `mappend` evtClose)
onFdEvent :: EventManager -> Fd -> Event -> IO ()
onFdEvent mgr fd evs
| fd == controlReadFd (emControl mgr) || fd == wakeupReadFd (emControl mgr) =
handleControlEvent mgr fd evs
| otherwise = do
fdds <- withMVar (callbackTableVar mgr fd) $ \tbl ->
IT.delete (fromIntegral fd) tbl >>= maybe (return []) (selectCallbacks tbl)
forM_ fdds $ \(FdData reg _ cb) -> cb reg evs
where
selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]
selectCallbacks tbl fdds = do
let
matches :: FdData -> Bool
matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd')
(triggered, notTriggered) = partition matches fdds
isMultishot :: FdData -> Bool
isMultishot fd' = I.elLifetime (fdEvents fd') == MultiShot
saved = notTriggered ++ filter isMultishot triggered
savedEls = eventsOf saved
allEls = eventsOf fdds
_ <- IT.insertWith (\_ _ -> saved) (fromIntegral fd) saved tbl
case I.elLifetime allEls of
MultiShot | allEls == savedEls ->
return ()
_ ->
case I.elLifetime savedEls of
OneShot | haveOneShot ->
unless (OneShot == I.elLifetime allEls
&& mempty == I.elEvent savedEls) $ do
void $ I.modifyFdOnce (emBackend mgr) fd (I.elEvent savedEls)
_ ->
void $ I.modifyFd (emBackend mgr) fd
(I.elEvent allEls) (I.elEvent savedEls)
return triggered
nullToNothing :: [a] -> Maybe [a]
nullToNothing [] = Nothing
nullToNothing xs@(_:_) = Just xs
unless :: Monad m => Bool -> m () -> m ()
unless p = when (not p)