Internal.hs 3.76 KB
Newer Older
1
{-# LANGUAGE Unsafe #-}
Simon Marlow's avatar
Simon Marlow committed
2
{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
3
4
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
Simon Marlow's avatar
Simon Marlow committed
5

Ian Lynagh's avatar
Ian Lynagh committed
6
module GHC.Event.Internal
Simon Marlow's avatar
Simon Marlow committed
7
8
9
10
11
12
13
    (
    -- * Event back end
      Backend
    , backend
    , delete
    , poll
    , modifyFd
14
    , modifyFdOnce
15
    , module GHC.Event.Internal.Types
Simon Marlow's avatar
Simon Marlow committed
16
17
    -- * Helpers
    , throwErrnoIfMinus1NoRetry
18
19
20

    -- Atomic ptr exchange for WinIO
    , exchangePtr
Simon Marlow's avatar
Simon Marlow committed
21
22
23
24
25
26
    ) where

import Foreign.C.Error (eINTR, getErrno, throwErrno)
import System.Posix.Types (Fd)
import GHC.Base
import GHC.Num (Num(..))
27
import GHC.Event.Internal.Types
Simon Marlow's avatar
Simon Marlow committed
28

29
30
import GHC.Ptr (Ptr(..))

Simon Marlow's avatar
Simon Marlow committed
31
32
33
34
35
36
37
-- | Event notification backend.
data Backend = forall a. Backend {
      _beState :: !a

    -- | Poll backend for new events.  The provided callback is called
    -- once per file descriptor with new events.
    , _bePoll :: a                          -- backend state
38
              -> Maybe Timeout              -- timeout in milliseconds ('Nothing' for non-blocking poll)
Simon Marlow's avatar
Simon Marlow committed
39
              -> (Fd -> Event -> IO ())     -- I/O callback
40
              -> IO Int
Simon Marlow's avatar
Simon Marlow committed
41
42
43
44
45
46
47

    -- | Register, modify, or unregister interest in the given events
    -- on the given file descriptor.
    , _beModifyFd :: a
                  -> Fd       -- file descriptor
                  -> Event    -- old events to watch for ('mempty' for new)
                  -> Event    -- new events to watch for ('mempty' to delete)
48
                  -> IO Bool
Simon Marlow's avatar
Simon Marlow committed
49

50
51
    -- | Register interest in new events on a given file descriptor, set
    -- to be deactivated after the first event.
52
53
54
    , _beModifyFdOnce :: a
                         -> Fd    -- file descriptor
                         -> Event -- new events to watch
55
                         -> IO Bool
56

Simon Marlow's avatar
Simon Marlow committed
57
58
59
    , _beDelete :: a -> IO ()
    }

60
backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
61
62
        -> (a -> Fd -> Event -> Event -> IO Bool)
        -> (a -> Fd -> Event -> IO Bool)
Simon Marlow's avatar
Simon Marlow committed
63
64
65
        -> (a -> IO ())
        -> a
        -> Backend
66
67
backend bPoll bModifyFd bModifyFdOnce bDelete state =
  Backend state bPoll bModifyFd bModifyFdOnce bDelete
Simon Marlow's avatar
Simon Marlow committed
68
69
{-# INLINE backend #-}

70
poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
71
poll (Backend bState bPoll _ _ _) = bPoll bState
Simon Marlow's avatar
Simon Marlow committed
72
73
{-# INLINE poll #-}

74
75
76
77
-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
78
modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
Simon Marlow's avatar
Simon Marlow committed
79
80
{-# INLINE modifyFd #-}

81
82
83
84
-- | Returns 'True' if the modification succeeded.
-- Returns 'False' if this backend does not support
-- event notifications on this type of file.
modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
85
86
87
modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
{-# INLINE modifyFdOnce #-}

Simon Marlow's avatar
Simon Marlow committed
88
delete :: Backend -> IO ()
89
delete (Backend bState _ _ _ bDelete) = bDelete bState
Simon Marlow's avatar
Simon Marlow committed
90
91
{-# INLINE delete #-}

92
-- | Throw an 'Prelude.IOError' corresponding to the current value of
Simon Marlow's avatar
Simon Marlow committed
93
94
95
96
-- 'getErrno' if the result value of the 'IO' action is -1 and
-- 'getErrno' is not 'eINTR'.  If the result value is -1 and
-- 'getErrno' returns 'eINTR' 0 is returned.  Otherwise the result
-- value is returned.
Ian Lynagh's avatar
Ian Lynagh committed
97
throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a
Simon Marlow's avatar
Simon Marlow committed
98
99
100
101
102
103
104
throwErrnoIfMinus1NoRetry loc f = do
    res <- f
    if res == -1
        then do
            err <- getErrno
            if err == eINTR then return 0 else throwErrno loc
        else return res
105
106
107
108
109
110
111

{-# INLINE exchangePtr #-}
-- | @exchangePtr pptr x@ swaps the pointer pointed to by @pptr@ with the value
-- @x@, returning the old value.
exchangePtr :: Ptr (Ptr a) -> Ptr a -> IO (Ptr a)
exchangePtr (Ptr dst) (Ptr val) =
  IO $ \s ->
112
      case (atomicExchangeAddrAddr# dst val s) of
113
        (# s2, old_val #) -> (# s2, Ptr old_val #)