dist-install/build/GHC/Event/KQueue.hs

    {-# LINE 1 "libraries/base/GHC/Event/KQueue.hsc" #-}
    {-# LANGUAGE Trustworthy #-}
    {-# LINE 2 "libraries/base/GHC/Event/KQueue.hsc" #-}
    {-# LANGUAGE CApiFFI
               , GeneralizedNewtypeDeriving
               , NoImplicitPrelude
               , RecordWildCards
               , BangPatterns
      #-}

    module GHC.Event.KQueue
        (
          new
        , available
        ) where

    import qualified GHC.Event.Internal as E

    {-# LINE 18 "libraries/base/GHC/Event/KQueue.hsc" #-}

    {-# LINE 28 "libraries/base/GHC/Event/KQueue.hsc" #-}

    import Data.Bits (Bits(..), FiniteBits(..))
    import Data.Word (Word16, Word32)
    import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL,
                            eNOTSUP, getErrno, throwErrno)
    import Foreign.C.Types
    import Foreign.Marshal.Alloc (alloca)
    import Foreign.Ptr (Ptr, nullPtr)
    import Foreign.Storable (Storable(..))
    import GHC.Base
    import GHC.Enum (toEnum)
    import GHC.Num (Num(..))
    import GHC.Real (ceiling, floor, fromIntegral)
    import GHC.Show (Show(show))
    import GHC.Event.Internal (Timeout(..))
    import System.Posix.Internals (c_close)
    import System.Posix.Types (Fd(..))
    import qualified GHC.Event.Array as A

    {-# LINE 50 "libraries/base/GHC/Event/KQueue.hsc" #-}

    {-# LINE 52 "libraries/base/GHC/Event/KQueue.hsc" #-}

    {-# LINE 53 "libraries/base/GHC/Event/KQueue.hsc" #-}

    {-# LINE 54 "libraries/base/GHC/Event/KQueue.hsc" #-}

    -- Handle brokenness on some BSD variants, notably OS X up to at least
    -- 10.6.  If NOTE_EOF isn't available, we have no way to receive a
    -- notification from the kernel when we reach EOF on a plain file.

    {-# LINE 61 "libraries/base/GHC/Event/KQueue.hsc" #-}

    available :: Bool
    available = True
    {-# INLINE available #-}

    ------------------------------------------------------------------------
    -- Exported interface

    data KQueue = KQueue {
          kqueueFd     :: {-# UNPACK #-} !KQueueFd
        , kqueueEvents :: {-# UNPACK #-} !(A.Array Event)
        }

    new :: IO E.Backend
    new = do
      kqfd <- kqueue
      events <- A.new 64
      let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)
      return be

    delete :: KQueue -> IO ()
    delete kq = do
      _ <- c_close . fromKQueueFd . kqueueFd $ kq
      return ()

    modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
    modifyFd kq fd oevt nevt
      | nevt == mempty = do
          let !ev = event fd (toFilter oevt) flagDelete noteEOF
          kqueueControl (kqueueFd kq) ev
      | otherwise      = do
          let !ev = event fd (toFilter nevt) flagAdd noteEOF
          kqueueControl (kqueueFd kq) ev

    toFilter :: E.Event -> Filter
    toFilter evt
      | evt `E.eventIs` E.evtRead = filterRead
      | otherwise                 = filterWrite

    modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool
    modifyFdOnce kq fd evt = do
        let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF
        kqueueControl (kqueueFd kq) ev

    poll :: KQueue
         -> Maybe Timeout
         -> (Fd -> E.Event -> IO ())
         -> IO Int
    poll kq mtimeout f = do
        let events = kqueueEvents kq
            fd = kqueueFd kq

        n <- A.unsafeLoad events $ \es cap -> case mtimeout of
          Just timeout -> kqueueWait fd es cap $ fromTimeout timeout
          Nothing      -> kqueueWaitNonBlock fd es cap

        when (n > 0) $ do
            A.forM_ events $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))
            cap <- A.capacity events
            when (n == cap) $ A.ensureCapacity events (2 * cap)
        return n
    ------------------------------------------------------------------------
    -- FFI binding

    newtype KQueueFd = KQueueFd {
          fromKQueueFd :: CInt
        } deriving (Eq, Show)

    data Event = KEvent {
          ident  :: {-# UNPACK #-} !CUIntPtr
        , filter :: {-# UNPACK #-} !Filter
        , flags  :: {-# UNPACK #-} !Flag
        , fflags :: {-# UNPACK #-} !FFlag

    {-# LINE 137 "libraries/base/GHC/Event/KQueue.hsc" #-}
        , data_  :: {-# UNPACK #-} !CIntPtr

    {-# LINE 139 "libraries/base/GHC/Event/KQueue.hsc" #-}
        , udata  :: {-# UNPACK #-} !(Ptr ())
        } deriving Show

    event :: Fd -> Filter -> Flag -> FFlag -> Event
    event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr

    instance Storable Event where
        sizeOf _ = (20)
    {-# LINE 147 "libraries/base/GHC/Event/KQueue.hsc" #-}
        alignment _ = alignment (undefined :: CInt)

        peek ptr = do
            ident'  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
    {-# LINE 151 "libraries/base/GHC/Event/KQueue.hsc" #-}
            filter' <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
    {-# LINE 152 "libraries/base/GHC/Event/KQueue.hsc" #-}
            flags'  <- (\hsc_ptr -> peekByteOff hsc_ptr 6) ptr
    {-# LINE 153 "libraries/base/GHC/Event/KQueue.hsc" #-}
            fflags' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
    {-# LINE 154 "libraries/base/GHC/Event/KQueue.hsc" #-}
            data'   <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
    {-# LINE 155 "libraries/base/GHC/Event/KQueue.hsc" #-}
            udata'  <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
    {-# LINE 156 "libraries/base/GHC/Event/KQueue.hsc" #-}
            let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
                             udata'
            return ev

        poke ptr ev = do
            (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (ident ev)
    {-# LINE 162 "libraries/base/GHC/Event/KQueue.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (filter ev)
    {-# LINE 163 "libraries/base/GHC/Event/KQueue.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 6) ptr (flags ev)
    {-# LINE 164 "libraries/base/GHC/Event/KQueue.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (fflags ev)
    {-# LINE 165 "libraries/base/GHC/Event/KQueue.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (data_ ev)
    {-# LINE 166 "libraries/base/GHC/Event/KQueue.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (udata ev)
    {-# LINE 167 "libraries/base/GHC/Event/KQueue.hsc" #-}

    newtype FFlag = FFlag Word32
        deriving (Eq, Show, Storable)

    noteEOF  :: FFlag
    noteEOF  = FFlag 0

    {-# LINE 174 "libraries/base/GHC/Event/KQueue.hsc" #-}

    {-# LINE 178 "libraries/base/GHC/Event/KQueue.hsc" #-}
    newtype Flag = Flag Word16

    {-# LINE 180 "libraries/base/GHC/Event/KQueue.hsc" #-}
        deriving (Bits, FiniteBits, Eq, Num, Show, Storable)

    flagAdd      :: Flag
    flagAdd      = Flag 1
    flagDelete   :: Flag
    flagDelete   = Flag 2
    flagOneshot  :: Flag
    flagOneshot  = Flag 16

    {-# LINE 187 "libraries/base/GHC/Event/KQueue.hsc" #-}

    {-# LINE 191 "libraries/base/GHC/Event/KQueue.hsc" #-}
    newtype Filter = Filter Word16

    {-# LINE 193 "libraries/base/GHC/Event/KQueue.hsc" #-}
        deriving (Bits, FiniteBits, Eq, Num, Show, Storable)

    filterRead :: Filter
    filterRead = Filter (-1)
    {-# LINE 197 "libraries/base/GHC/Event/KQueue.hsc" #-}
    filterWrite :: Filter
    filterWrite  = Filter (-2)
    {-# LINE 199 "libraries/base/GHC/Event/KQueue.hsc" #-}

    data TimeSpec = TimeSpec {
          tv_sec  :: {-# UNPACK #-} !CTime
        , tv_nsec :: {-# UNPACK #-} !CLong
        }

    instance Storable TimeSpec where
        sizeOf _ = (8)
    {-# LINE 207 "libraries/base/GHC/Event/KQueue.hsc" #-}
        alignment _ = alignment (undefined :: CInt)

        peek ptr = do
            tv_sec'  <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
    {-# LINE 211 "libraries/base/GHC/Event/KQueue.hsc" #-}
            tv_nsec' <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
    {-# LINE 212 "libraries/base/GHC/Event/KQueue.hsc" #-}
            let !ts = TimeSpec tv_sec' tv_nsec'
            return ts

        poke ptr ts = do
            (\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (tv_sec ts)
    {-# LINE 217 "libraries/base/GHC/Event/KQueue.hsc" #-}
            (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (tv_nsec ts)
    {-# LINE 218 "libraries/base/GHC/Event/KQueue.hsc" #-}

    kqueue :: IO KQueueFd
    kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue

    kqueueControl :: KQueueFd -> Event -> IO Bool
    kqueueControl kfd ev =
        withTimeSpec (TimeSpec 0 0) $ \tp ->
            withEvent ev $ \evp -> do
                res <- kevent False kfd evp 1 nullPtr 0 tp
                if res == -1
                  then do
                   err <- getErrno
                   case err of
                     _ | err == eINTR  -> return True
                     _ | err == eINVAL -> return False
                     _ | err == eNOTSUP -> return False
                     _                 -> throwErrno "kevent"
                  else return True

    kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int
    kqueueWait fd es cap tm =
        fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
        withTimeSpec tm $ kevent True fd nullPtr 0 es cap

    kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int
    kqueueWaitNonBlock fd es cap =
        fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
        withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap

    -- TODO: We cannot retry on EINTR as the timeout would be wrong.
    -- Perhaps we should just return without calling any callbacks.
    kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
           -> IO CInt
    kevent safe k chs chlen evs evlen ts
      | safe      = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
      | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts

    withEvent :: Event -> (Ptr Event -> IO a) -> IO a
    withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr

    withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
    withTimeSpec ts f
      | tv_sec ts < 0 = f nullPtr
      | otherwise     = alloca $ \ptr -> poke ptr ts >> f ptr

    fromTimeout :: Timeout -> TimeSpec
    fromTimeout Forever     = TimeSpec (-1) (-1)
    fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
      where
        sec :: Int
        sec     = floor s

        nanosec :: Int
        nanosec = ceiling $ (s - fromIntegral sec) * 1000000000

    toEvent :: Filter -> E.Event
    toEvent (Filter f)
      | f == (-1) = E.evtRead
    {-# LINE 276 "libraries/base/GHC/Event/KQueue.hsc" #-}
      | f == (-2) = E.evtWrite
    {-# LINE 277 "libraries/base/GHC/Event/KQueue.hsc" #-}
      | otherwise = error $ "toEvent: unknown filter " ++ show f

    foreign import ccall unsafe "kqueue"
        c_kqueue :: IO CInt

    {-# LINE 283 "libraries/base/GHC/Event/KQueue.hsc" #-}
    foreign import capi safe "sys/event.h kevent"
        c_kevent :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
                 -> Ptr TimeSpec -> IO CInt

    foreign import ccall unsafe "kevent"
        c_kevent_unsafe :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
                        -> Ptr TimeSpec -> IO CInt

    {-# LINE 293 "libraries/base/GHC/Event/KQueue.hsc" #-}

    {-# LINE 295 "libraries/base/GHC/Event/KQueue.hsc" #-}