forked from tibbe/event
-
Notifications
You must be signed in to change notification settings - Fork 1
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
2 changed files
with
276 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,97 @@ | ||
{-# LANGUAGE CPP #-} | ||
|
||
module System.Event.Array | ||
( Array, | ||
new, | ||
empty, | ||
unsafeRead, | ||
unsafeWrite, | ||
ensureCapacity, | ||
useAsPtr, | ||
length, | ||
snoc, | ||
mapM_ | ||
) where | ||
|
||
import Control.Monad (when) | ||
import Data.IORef | ||
import Foreign.Marshal.Array | ||
import Foreign.Ptr | ||
import Foreign.Storable | ||
import Prelude hiding (length, mapM_) | ||
|
||
#define BOUNDS_CHECKING 1 | ||
|
||
#if defined(BOUNDS_CHECKING) | ||
-- This fugly hack is brought by GHC's apparent reluctance to deal | ||
-- with MagicHash and UnboxedTuples when inferring types. Eek! | ||
#define CHECK_BOUNDS(_func_,_len_,_k_) \ | ||
if (_k_) < 0 || (_k_) >= (_len_) then error ("System.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else | ||
#else | ||
#define CHECK_BOUNDS(_func_,_len_,_k_) | ||
#endif | ||
|
||
-- Invariant: size <= capacity | ||
newtype Array a = Array (IORef (AC a)) | ||
|
||
-- The actual array content. | ||
data AC a = AC | ||
!(Ptr a) -- Elements | ||
!Int -- Size | ||
!Int -- Capacity | ||
|
||
new :: Storable a => Int -> IO (Array a) | ||
new cap = do ptr <- mallocArray cap | ||
ref <- newIORef (AC ptr 0 cap) | ||
return $ Array ref | ||
|
||
empty :: IO (Array a) | ||
empty = do ref <- newIORef (AC nullPtr 0 0) | ||
return $ Array ref | ||
|
||
unsafeRead :: Storable a => Array a -> Int -> IO a | ||
unsafeRead (Array ref) ix = | ||
do AC ptr _ cap <- readIORef ref | ||
CHECK_BOUNDS("unsafeRead",cap,ix) | ||
peekElemOff ptr ix | ||
|
||
unsafeWrite :: Storable a => Array a -> Int -> a -> IO () | ||
unsafeWrite (Array ref) ix a = | ||
do AC ptr _ cap <- readIORef ref | ||
CHECK_BOUNDS("unsafeWrite",cap,ix) | ||
pokeElemOff ptr ix a | ||
|
||
ensureCapacity :: Storable a => Array a -> Int -> IO () | ||
ensureCapacity (Array ref) newSize = | ||
do AC ptr sz cap <- readIORef ref | ||
when (newSize > cap) $ do | ||
let cap' = newCap cap | ||
ptr' <- reallocArray ptr cap' | ||
writeIORef ref (AC ptr' sz cap') | ||
where newCap 0 = 64 | ||
newCap oldCap = 2 * oldCap | ||
|
||
useAsPtr :: Array a -> (Ptr a -> Int -> IO b) -> IO b | ||
useAsPtr (Array ref) f = | ||
do AC ptr _ cap <- readIORef ref | ||
f ptr cap | ||
|
||
length :: Array a -> IO Int | ||
length (Array ref) = | ||
do AC _ sz _ <- readIORef ref | ||
return sz | ||
|
||
snoc :: Storable a => Array a -> a -> IO () | ||
snoc arr elem = | ||
do sz <- length arr | ||
ensureCapacity arr (sz + 1) | ||
unsafeWrite arr sz elem | ||
|
||
mapM_ :: Storable a => Array a -> (a -> IO ()) -> IO () | ||
mapM_ (Array ref) f = | ||
do AC ptr sz _ <- readIORef ref | ||
let loop n | n == sz = return () | ||
| otherwise = do | ||
e <- peek (ptr `plusPtr` n) | ||
f e | ||
loop 0 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,179 @@ | ||
{-# LANGUAGE ForeignFunctionInterface #-} | ||
|
||
module System.Event.KQueue where | ||
|
||
import Control.Monad | ||
import Data.Bits | ||
import Foreign.C.Error | ||
import Foreign.C.Types | ||
import Foreign.Ptr | ||
import Foreign.Storable | ||
import Foreign.Marshal.Alloc | ||
import Prelude hiding (filter) | ||
|
||
import qualified System.Event.Internal as E | ||
|
||
import qualified System.Event.Array as A | ||
|
||
#include <sys/types.h> | ||
#include <sys/event.h> | ||
#include <sys/time.h> | ||
|
||
------------------------------------------------------------------------ | ||
-- FFI binding | ||
|
||
newtype EventQ = EventQ { unEventQ :: CInt } | ||
deriving (Eq, Show) | ||
|
||
data Event = Event { | ||
ident :: CUIntPtr | ||
, filter :: Filter | ||
, flags :: Flag | ||
, fflags :: CUInt | ||
, data_ :: CIntPtr | ||
, udata :: Ptr () | ||
} deriving Show | ||
|
||
instance Storable Event where | ||
sizeOf _ = #size struct kevent | ||
alignment _ = alignment (undefined :: CInt) | ||
|
||
peek ptr = do | ||
ident' <- #{peek struct kevent, ident} ptr | ||
filter' <- #{peek struct kevent, filter} ptr | ||
flags' <- #{peek struct kevent, flags} ptr | ||
fflags' <- #{peek struct kevent, fflags} ptr | ||
data' <- #{peek struct kevent, data} ptr | ||
udata' <- #{peek struct kevent, udata} ptr | ||
return $ Event ident' (Filter filter') (Flag flags') fflags' data' | ||
udata' | ||
|
||
poke ptr ev = do | ||
#{poke struct kevent, ident} ptr (ident ev) | ||
#{poke struct kevent, filter} ptr (unFilter $ filter ev) | ||
#{poke struct kevent, flags} ptr (unFlag $ flags ev) | ||
#{poke struct kevent, fflags} ptr (fflags ev) | ||
#{poke struct kevent, data} ptr (data_ ev) | ||
#{poke struct kevent, udata} ptr (udata ev) | ||
|
||
newtype Flag = Flag { unFlag :: CUShort } | ||
deriving (Eq, Show) | ||
|
||
#{enum Flag, Flag | ||
, flagAdd = EV_ADD | ||
, flagEnable = EV_ENABLE | ||
, flagDisable = EV_DISABLE | ||
, flagDelete = EV_DELETE | ||
, flagReceipt = EV_RECEIPT | ||
, flagOneShot = EV_ONESHOT | ||
, flagClear = EV_CLEAR | ||
, flagEof = EV_EOF | ||
, flagError = EV_ERROR | ||
} | ||
|
||
combineFlags :: [Flag] -> Flag | ||
combineFlags = Flag . foldr ((.|.) . unFlag) 0 | ||
|
||
newtype Filter = Filter { unFilter :: CShort } | ||
deriving (Eq, Show) | ||
|
||
#{enum Filter, Filter | ||
, filterRead = EVFILT_READ | ||
, filterWrite = EVFILT_WRITE | ||
, filterAio = EVFILT_AIO | ||
, filterVnode = EVFILT_VNODE | ||
, filterProc = EVFILT_PROC | ||
, filterSignal = EVFILT_SIGNAL | ||
, filterTimer = EVFILT_TIMER | ||
} | ||
|
||
combineFilters :: [Filter] -> Filter | ||
combineFilters = Filter . foldr ((.|.) . unFilter) 0 | ||
|
||
data TimeSpec = TimeSpec { | ||
tv_sec :: CTime | ||
, tv_nsec :: CLong | ||
} | ||
|
||
instance Storable TimeSpec where | ||
sizeOf _ = #size struct timespec | ||
alignment _ = alignment (undefined :: CInt) | ||
|
||
peek ptr = do | ||
tv_sec' <- #{peek struct timespec, tv_sec} ptr | ||
tv_nsec' <- #{peek struct timespec, tv_nsec} ptr | ||
return $ TimeSpec tv_sec' tv_nsec' | ||
|
||
poke ptr ts = do | ||
#{poke struct timespec, tv_sec} ptr (tv_sec ts) | ||
#{poke struct timespec, tv_nsec} ptr (tv_nsec ts) | ||
|
||
foreign import ccall unsafe "event.h kqueue" | ||
c_kqueue :: IO EventQ | ||
|
||
foreign import ccall unsafe "event.h kevent" | ||
c_kevent :: EventQ -> Ptr Event -> CInt -> Ptr Event -> CInt | ||
-> Ptr TimeSpec -> IO CInt | ||
|
||
kqueue :: IO EventQ | ||
kqueue = EventQ `fmap` throwErrnoIfMinus1 | ||
"kqueue" (fmap unEventQ c_kqueue) | ||
|
||
kevent :: EventQ -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec | ||
-> IO Int | ||
kevent kq chs chlen evs evlen ts | ||
= fmap fromIntegral $ throwErrnoIfMinus1 "kevent" $ | ||
c_kevent kq chs (fromIntegral chlen) evs (fromIntegral evlen) ts | ||
|
||
withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a | ||
withTimeSpec ts f = alloca $ \ptr -> poke ptr ts >> f ptr | ||
|
||
------------------------------------------------------------------------ | ||
-- Exported interface | ||
|
||
data EventQueue = EventQueue { | ||
kq :: !EventQ | ||
, changes :: !(A.Array Event) | ||
, events :: !(A.Array Event) | ||
} | ||
|
||
instance E.Backend EventQueue where | ||
new = new | ||
poll = poll | ||
set q fd events = set q fd (combineFilters $ map fromEvent events) flagAdd | ||
|
||
new :: IO EventQueue | ||
new = do | ||
kq' <- kqueue | ||
changes' <- A.empty | ||
events' <- A.new 64 | ||
return $ EventQueue kq' changes' events' | ||
|
||
set :: EventQueue -> CInt -> Filter -> Flag -> IO () | ||
set q fd fltr flg = | ||
A.snoc (changes q) (Event (fromIntegral fd) fltr flg 0 0 nullPtr) | ||
|
||
poll :: EventQueue -> (CInt -> [E.Event] -> IO ()) -> IO () | ||
poll q f = do | ||
changesLen <- A.length (changes q) | ||
len <- A.length (events q) | ||
when (changesLen > len) $ do | ||
A.ensureCapacity (events q) (2 * changesLen) | ||
res <- A.useAsPtr (changes q) $ \changesPtr changesLen -> | ||
A.useAsPtr (events q) $ \eventsPtr eventsLen -> | ||
withTimeSpec (TimeSpec 1 0) $ \tsPtr -> | ||
kevent (kq q) changesPtr changesLen eventsPtr eventsLen tsPtr | ||
|
||
when (res > 0) $ putStrLn "events!" | ||
|
||
eventsLen <- A.length (events q) | ||
when (res == eventsLen) $ do | ||
A.ensureCapacity (events q) (2 * eventsLen) | ||
|
||
A.mapM_ (events q) $ \e -> do | ||
let fd = fromIntegral (ident e) | ||
f fd [] | ||
|
||
fromEvent :: E.Event -> Filter | ||
fromEvent E.Read = filterRead | ||
fromEvent E.Write = filterWrite |