Switch IO manager to a mutable hashtable

This data structure (IntTable) provides a similar API to its predecessor
(IntMap), at half the number of lines in size.

When tested in isolation using criterion, IntTable is much faster than
IntMap: over 15x, according to my criterion benchmarks.

This translates into a measurable improvement when used in the IO manager:
using weighttp to benchmark acme-http under various configurations on two
32-core Linux servers connected by a 10gbE network, I see between a 3%
and 10% increase in requests served per second compared to IntMap.

Signed-off-by: Andreas Voellmy <andreas.voellmy@gmail.com>

6 files changed, 243 insertions, 425 deletions

diff --git a/libraries/base/GHC/Event/Arr.hs b/libraries/base/GHC/Event/Arr.hs
new file mode 100644
index 0000000000..c2ca8f9b8d
--- /dev/null
+++ b/libraries/base/GHC/Event/Arr.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}
+
+module GHC.Event.Arr
+    (
+      Arr(..)
+    , new
+    , size
+    , read
+    , write
+    ) where
+
+import GHC.Base (($))
+import GHC.Prim (MutableArray#, RealWorld, newArray#, readArray#,
+                 sizeofMutableArray#, writeArray#)
+import GHC.Types (IO(..), Int(..))
+
+data Arr a = Arr (MutableArray# RealWorld a)
+
+new :: a -> Int -> IO (Arr a)
+new defval (I# n#) = IO $ \s0# ->
+  case newArray# n# defval s0# of (# s1#, marr# #) -> (# s1#, Arr marr# #)
+
+size :: Arr a -> Int
+size (Arr a) = I# (sizeofMutableArray# a)
+
+read :: Arr a -> Int -> IO a
+read (Arr a) (I# n#) = IO $ \s0# ->
+  case readArray# a n# s0# of (# s1#, val #) -> (# s1#, val #)
+
+write :: Arr a -> Int -> a -> IO ()
+write (Arr a) (I# n#) val = IO $ \s0# ->
+  case writeArray# a n# val s0# of s1# -> (# s1#, () #)
diff --git a/libraries/base/GHC/Event/IntMap.hs b/libraries/base/GHC/Event/IntMap.hs
deleted file mode 100644
index c850311a1b..0000000000
--- a/libraries/base/GHC/Event/IntMap.hs
+++ /dev/null
@@ -1,347 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.Event.IntMap
--- Copyright   :  (c) Daan Leijen 2002
---                (c) Andriy Palamarchuk 2008
--- License     :  BSD-style
--- Maintainer  :  libraries@haskell.org
--- Stability   :  provisional
--- Portability :  portable
---
--- An efficient implementation of maps from integer keys to values.
---
--- Since many function names (but not the type name) clash with
--- "Prelude" names, this module is usually imported @qualified@, e.g.
---
--- >  import Data.IntMap (IntMap)
--- >  import qualified Data.IntMap as IntMap
---
--- The implementation is based on /big-endian patricia trees/.  This data
--- structure performs especially well on binary operations like 'union'
--- and 'intersection'.  However, my benchmarks show that it is also
--- (much) faster on insertions and deletions when compared to a generic
--- size-balanced map implementation (see "Data.Map").
---
---    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",
---      Workshop on ML, September 1998, pages 77-86,
---      <http://citeseer.ist.psu.edu/okasaki98fast.html>
---
---    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
---      Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
---      October 1968, pages 514-534.
---
--- Operation comments contain the operation time complexity in
--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.
--- Many operations have a worst-case complexity of /O(min(n,W))/.
--- This means that the operation can become linear in the number of
--- elements with a maximum of /W/ -- the number of bits in an 'Int'
--- (32 or 64).
---
------------------------------------------------------------------------------
-
-module GHC.Event.IntMap
-    (
-    -- * Map type
-    IntMap
-    , Key
-
-    -- * Query
-    , lookup
-    , member
-
-    -- * Construction
-    , empty
-
-    -- * Insertion
-    , insertWith
-
-    -- * Delete\/Update
-    , delete
-    , updateWith
-
-    -- * Traversal
-    -- ** Fold
-    , foldWithKey
-
-    -- * Conversion
-    , keys
-    ) where
-
-import Data.Bits
-
-import Data.Maybe (Maybe(..))
-import GHC.Base hiding (foldr)
-import GHC.Num (Num(..))
-import GHC.Real (fromIntegral)
-import GHC.Show (Show(showsPrec), showParen, shows, showString)
-
-#if !defined(__GLASGOW_HASKELL__)
-import Data.Word
-#endif
-
--- | A @Nat@ is a natural machine word (an unsigned Int)
-type Nat = Word
-
-natFromInt :: Key -> Nat
-natFromInt i = fromIntegral i
-
-intFromNat :: Nat -> Key
-intFromNat w = fromIntegral w
-
-shiftRL :: Nat -> Key -> Nat
-#if __GLASGOW_HASKELL__
--- GHC: use unboxing to get @shiftRL@ inlined.
-shiftRL (W# x) (I# i) = W# (shiftRL# x i)
-#else
-shiftRL x i = shiftR x i
-#endif
-
-------------------------------------------------------------------------
--- Types
-
--- | A map of integers to values @a@.
-data IntMap a = Nil
-              | Tip {-# UNPACK #-} !Key !a
-              | Bin {-# UNPACK #-} !Prefix
-                    {-# UNPACK #-} !Mask
-                    !(IntMap a)
-                    !(IntMap a)
-
-type Prefix = Int
-type Mask   = Int
-type Key    = Int
-
-------------------------------------------------------------------------
--- Query
-
--- | /O(min(n,W))/ Lookup the value at a key in the map.  See also
--- 'Data.Map.lookup'.
-lookup :: Key -> IntMap a -> Maybe a
-lookup k t = let nk = natFromInt k in seq nk (lookupN nk t)
-
-lookupN :: Nat -> IntMap a -> Maybe a
-lookupN k t
-  = case t of
-      Bin _ m l r
-        | zeroN k (natFromInt m) -> lookupN k l
-        | otherwise              -> lookupN k r
-      Tip kx x
-        | (k == natFromInt kx)  -> Just x
-        | otherwise             -> Nothing
-      Nil -> Nothing
-
--- | /O(min(n,W))/. Is the key a member of the map?
---
--- > member 5 (fromList [(5,'a'), (3,'b')]) == True
--- > member 1 (fromList [(5,'a'), (3,'b')]) == False
-
-member :: Key -> IntMap a -> Bool
-member k m
-  = case lookup k m of
-      Nothing -> False
-      Just _  -> True
-
-------------------------------------------------------------------------
--- Construction
-
--- | /O(1)/ The empty map.
---
--- > empty      == fromList []
--- > size empty == 0
-empty :: IntMap a
-empty = Nil
-
-------------------------------------------------------------------------
--- Insert
-
--- | /O(min(n,W))/ Insert with a function, combining new value and old
--- value.  @insertWith f key value mp@ will insert the pair (key,
--- value) into @mp@ if key does not exist in the map.  If the key does
--- exist, the function will insert the pair (key, f new_value
--- old_value).  The result is a pair where the first element is the
--- old value, if one was present, and the second is the modified map.
-insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
-insertWith f k x t = case t of
-    Bin p m l r
-        | nomatch k p m -> (Nothing, join k (Tip k x) p t)
-        | zero k m      -> let (found, l') = insertWith f k x l
-                           in (found, Bin p m l' r)
-        | otherwise     -> let (found, r') = insertWith f k x r
-                           in (found, Bin p m l r')
-    Tip ky y
-        | k == ky       -> (Just y, Tip k (f x y))
-        | otherwise     -> (Nothing, join k (Tip k x) ky t)
-    Nil                 -> (Nothing, Tip k x)
-
-
-------------------------------------------------------------------------
--- Delete/Update
-
--- | /O(min(n,W))/. Delete a key and its value from the map.  When the
--- key is not a member of the map, the original map is returned.  The
--- result is a pair where the first element is the value associated
--- with the deleted key, if one existed, and the second element is the
--- modified map.
-delete :: Key -> IntMap a -> (Maybe a, IntMap a)
-delete k t = case t of
-   Bin p m l r
-        | nomatch k p m -> (Nothing, t)
-        | zero k m      -> let (found, l') = delete k l
-                           in (found, bin p m l' r)
-        | otherwise     -> let (found, r') = delete k r
-                           in (found, bin p m l r')
-   Tip ky y
-        | k == ky       -> (Just y, Nil)
-        | otherwise     -> (Nothing, t)
-   Nil                  -> (Nothing, Nil)
-
-updateWith :: (a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a)
-updateWith f k t = case t of
-    Bin p m l r
-        | nomatch k p m -> (Nothing, t)
-        | zero k m      -> let (found, l') = updateWith f k l
-                           in (found, bin p m l' r)
-        | otherwise     -> let (found, r') = updateWith f k r
-                           in (found, bin p m l r')
-    Tip ky y
-        | k == ky       -> case (f y) of
-                               Just y' -> (Just y, Tip ky y')
-                               Nothing -> (Just y, Nil)
-        | otherwise     -> (Nothing, t)
-    Nil                 -> (Nothing, Nil)
--- | /O(n)/. Fold the keys and values in the map, such that
--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
--- For example,
---
--- > keys map = foldWithKey (\k x ks -> k:ks) [] map
---
--- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
--- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
-
-foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldWithKey f z t
-  = foldr f z t
-
--- | /O(n)/. Convert the map to a list of key\/value pairs.
---
--- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
--- > toList empty == []
-
-toList :: IntMap a -> [(Key,a)]
-toList t
-  = foldWithKey (\k x xs -> (k,x):xs) [] t
-
-foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr f z t
-  = case t of
-      Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r  -- put negative numbers before.
-      Bin _ _ _ _ -> foldr' f z t
-      Tip k x     -> f k x z
-      Nil         -> z
-
-foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr' f z t
-  = case t of
-      Bin _ _ l r -> foldr' f (foldr' f z r) l
-      Tip k x     -> f k x z
-      Nil         -> z
-
--- | /O(n)/. Return all keys of the map in ascending order.
---
--- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
--- > keys empty == []
-
-keys  :: IntMap a -> [Key]
-keys m
-  = foldWithKey (\k _ ks -> k:ks) [] m
-
-------------------------------------------------------------------------
--- Eq
-
-instance Eq a => Eq (IntMap a) where
-    t1 == t2 = equal t1 t2
-    t1 /= t2 = nequal t1 t2
-
-equal :: Eq a => IntMap a -> IntMap a -> Bool
-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
-    = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
-equal (Tip kx x) (Tip ky y)
-    = (kx == ky) && (x==y)
-equal Nil Nil = True
-equal _   _   = False
-
-nequal :: Eq a => IntMap a -> IntMap a -> Bool
-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
-    = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
-nequal (Tip kx x) (Tip ky y)
-    = (kx /= ky) || (x/=y)
-nequal Nil Nil = False
-nequal _   _   = True
-
-instance Show a => Show (IntMap a) where
-  showsPrec d m   = showParen (d > 10) $
-    showString "fromList " . shows (toList m)
-
-------------------------------------------------------------------------
--- Utility functions
-
-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
-join p1 t1 p2 t2
-  | zero p1 m = Bin p m t1 t2
-  | otherwise = Bin p m t2 t1
-  where
-    m = branchMask p1 p2
-    p = mask p1 m
-
--- | @bin@ assures that we never have empty trees within a tree.
-bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
-bin _ _ l Nil = l
-bin _ _ Nil r = r
-bin p m l r   = Bin p m l r
-
-------------------------------------------------------------------------
--- Endian independent bit twiddling
-
-zero :: Key -> Mask -> Bool
-zero i m = (natFromInt i) .&. (natFromInt m) == 0
-
-nomatch :: Key -> Prefix -> Mask -> Bool
-nomatch i p m = (mask i m) /= p
-
-mask :: Key -> Mask -> Prefix
-mask i m = maskW (natFromInt i) (natFromInt m)
-
-zeroN :: Nat -> Nat -> Bool
-zeroN i m = (i .&. m) == 0
-
-------------------------------------------------------------------------
--- Big endian operations
-
-maskW :: Nat -> Nat -> Prefix
-maskW i m = intFromNat (i .&. (complement (m-1) `xor` m))
-
-branchMask :: Prefix -> Prefix -> Mask
-branchMask p1 p2
-    = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
-
--- The highestBitMask implementation is based on
--- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2
--- which has been put in the public domain.
-
--- | Return a word where only the highest bit is set.
-highestBitMask :: Nat -> Nat
-highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1
-                        x3 = x2 .|. x2 `shiftRL` 2
-                        x4 = x3 .|. x3 `shiftRL` 4
-                        x5 = x4 .|. x4 `shiftRL` 8
-                        x6 = x5 .|. x5 `shiftRL` 16
-#if !(WORD_SIZE_IN_BITS==32)
-                        x7 = x6 .|. x6 `shiftRL` 32
-                     in x7 `xor` (x7 `shiftRL` 1)
-#else
-                     in x6 `xor` (x6 `shiftRL` 1)
-#endif
-{-# INLINE highestBitMask #-}
diff --git a/libraries/base/GHC/Event/IntTable.hs b/libraries/base/GHC/Event/IntTable.hs
new file mode 100644
index 0000000000..d8cbcc0d45
--- /dev/null
+++ b/libraries/base/GHC/Event/IntTable.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE BangPatterns, NoImplicitPrelude, RecordWildCards, Trustworthy #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module GHC.Event.IntTable
+    (
+      IntTable
+    , new
+    , lookup
+    , insertWith
+    , reset
+    , delete
+    , updateWith
+    ) where
+
+import Control.Monad ((=<<), liftM, unless, when)
+import Data.Bits ((.&.), shiftL, shiftR)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Maybe (Maybe(..), isJust)
+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)
+import Foreign.Storable (peek, poke)
+import GHC.Base (Monad(..), ($), const, otherwise)
+import GHC.Classes (Eq(..), Ord(..))
+import GHC.Event.Arr (Arr)
+import GHC.Num (Num(..))
+import GHC.Prim (seq)
+import GHC.Types (Bool(..), IO(..), Int(..))
+import qualified GHC.Event.Arr as Arr
+
+-- A very simple chained integer-keyed mutable hash table. We use
+-- power-of-two sizing, grow at a load factor of 0.75, and never
+-- shrink. The "hash function" is the identity function.
+
+newtype IntTable a = IntTable (IORef (IT a))
+
+data IT a = IT {
+      tabArr  :: {-# UNPACK #-} !(Arr (Bucket a))
+    , tabSize :: {-# UNPACK #-} !(ForeignPtr Int)
+    }
+
+data Bucket a = Empty
+              | Bucket {
+      bucketKey   :: {-# UNPACK #-} !Int
+    , bucketValue :: a
+    , bucketNext  :: Bucket a
+    }
+
+lookup :: Int -> IntTable a -> IO (Maybe a)
+lookup k (IntTable ref) = do
+  let go Bucket{..}
+        | bucketKey == k = return (Just bucketValue)
+        | otherwise      = go bucketNext
+      go _ = return Nothing
+  it@IT{..} <- readIORef ref
+  go =<< Arr.read tabArr (indexOf k it)
+
+new :: Int -> IO (IntTable a)
+new capacity = IntTable `liftM` (newIORef =<< new_ capacity)
+
+new_ :: Int -> IO (IT a)
+new_ capacity = do
+  arr <- Arr.new Empty capacity
+  size <- mallocForeignPtr
+  withForeignPtr size $ \ptr -> poke ptr 0
+  return IT { tabArr = arr
+            , tabSize = size
+            }
+
+grow :: IT a -> IORef (IT a) -> Int -> IO ()
+grow oldit ref size = do
+  newit <- new_ (Arr.size (tabArr oldit) `shiftL` 1)
+  let copySlot n !i
+        | n == size = return ()
+        | otherwise = do
+          let copyBucket !m Empty          = copySlot m (i+1)
+              copyBucket  m bkt@Bucket{..} = do
+                let idx = indexOf bucketKey newit
+                next <- Arr.read (tabArr newit) idx
+                Arr.write (tabArr newit) idx bkt { bucketNext = next }
+                copyBucket (m+1) bucketNext
+          copyBucket n =<< Arr.read (tabArr oldit) i
+  copySlot 0 0
+  withForeignPtr (tabSize newit) $ \ptr -> poke ptr size
+  writeIORef ref newit
+
+insertWith :: (a -> a -> a) -> Int -> a -> IntTable a -> IO (Maybe a)
+insertWith f k v inttable@(IntTable ref) = do
+  it@IT{..} <- readIORef ref
+  let idx = indexOf k it
+      go seen bkt@Bucket{..}
+        | bucketKey == k = do
+          let !v' = f v bucketValue
+              !next = seen <> bucketNext
+              Empty        <> bs = bs
+              b@Bucket{..} <> bs = b { bucketNext = bucketNext <> bs }
+          Arr.write tabArr idx (Bucket k v' next)
+          return (Just bucketValue)
+        | otherwise = go bkt { bucketNext = seen } bucketNext
+      go seen _ = withForeignPtr tabSize $ \ptr -> do
+        size <- peek ptr
+        if size + 1 >= Arr.size tabArr - (Arr.size tabArr `shiftR` 2)
+          then grow it ref size >> insertWith f k v inttable
+          else do
+            v `seq` Arr.write tabArr idx (Bucket k v seen)
+            poke ptr (size + 1)
+            return Nothing
+  go Empty =<< Arr.read tabArr idx
+{-# INLINABLE insertWith #-}
+
+-- | Used to undo the effect of a prior insertWith.
+reset :: Int -> Maybe a -> IntTable a -> IO ()
+reset k (Just v) tbl = insertWith const k v tbl >> return ()
+reset k Nothing  tbl = delete k tbl >> return ()
+
+indexOf :: Int -> IT a -> Int
+indexOf k IT{..} = k .&. (Arr.size tabArr - 1)
+
+delete :: Int -> IntTable a -> IO (Maybe a)
+delete k t = updateWith (const Nothing) k t
+
+updateWith :: (a -> Maybe a) -> Int -> IntTable a -> IO (Maybe a)
+updateWith f k (IntTable ref) = do
+  it@IT{..} <- readIORef ref
+  let idx = indexOf k it
+      go changed bkt@Bucket{..}
+        | bucketKey == k =
+            let fbv = f bucketValue
+                !nb = case fbv of
+                        Just val -> bkt { bucketValue = val }
+                        Nothing  -> bucketNext
+            in (fbv, Just bucketValue, nb)
+        | otherwise = case go changed bucketNext of
+                        (fbv, ov, nb) -> (fbv, ov, bkt { bucketNext = nb })
+      go _ e = (Nothing, Nothing, e)
+  (fbv, oldVal, newBucket) <- go False `liftM` Arr.read tabArr idx
+  when (isJust oldVal) $ do
+    Arr.write tabArr idx newBucket
+    unless (isJust fbv) $
+      withForeignPtr tabSize $ \ptr -> do
+        size <- peek ptr
+        poke ptr (size - 1)
+  return oldVal
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index a51491508c..8c8858b079 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -48,16 +48,15 @@ module GHC.Event.Manager
 ------------------------------------------------------------------------
 -- Imports
 
-import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar, putMVar,
-                                tryPutMVar, takeMVar)
+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(..))
+import Data.Maybe (Maybe(..), maybe)
 import Data.Monoid (mappend, mconcat, mempty)
-import Data.Tuple (snd)
 import GHC.Arr (Array, (!), listArray)
 import GHC.Base
 import GHC.Conc.Signal (runHandlers)
@@ -67,12 +66,13 @@ 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.IntMap as IM
+import qualified GHC.Event.IntTable as IT
 import qualified GHC.Event.Internal as I
 
 #if defined(HAVE_KQUEUE)
@@ -113,7 +113,7 @@ data State = Created
 -- | The event manager state.
 data EventManager = EventManager
     { emBackend      :: !Backend
-    , emFds          :: {-# UNPACK #-} !(Array Int (MVar (IM.IntMap [FdData])))
+    , emFds          :: {-# UNPACK #-} !(Array Int (MVar (IntTable [FdData])))
     , emState        :: {-# UNPACK #-} !(IORef State)
     , emUniqueSource :: {-# UNPACK #-} !UniqueSource
     , emControl      :: {-# UNPACK #-} !Control
@@ -129,7 +129,7 @@ hashFd :: Fd -> Int
 hashFd fd = fromIntegral fd .&. (callbackArraySize - 1)
 {-# INLINE hashFd #-}
 
-callbackTableVar :: EventManager -> Fd -> MVar (IM.IntMap [FdData])
+callbackTableVar :: EventManager -> Fd -> MVar (IntTable [FdData])
 callbackTableVar mgr fd = emFds mgr ! hashFd fd
 {-# INLINE callbackTableVar #-}
 
@@ -171,7 +171,7 @@ new oneShot = newWith oneShot =<< newDefaultBackend
 newWith :: Bool -> Backend -> IO EventManager
 newWith oneShot be = do
   iofds <- fmap (listArray (0, callbackArraySize-1)) $
-           replicateM callbackArraySize (newMVar IM.empty)
+           replicateM callbackArraySize (newMVar =<< IT.new 8)
   ctrl <- newControl False
   state <- newIORef Created
   us <- newSource
@@ -294,27 +294,28 @@ registerFd_ mgr@(EventManager{..}) cb fd evs = do
   let fd'  = fromIntegral fd
       reg  = FdKey fd u
       !fdd = FdData reg evs cb
-  (modify,ok) <- modifyMVar (callbackTableVar mgr fd) $ \oldMap ->
+  (modify,ok) <- withMVar (callbackTableVar mgr fd) $ \tbl ->
     if haveOneShot && emOneShot
-    then do let (n,evs') = case IM.insertWith (++) fd' [fdd] oldMap of
-                  (Nothing,   n') -> (n', evs)
-                  (Just prev, n') -> (n', combineEvents evs prev)
-            ok <- I.modifyFdOnce emBackend fd evs'
-            if ok
-              then return (n, (False, True))
-              else return (oldMap, (False, False))
-    else
-      let (!newMap, (oldEvs, newEvs)) =
-            case IM.insertWith (++) fd' [fdd] oldMap of
-              (Nothing,   n) -> (n, (mempty, evs))
-              (Just prev, n) -> (n, (eventsOf prev, combineEvents evs prev))
+    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
-      in do ok <- if modify
-                  then I.modifyFd emBackend fd oldEvs newEvs
-                  else return True
-            if ok
-              then return (newMap, (modify, True))
-              else return (oldMap, (False, False))
+      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)
   -- this simulates behavior of old IO manager:
   -- i.e. just call the callback if the registration fails.
   when (not ok) (cb reg evs)
@@ -358,31 +359,25 @@ wakeManager mgr = sendWakeup (emControl mgr)
 eventsOf :: [FdData] -> Event
 eventsOf = mconcat . map fdEvents
 
-pairEvents :: [FdData] -> IM.IntMap [FdData] -> Int -> (Event, Event)
-pairEvents prev m fd = let l = eventsOf prev
-                           r = case IM.lookup fd m of
-                                 Nothing  -> mempty
-                                 Just fds -> eventsOf fds
-                       in (l, r)
-
 -- | Drop a previous file descriptor registration, without waking the
 -- event manager thread.  The return value indicates whether the event
 -- manager ought to be woken.
 unregisterFd_ :: EventManager -> FdKey -> IO Bool
 unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) =
-  modifyMVar (callbackTableVar mgr fd) $ \oldMap -> do
+  withMVar (callbackTableVar mgr fd) $ \tbl -> do
     let dropReg = nullToNothing . filter ((/= u) . keyUnique . fdKey)
         fd' = fromIntegral fd
-        (!newMap, (oldEvs, newEvs)) =
-            case IM.updateWith dropReg fd' oldMap of
-              (Nothing,   _)    -> (oldMap, (mempty, mempty))
-              (Just prev, newm) -> (newm, pairEvents prev newm fd')
-        modify = oldEvs /= newEvs
+        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 (newMap, modify)
+    return modify
 
 -- | Drop a previous file descriptor registration.
 unregisterFd :: EventManager -> FdKey -> IO ()
@@ -393,17 +388,17 @@ unregisterFd mgr reg = do
 -- | Close a file descriptor in a race-safe way.
 closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO ()
 closeFd mgr close fd = do
-  fds <- modifyMVar (callbackTableVar mgr fd) $ \oldMap -> do
-    case IM.delete (fromIntegral fd) oldMap of
-      (Nothing,  _)       -> do close fd
-                                return (oldMap, [])
-      (Just fds, !newMap) -> 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 (newMap, fds)
+        return fds
   forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose)
 
 -- | Close a file descriptor in a race-safe way.
@@ -411,20 +406,21 @@ closeFd mgr close fd = do
 -- holds the callback table lock for the fd. It must hold this lock because
 -- this command executes a backend command on the fd.
 closeFd_ :: EventManager
-            -> IM.IntMap [FdData]
+            -> IntTable [FdData]
             -> Fd
-            -> IO (IM.IntMap [FdData], IO ())
-closeFd_ mgr oldMap fd = do
-  case IM.delete (fromIntegral fd) oldMap of
-    (Nothing,  _)       -> return (oldMap, return ())
-    (Just fds, !newMap) -> do
+            -> 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
-      let runCbs =
-            forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose)
-      return (newMap, runCbs)
+      return $
+        forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose)
+
 ------------------------------------------------------------------------
 -- Utilities
 
@@ -436,14 +432,13 @@ onFdEvent mgr fd evs =
   else
     if emOneShot mgr
     then
-      do fdds <- modifyMVar (callbackTableVar mgr fd) $ \oldMap ->
-            case IM.delete fd' oldMap of
-              (Nothing, _)       -> return (oldMap, [])
-              (Just cbs, newmap) -> selectCallbacks newmap cbs
+      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 fds <- readMVar (callbackTableVar mgr fd)
-         case IM.lookup fd' fds of
+      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 ()
@@ -451,16 +446,15 @@ onFdEvent mgr fd evs =
     fd' :: Int
     fd' = fromIntegral fd
 
-    selectCallbacks ::
-      IM.IntMap [FdData] -> [FdData] -> IO (IM.IntMap [FdData], [FdData])
-    selectCallbacks curmap cbs = aux cbs [] []
+    selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]
+    selectCallbacks tbl cbs = aux cbs [] []
       where
         -- nothing to rearm.
         aux [] _    []          =
           if haveOneShot
-          then return (curmap, cbs)
+          then return cbs
           else do _ <- I.modifyFd (emBackend mgr) fd (eventsOf cbs) mempty
-                  return (curmap, cbs)
+                  return cbs
 
         -- reinsert and rearm; note that we already have the lock on the
         -- callback table for this fd, and we deleted above, so we know there
@@ -469,7 +463,8 @@ onFdEvent mgr fd evs =
           _ <- if haveOneShot
                then I.modifyFdOnce (emBackend mgr) fd $ eventsOf saved
                else I.modifyFd (emBackend mgr) fd (eventsOf cbs) $ eventsOf saved
-          return (snd $ IM.insertWith (\_ _ -> saved) fd' saved curmap, fdds)
+          _ <- IT.insertWith (\_ _ -> saved) fd' saved tbl
+          return fdds
 
         -- continue, saving those callbacks that don't match the event
         aux (fdd@(FdData _ evs' _) : cbs') fdds saved
diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs
index 61abbd078c..310ff4f044 100644
--- a/libraries/base/GHC/Event/Thread.hs
+++ b/libraries/base/GHC/Event/Thread.hs
@@ -15,8 +15,9 @@ module GHC.Event.Thread
     ) where
 
 import Control.Exception (finally)
-import Control.Monad (forM, forM_, zipWithM, zipWithM_, when)
+import Control.Monad (forM, forM_, sequence_, zipWithM, when)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.List (zipWith3)
 import Data.Maybe (Maybe(..))
 import Data.Tuple (snd)
 import Foreign.C.Error (eBADF, errnoToIOError)
@@ -99,15 +100,10 @@ closeFdWith close fd = do
     return mgr
   mask_ $ do
     tables <- forM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd
-    tableAndCbApps <- zipWithM
-                      (\mgr table -> M.closeFd_ mgr table fd)
-                      mgrs
-                      tables
-    close fd `finally` zipWithM_ finish mgrs tableAndCbApps
+    cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables
+    close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps)
   where
-    finish mgr (table', cbApp) = do
-      putMVar (M.callbackTableVar mgr fd) table'
-      cbApp
+    finish mgr table cbApp = putMVar (M.callbackTableVar mgr fd) table >> cbApp
 
 threadWait :: Event -> Fd -> IO ()
 threadWait evt fd = mask_ $ do
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 2cd17ff7bd..0b498637a7 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -242,11 +242,12 @@ Library {
         exposed-modules:
             GHC.Event
         other-modules:
+            GHC.Event.Arr
             GHC.Event.Array
             GHC.Event.Clock
             GHC.Event.Control
             GHC.Event.EPoll
-            GHC.Event.IntMap
+            GHC.Event.IntTable
             GHC.Event.Internal
             GHC.Event.KQueue
             GHC.Event.Manager