module GHC.Event.Manager
(
EventManager
, new
, newWith
, newDefaultBackend
, finished
, loop
, step
, shutdown
, release
, cleanup
, wakeManager
, callbackTableVar
, Event
, evtRead
, evtWrite
, IOCallback
, FdKey(keyFd)
, FdData
, registerFd_
, registerFd
, unregisterFd_
, unregisterFd
, closeFd
, closeFd_
) where
#include "EventConfig.h"
import Control.Concurrent.MVar (MVar, newMVar, readMVar, putMVar,
tryPutMVar, takeMVar, withMVar)
import Control.Exception (onException)
import Control.Monad ((=<<), forM_, liftM, when, replicateM, void)
import Data.Bits ((.&.))
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
writeIORef)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mappend, mconcat, mempty)
import GHC.Arr (Array, (!), listArray)
import GHC.Base
import GHC.Conc.Signal (runHandlers)
import GHC.Conc.Sync (yield)
import GHC.List (filter)
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,
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 :: !Event
, _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
, emOneShot :: !Bool
, 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
CMsgSignal fp s -> runHandlers fp s
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 = error "no back end for this platform"
#endif
new :: Bool -> IO EventManager
new oneShot = newWith oneShot =<< newDefaultBackend
newWith :: Bool -> Backend -> IO EventManager
newWith oneShot 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
, emOneShot = oneShot
, emLock = lockVar
}
registerControlFd mgr (controlReadFd ctrl) evtRead
registerControlFd mgr (wakeupReadFd ctrl) evtRead
return mgr
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 error 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
error $ "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
-> IO (FdKey, Bool)
registerFd_ mgr@(EventManager{..}) cb fd evs = do
u <- newUnique emUniqueSource
let fd' = fromIntegral fd
reg = FdKey fd u
!fdd = FdData reg evs cb
(modify,ok) <- withMVar (callbackTableVar mgr fd) $ \tbl ->
if haveOneShot && emOneShot
then do
oldFdd <- IT.insertWith (++) fd' [fdd] tbl
let evs' = maybe evs (combineEvents evs) oldFdd
ok <- I.modifyFdOnce emBackend fd evs'
if ok
then return (False, True)
else IT.reset fd' oldFdd tbl >> return (False, False)
else do
oldFdd <- IT.insertWith (++) fd' [fdd] tbl
let (oldEvs, newEvs) =
case oldFdd of
Nothing -> (mempty, evs)
Just prev -> (eventsOf prev, combineEvents evs prev)
modify = oldEvs /= newEvs
ok <- if modify
then 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)
combineEvents :: Event -> [FdData] -> Event
combineEvents ev [fdd] = mappend ev (fdEvents fdd)
combineEvents ev fdds = mappend ev (eventsOf fdds)
registerFd :: EventManager -> IOCallback -> Fd -> Event -> IO FdKey
registerFd mgr cb fd evs = do
(r, wake) <- registerFd_ mgr cb fd evs
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] -> Event
eventsOf = mconcat . map fdEvents
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 prev = do
r <- maybe mempty eventsOf `fmap` IT.lookup fd' tbl
return (eventsOf prev, r)
(oldEvs, newEvs) <- IT.updateWith dropReg fd' tbl >>=
maybe (return (mempty, mempty)) pairEvents
let modify = oldEvs /= newEvs
when modify $ failOnInvalidFile "unregisterFd_" fd $
if haveOneShot && emOneShot && newEvs /= mempty
then I.modifyFdOnce emBackend fd newEvs
else I.modifyFd emBackend fd oldEvs newEvs
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 oldEvs = eventsOf fds
when (oldEvs /= mempty) $ do
_ <- I.modifyFd (emBackend mgr) fd oldEvs mempty
wakeManager mgr
close fd
return fds
forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `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 oldEvs = eventsOf fds
when (oldEvs /= mempty) $ do
_ <- I.modifyFd (emBackend mgr) fd oldEvs mempty
wakeManager mgr
return $
forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose)
onFdEvent :: EventManager -> Fd -> Event -> IO ()
onFdEvent mgr fd evs =
if fd == controlReadFd (emControl mgr) || fd == wakeupReadFd (emControl mgr)
then handleControlEvent mgr fd evs
else
if emOneShot mgr
then
do fdds <- withMVar (callbackTableVar mgr fd) $ \tbl ->
IT.delete fd' tbl >>=
maybe (return []) (selectCallbacks tbl)
forM_ fdds $ \(FdData reg _ cb) -> cb reg evs
else
do found <- IT.lookup fd' =<< readMVar (callbackTableVar mgr fd)
case found of
Just cbs -> forM_ cbs $ \(FdData reg ev cb) -> do
when (evs `I.eventIs` ev) $ cb reg evs
Nothing -> return ()
where
fd' :: Int
fd' = fromIntegral fd
selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]
selectCallbacks tbl cbs = aux cbs [] []
where
aux [] _ [] =
if haveOneShot
then return cbs
else do _ <- I.modifyFd (emBackend mgr) fd (eventsOf cbs) mempty
return cbs
aux [] fdds saved@(_:_) = do
_ <- if haveOneShot
then I.modifyFdOnce (emBackend mgr) fd $ eventsOf saved
else I.modifyFd (emBackend mgr) fd (eventsOf cbs) $ eventsOf saved
_ <- IT.insertWith (\_ _ -> saved) fd' saved tbl
return fdds
aux (fdd@(FdData _ evs' _) : cbs') fdds saved
| evs `I.eventIs` evs' = aux cbs' (fdd:fdds) saved
| otherwise = aux cbs' fdds (fdd:saved)
nullToNothing :: [a] -> Maybe [a]
nullToNothing [] = Nothing
nullToNothing xs@(_:_) = Just xs