Stop using hedge algorithms
[packages/containers.git] / Data / IntMap / Base.hs
index f2ae1a8..f45e7d1 100644 (file)
@@ -1,10 +1,18 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 #if __GLASGOW_HASKELL__
 {-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 #endif
 #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
 {-# LANGUAGE Trustworthy #-}
 #endif
+#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE TypeFamilies #-}
+#endif
+
+#include "containers.h"
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.IntMap.Base
@@ -20,7 +28,7 @@
 -----------------------------------------------------------------------------
 
 -- [Note: INLINE bit fiddling]
--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- It is essential that the bit fiddling functions like mask, zero, branchMask
 -- etc are inlined. If they do not, the memory allocation skyrockets. The GHC
 -- usually gets it right, but it is disastrous if it does not. Therefore we
@@ -28,7 +36,7 @@
 
 
 -- [Note: Local 'go' functions and capturing]
--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Care must be taken when using 'go' function which captures an argument.
 -- Sometimes (for example when the argument is passed to a data constructor,
 -- as in insert), GHC heap-allocates more than necessary. Therefore C-- code
@@ -37,7 +45,7 @@
 
 
 -- [Note: Order of constructors]
--- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- The order of constructors of IntMap matters when considering performance.
 -- Currently in GHC 7.0, when type has 3 constructors, they are matched from
 -- the first to the last -- the best performance is achieved when the
 -- improves the benchmark by circa 10%.
 
 module Data.IntMap.Base (
-            -- * Map type
-              IntMap(..), Key          -- instance Eq,Show
-
-            -- * Operators
-            , (!), (\\)
-
-            -- * Query
-            , null
-            , size
-            , member
-            , notMember
-            , lookup
-            , findWithDefault
-
-            -- * Construction
-            , empty
-            , singleton
-
-            -- ** Insertion
-            , insert
-            , insertWith
-            , insertWithKey
-            , insertLookupWithKey
-
-            -- ** Delete\/Update
-            , delete
-            , adjust
-            , adjustWithKey
-            , update
-            , updateWithKey
-            , updateLookupWithKey
-            , alter
-
-            -- * Combine
-
-            -- ** Union
-            , union
-            , unionWith
-            , unionWithKey
-            , unions
-            , unionsWith
-
-            -- ** Difference
-            , difference
-            , differenceWith
-            , differenceWithKey
-
-            -- ** Intersection
-            , intersection
-            , intersectionWith
-            , intersectionWithKey
-
-            -- ** Universal combining function
-            , mergeWithKey
-            , mergeWithKey'
-
-            -- * Traversal
-            -- ** Map
-            , map
-            , mapWithKey
-            , traverseWithKey
-            , mapAccum
-            , mapAccumWithKey
-            , mapAccumRWithKey
-            , mapKeys
-            , mapKeysWith
-            , mapKeysMonotonic
-
-            -- * Folds
-            , foldr
-            , foldl
-            , foldrWithKey
-            , foldlWithKey
-            -- ** Strict folds
-            , foldr'
-            , foldl'
-            , foldrWithKey'
-            , foldlWithKey'
-
-            -- * Conversion
-            , elems
-            , keys
-            , keysSet
-            , assocs
-
-            -- ** Lists
-            , toList
-            , fromList
-            , fromListWith
-            , fromListWithKey
-
-            -- ** Ordered lists
-            , toAscList
-            , toDescList
-            , fromAscList
-            , fromAscListWith
-            , fromAscListWithKey
-            , fromDistinctAscList
-
-            -- * Filter
-            , filter
-            , filterWithKey
-            , partition
-            , partitionWithKey
-
-            , mapMaybe
-            , mapMaybeWithKey
-            , mapEither
-            , mapEitherWithKey
-
-            , split
-            , splitLookup
-
-            -- * Submap
-            , isSubmapOf, isSubmapOfBy
-            , isProperSubmapOf, isProperSubmapOfBy
-
-            -- * Min\/Max
-            , findMin
-            , findMax
-            , deleteMin
-            , deleteMax
-            , deleteFindMin
-            , deleteFindMax
-            , updateMin
-            , updateMax
-            , updateMinWithKey
-            , updateMaxWithKey
-            , minView
-            , maxView
-            , minViewWithKey
-            , maxViewWithKey
-
-            -- * Debugging
-            , showTree
-            , showTreeWith
-
-            -- * Internal types
-            , Mask, Prefix, Nat
-
-            -- * Utility
-            , natFromInt
-            , intFromNat
-            , shiftRL
-            , join
-            , bin
-            , zero
-            , nomatch
-            , match
-            , mask
-            , maskW
-            , shorter
-            , branchMask
-            , highestBitMask
-            , foldlStrict
-            ) where
+    -- * Map type
+      IntMap(..), Key          -- instance Eq,Show
+
+    -- * Operators
+    , (!), (\\)
+
+    -- * Query
+    , null
+    , size
+    , member
+    , notMember
+    , lookup
+    , findWithDefault
+    , lookupLT
+    , lookupGT
+    , lookupLE
+    , lookupGE
+
+    -- * Construction
+    , empty
+    , singleton
+
+    -- ** Insertion
+    , insert
+    , insertWith
+    , insertWithKey
+    , insertLookupWithKey
+
+    -- ** Delete\/Update
+    , delete
+    , adjust
+    , adjustWithKey
+    , update
+    , updateWithKey
+    , updateLookupWithKey
+    , alter
+    , alterF
+
+    -- * Combine
+
+    -- ** Union
+    , union
+    , unionWith
+    , unionWithKey
+    , unions
+    , unionsWith
+
+    -- ** Difference
+    , difference
+    , differenceWith
+    , differenceWithKey
+
+    -- ** Intersection
+    , intersection
+    , intersectionWith
+    , intersectionWithKey
+
+    -- ** Universal combining function
+    , mergeWithKey
+    , mergeWithKey'
+
+    -- * Traversal
+    -- ** Map
+    , map
+    , mapWithKey
+    , traverseWithKey
+    , mapAccum
+    , mapAccumWithKey
+    , mapAccumRWithKey
+    , mapKeys
+    , mapKeysWith
+    , mapKeysMonotonic
+
+    -- * Folds
+    , foldr
+    , foldl
+    , foldrWithKey
+    , foldlWithKey
+    , foldMapWithKey
+
+    -- ** Strict folds
+    , foldr'
+    , foldl'
+    , foldrWithKey'
+    , foldlWithKey'
+
+    -- * Conversion
+    , elems
+    , keys
+    , assocs
+    , keysSet
+    , fromSet
+
+    -- ** Lists
+    , toList
+    , fromList
+    , fromListWith
+    , fromListWithKey
+
+    -- ** Ordered lists
+    , toAscList
+    , toDescList
+    , fromAscList
+    , fromAscListWith
+    , fromAscListWithKey
+    , fromDistinctAscList
+
+    -- * Filter
+    , filter
+    , filterWithKey
+    , restrictKeys
+    , withoutKeys
+    , partition
+    , partitionWithKey
+
+    , mapMaybe
+    , mapMaybeWithKey
+    , mapEither
+    , mapEitherWithKey
+
+    , split
+    , splitLookup
+    , splitRoot
+
+    -- * Submap
+    , isSubmapOf, isSubmapOfBy
+    , isProperSubmapOf, isProperSubmapOfBy
+
+    -- * Min\/Max
+    , findMin
+    , findMax
+    , deleteMin
+    , deleteMax
+    , deleteFindMin
+    , deleteFindMax
+    , updateMin
+    , updateMax
+    , updateMinWithKey
+    , updateMaxWithKey
+    , minView
+    , maxView
+    , minViewWithKey
+    , maxViewWithKey
+
+    -- * Debugging
+    , showTree
+    , showTreeWith
+
+    -- * Internal types
+    , Mask, Prefix, Nat
+
+    -- * Utility
+    , natFromInt
+    , intFromNat
+    , link
+    , bin
+    , binCheckLeft
+    , binCheckRight
+    , zero
+    , nomatch
+    , match
+    , mask
+    , maskW
+    , shorter
+    , branchMask
+    , highestBitMask
+    ) where
+
+#if !(MIN_VERSION_base(4,8,0))
+import Control.Applicative (Applicative(pure, (<*>)), (<$>))
+import Data.Monoid (Monoid(..))
+import Data.Traversable (Traversable(traverse))
+import Data.Word (Word)
+#endif
+#if MIN_VERSION_base(4,9,0)
+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+#endif
 
+import Control.DeepSeq (NFData(rnf))
+import Control.Monad (liftM)
 import Data.Bits
-
-import Prelude hiding (lookup,map,filter,foldr,foldl,null)
-import qualified Data.IntSet as IntSet
-import Data.Monoid (Monoid(..))
+import qualified Data.Foldable as Foldable
 import Data.Maybe (fromMaybe)
 import Data.Typeable
-import qualified Data.Foldable as Foldable
-import Data.Traversable (Traversable(traverse))
-import Control.Applicative (Applicative(pure,(<*>)),(<$>))
-import Control.Monad ( liftM )
-import Control.DeepSeq (NFData(rnf))
+import Prelude hiding (lookup, map, filter, foldr, foldl, null)
+
+import Data.IntSet.Base (Key)
+import qualified Data.IntSet.Base as IntSet
+import Data.Utils.BitUtil
+import Data.Utils.StrictFold
+import Data.Utils.StrictPair
 
 #if __GLASGOW_HASKELL__
+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),
+                  DataType, mkDataType)
+import GHC.Exts (build)
+#if !MIN_VERSION_base(4,8,0)
+import Data.Functor ((<$))
+#endif
+#if __GLASGOW_HASKELL__ >= 708
+import qualified GHC.Exts as GHCExts
+#endif
 import Text.Read
-import Data.Data (Data(..), mkNoRepType)
 #endif
-
-#if __GLASGOW_HASKELL__
-import GHC.Exts ( Word(..), Int(..), shiftRL#, build )
-#else
-import Data.Word
+#if __GLASGOW_HASKELL__ >= 709
+import Data.Coerce
 #endif
 
--- Use macros to define strictness of functions.
--- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
--- We do not use BangPatterns, because they are not in any standard and we
--- want the compilers to be compiled by as many compilers as possible.
-#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
 
 -- A "Nat" is a natural machine word (an unsigned Int)
 type Nat = Word
@@ -244,18 +274,6 @@ intFromNat :: Nat -> Key
 intFromNat = fromIntegral
 {-# INLINE intFromNat #-}
 
-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
-{-# INLINE shiftRL #-}
-#endif
-
 {--------------------------------------------------------------------
   Types
 --------------------------------------------------------------------}
@@ -264,13 +282,15 @@ shiftRL x i   = shiftR x i
 -- | A map of integers to values @a@.
 
 -- See Note: Order of constructors
-data IntMap a = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)
+data IntMap a = Bin {-# UNPACK #-} !Prefix
+                    {-# UNPACK #-} !Mask
+                    !(IntMap a)
+                    !(IntMap a)
               | Tip {-# UNPACK #-} !Key a
               | Nil
 
 type Prefix = Int
 type Mask   = Int
-type Key    = Int
 
 {--------------------------------------------------------------------
   Operators
@@ -283,7 +303,7 @@ type Key    = Int
 -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
 
 (!) :: IntMap a -> Key -> a
-m ! k = find k m
+(!) m k = find k m
 
 -- | Same as 'difference'.
 (\\) :: IntMap a -> IntMap b -> IntMap a
@@ -297,21 +317,78 @@ infixl 9 \\{-This comment teaches CPP correct behaviour -}
 
 instance Monoid (IntMap a) where
     mempty  = empty
-    mappend = union
     mconcat = unions
+#if !(MIN_VERSION_base(4,9,0))
+    mappend = union
+#else
+    mappend = (<>)
+
+instance Semigroup (IntMap a) where
+    (<>)    = union
+    stimes  = stimesIdempotentMonoid
+#endif
 
 instance Foldable.Foldable IntMap where
-  fold Nil = mempty
-  fold (Tip _ v) = v
-  fold (Bin _ _ l r) = Foldable.fold l `mappend` Foldable.fold r
+  fold = go
+    where go Nil = mempty
+          go (Tip _ v) = v
+          go (Bin _ _ l r) = go l `mappend` go r
+  {-# INLINABLE fold #-}
   foldr = foldr
+  {-# INLINE foldr #-}
   foldl = foldl
-  foldMap _ Nil = mempty
-  foldMap f (Tip _k v) = f v
-  foldMap f (Bin _ _ l r) = Foldable.foldMap f l `mappend` Foldable.foldMap f r
+  {-# INLINE foldl #-}
+  foldMap f t = go t
+    where go Nil = mempty
+          go (Tip _ v) = f v
+          go (Bin _ _ l r) = go l `mappend` go r
+  {-# INLINE foldMap #-}
+
+#if MIN_VERSION_base(4,6,0)
+  foldl' = foldl'
+  {-# INLINE foldl' #-}
+  foldr' = foldr'
+  {-# INLINE foldr' #-}
+#endif
+#if MIN_VERSION_base(4,8,0)
+  length = size
+  {-# INLINE length #-}
+  null   = null
+  {-# INLINE null #-}
+  toList = elems -- NB: Foldable.toList /= IntMap.toList
+  {-# INLINE toList #-}
+  elem = go
+    where go !_ Nil = False
+          go x (Tip _ y) = x == y
+          go x (Bin _ _ l r) = go x l || go x r
+  {-# INLINABLE elem #-}
+  maximum = start
+    where start Nil = error "IntMap.Foldable.maximum: called with empty map"
+          start (Tip _ y) = y
+          start (Bin _ _ l r) = go (start l) r
+
+          go !m Nil = m
+          go m (Tip _ y) = max m y
+          go m (Bin _ _ l r) = go (go m l) r
+  {-# INLINABLE maximum #-}
+  minimum = start
+    where start Nil = error "IntMap.Foldable.minimum: called with empty map"
+          start (Tip _ y) = y
+          start (Bin _ _ l r) = go (start l) r
+
+          go !m Nil = m
+          go m (Tip _ y) = min m y
+          go m (Bin _ _ l r) = go (go m l) r
+  {-# INLINABLE minimum #-}
+  sum = foldl' (+) 0
+  {-# INLINABLE sum #-}
+  product = foldl' (*) 1
+  {-# INLINABLE product #-}
+#endif
 
 instance Traversable IntMap where
     traverse f = traverseWithKey (\_ -> f)
+    {-# INLINE traverse #-}
 
 instance NFData a => NFData (IntMap a) where
     rnf Nil = ()
@@ -325,14 +402,22 @@ instance NFData a => NFData (IntMap a) where
 --------------------------------------------------------------------}
 
 -- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
+-- We provide limited reflection services for the sake of data abstraction.
 
 instance Data a => Data (IntMap a) where
   gfoldl f z im = z fromList `f` (toList im)
-  toConstr _    = error "toConstr"
-  gunfold _ _   = error "gunfold"
-  dataTypeOf _  = mkNoRepType "Data.IntMap.IntMap"
-  dataCast1 f   = gcast1 f
+  toConstr _     = fromListConstr
+  gunfold k z c  = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> error "gunfold"
+  dataTypeOf _   = intMapDataType
+  dataCast1 f    = gcast1 f
+
+fromListConstr :: Constr
+fromListConstr = mkConstr intMapDataType "fromList" [] Prefix
+
+intMapDataType :: DataType
+intMapDataType = mkDataType "Data.IntMap.Base.IntMap" [fromListConstr]
 
 #endif
 
@@ -355,11 +440,9 @@ null _   = False
 -- > size (singleton 1 'a')                       == 1
 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
 size :: IntMap a -> Int
-size t
-  = case t of
-      Bin _ _ l r -> size l + size r
-      Tip _ _ -> 1
-      Nil     -> 0
+size (Bin _ _ l r) = size l + size r
+size (Tip _ _) = 1
+size Nil = 0
 
 -- | /O(min(n,W))/. Is the key a member of the map?
 --
@@ -368,7 +451,7 @@ size t
 
 -- See Note: Local 'go' functions and capturing]
 member :: Key -> IntMap a -> Bool
-member k = k `seq` go
+member !k = go
   where
     go (Bin p m l r) | nomatch k p m = False
                      | zero k m  = go l
@@ -388,7 +471,7 @@ notMember k m = not $ member k m
 
 -- See Note: Local 'go' functions and capturing]
 lookup :: Key -> IntMap a -> Maybe a
-lookup k = k `seq` go
+lookup !k = go
   where
     go (Bin p m l r) | nomatch k p m = Nothing
                      | zero k m  = go l
@@ -400,7 +483,7 @@ lookup k = k `seq` go
 
 -- See Note: Local 'go' functions and capturing]
 find :: Key -> IntMap a -> a
-find k = k `seq` go
+find !k = go
   where
     go (Bin p m l r) | nomatch k p m = not_found
                      | zero k m  = go l
@@ -420,7 +503,7 @@ find k = k `seq` go
 
 -- See Note: Local 'go' functions and capturing]
 findWithDefault :: a -> Key -> IntMap a -> a
-findWithDefault def k = k `seq` go
+findWithDefault def !k = go
   where
     go (Bin p m l r) | nomatch k p m = def
                      | zero k m  = go l
@@ -429,6 +512,99 @@ findWithDefault def k = k `seq` go
                   | otherwise = def
     go Nil = def
 
+-- | /O(log n)/. Find largest key smaller than the given one and return the
+-- corresponding (key, value) pair.
+--
+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing
+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+
+-- See Note: Local 'go' functions and capturing.
+lookupLT :: Key -> IntMap a -> Maybe (Key, a)
+lookupLT !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r
+                         | zero k m  = go def l
+                         | otherwise = go l r
+    go def (Tip ky y) | k <= ky   = unsafeFindMax def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMax def
+
+-- | /O(log n)/. Find smallest key greater than the given one and return the
+-- corresponding (key, value) pair.
+--
+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGT :: Key -> IntMap a -> Maybe (Key, a)
+lookupGT !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def
+                         | zero k m  = go r l
+                         | otherwise = go def r
+    go def (Tip ky y) | k >= ky   = unsafeFindMin def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMin def
+
+-- | /O(log n)/. Find largest key smaller or equal to the given one and return
+-- the corresponding (key, value) pair.
+--
+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing
+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+
+-- See Note: Local 'go' functions and capturing.
+lookupLE :: Key -> IntMap a -> Maybe (Key, a)
+lookupLE !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r
+                         | zero k m  = go def l
+                         | otherwise = go l r
+    go def (Tip ky y) | k < ky    = unsafeFindMax def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMax def
+
+-- | /O(log n)/. Find smallest key greater or equal to the given one and return
+-- the corresponding (key, value) pair.
+--
+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGE :: Key -> IntMap a -> Maybe (Key, a)
+lookupGE !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def
+                         | zero k m  = go r l
+                         | otherwise = go def r
+    go def (Tip ky y) | k > ky    = unsafeFindMin def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMin def
+
+
+-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMin :: IntMap a -> Maybe (Key, a)
+unsafeFindMin Nil = Nothing
+unsafeFindMin (Tip ky y) = Just (ky, y)
+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l
+
+-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMax :: IntMap a -> Maybe (Key, a)
+unsafeFindMax Nil = Nothing
+unsafeFindMax (Tip ky y) = Just (ky, y)
+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r
+
 {--------------------------------------------------------------------
   Construction
 --------------------------------------------------------------------}
@@ -465,16 +641,14 @@ singleton k x
 -- > insert 5 'x' empty                         == singleton 5 'x'
 
 insert :: Key -> a -> IntMap a -> IntMap a
-insert k x t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> join k (Tip k x) p t
-      | zero k m      -> Bin p m (insert k x l) r
-      | otherwise     -> Bin p m l (insert k x r)
-    Tip ky _
-      | k==ky         -> Tip k x
-      | otherwise     -> join k (Tip k x) ky t
-    Nil -> Tip k x
+insert !k x t@(Bin p m l r)
+  | nomatch k p m = link k (Tip k x) p t
+  | zero k m      = Bin p m (insert k x l) r
+  | otherwise     = Bin p m l (insert k x r)
+insert k x t@(Tip ky _)
+  | k==ky         = Tip k x
+  | otherwise     = link k (Tip k x) ky t
+insert k x Nil = Tip k x
 
 -- right-biased insertion, used by 'union'
 -- | /O(min(n,W))/. Insert with a combining function.
@@ -503,16 +677,14 @@ insertWith f k x t
 -- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"
 
 insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
-insertWithKey f k x t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> join k (Tip k x) p t
-      | zero k m      -> Bin p m (insertWithKey f k x l) r
-      | otherwise     -> Bin p m l (insertWithKey f k x r)
-    Tip ky y
-      | k==ky         -> Tip k (f k x y)
-      | otherwise     -> join k (Tip k x) ky t
-    Nil -> Tip k x
+insertWithKey f !k x t@(Bin p m l r)
+  | nomatch k p m = link k (Tip k x) p t
+  | zero k m      = Bin p m (insertWithKey f k x l) r
+  | otherwise     = Bin p m l (insertWithKey f k x r)
+insertWithKey f k x t@(Tip ky y)
+  | k == ky       = Tip k (f k x y)
+  | otherwise     = link k (Tip k x) ky t
+insertWithKey _ k x Nil = Tip k x
 
 -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
 -- is a pair where the first element is equal to (@'lookup' k map@)
@@ -530,16 +702,14 @@ insertWithKey f k x t = k `seq`
 -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])
 
 insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
-insertLookupWithKey f k x t = k `seq`
-  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') = insertLookupWithKey f k x l in (found,Bin p m l' r)
-      | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
-    Tip ky y
-      | k==ky         -> (Just y,Tip k (f k x y))
-      | otherwise     -> (Nothing,join k (Tip k x) ky t)
-    Nil -> (Nothing,Tip k x)
+insertLookupWithKey f !k x t@(Bin p m l r)
+  | nomatch k p m = (Nothing,link k (Tip k x) p t)
+  | zero k m      = let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
+  | otherwise     = let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
+insertLookupWithKey f k x t@(Tip ky y)
+  | k == ky       = (Just y,Tip k (f k x y))
+  | otherwise     = (Nothing,link k (Tip k x) ky t)
+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)
 
 
 {--------------------------------------------------------------------
@@ -553,16 +723,14 @@ insertLookupWithKey f k x t = k `seq`
 -- > delete 5 empty                         == empty
 
 delete :: Key -> IntMap a -> IntMap a
-delete k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> t
-      | zero k m      -> bin p m (delete k l) r
-      | otherwise     -> bin p m l (delete k r)
-    Tip ky _
-      | k==ky         -> Nil
-      | otherwise     -> t
-    Nil -> Nil
+delete !k t@(Bin p m l r)
+  | nomatch k p m = t
+  | zero k m      = binCheckLeft p m (delete k l) r
+  | otherwise     = binCheckRight p m l (delete k r)
+delete k t@(Tip ky _)
+  | k == ky       = Nil
+  | otherwise     = t
+delete _k Nil = Nil
 
 -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
 -- a member of the map, the original map is returned.
@@ -584,8 +752,15 @@ adjust f k m
 -- > adjustWithKey f 7 empty                         == empty
 
 adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a
-adjustWithKey f
-  = updateWithKey (\k' x -> Just (f k' x))
+adjustWithKey f !k t@(Bin p m l r)
+  | nomatch k p m = t
+  | zero k m      = Bin p m (adjustWithKey f k l) r
+  | otherwise     = Bin p m l (adjustWithKey f k r)
+adjustWithKey f k t@(Tip ky y)
+  | k == ky       = Tip ky (f k y)
+  | otherwise     = t
+adjustWithKey _ _ Nil = Nil
+
 
 -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
@@ -610,18 +785,16 @@ update f
 -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
 
 updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
-updateWithKey f k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> t
-      | zero k m      -> bin p m (updateWithKey f k l) r
-      | otherwise     -> bin p m l (updateWithKey f k r)
-    Tip ky y
-      | k==ky         -> case (f k y) of
+updateWithKey f !k t@(Bin p m l r)
+  | nomatch k p m = t
+  | zero k m      = binCheckLeft p m (updateWithKey f k l) r
+  | otherwise     = binCheckRight p m l (updateWithKey f k r)
+updateWithKey f k t@(Tip ky y)
+  | k == ky       = case (f k y) of
                            Just y' -> Tip ky y'
                            Nothing -> Nil
-      | otherwise     -> t
-    Nil -> Nil
+  | otherwise     = t
+updateWithKey _ _ Nil = Nil
 
 -- | /O(min(n,W))/. Lookup and update.
 -- The function returns original value, if it is updated.
@@ -634,18 +807,16 @@ updateWithKey f k t = k `seq`
 -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
 
 updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
-updateLookupWithKey f k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> (Nothing,t)
-      | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
-      | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
-    Tip ky y
-      | k==ky         -> case (f k y) of
-                           Just y' -> (Just y,Tip ky y')
-                           Nothing -> (Just y,Nil)
-      | otherwise     -> (Nothing,t)
-    Nil -> (Nothing,Nil)
+updateLookupWithKey f !k t@(Bin p m l r)
+  | nomatch k p m = (Nothing,t)
+  | zero k m      = let !(found,l') = updateLookupWithKey f k l in (found,binCheckLeft p m l' r)
+  | otherwise     = let !(found,r') = updateLookupWithKey f k r in (found,binCheckRight p m l r')
+updateLookupWithKey f k t@(Tip ky y)
+  | k==ky         = case (f k y) of
+                      Just y' -> (Just y,Tip ky y')
+                      Nothing -> (Just y,Nil)
+  | otherwise     = (Nothing,t)
+updateLookupWithKey _ _ Nil = (Nothing,Nil)
 
 
 
@@ -653,25 +824,59 @@ updateLookupWithKey f k t = k `seq`
 -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.
 -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
 alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
-alter f k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> case f Nothing of
-                           Nothing -> t
-                           Just x -> join k (Tip k x) p t
-      | zero k m      -> bin p m (alter f k l) r
-      | otherwise     -> bin p m l (alter f k r)
-    Tip ky y
-      | k==ky         -> case f (Just y) of
-                           Just x -> Tip ky x
-                           Nothing -> Nil
-      | otherwise     -> case f Nothing of
-                           Just x -> join k (Tip k x) ky t
-                           Nothing -> Tip ky y
-    Nil               -> case f Nothing of
-                           Just x -> Tip k x
-                           Nothing -> Nil
-
+alter f !k t@(Bin p m l r)
+  | nomatch k p m = case f Nothing of
+                      Nothing -> t
+                      Just x -> link k (Tip k x) p t
+  | zero k m      = binCheckLeft p m (alter f k l) r
+  | otherwise     = binCheckRight p m l (alter f k r)
+alter f k t@(Tip ky y)
+  | k==ky         = case f (Just y) of
+                      Just x -> Tip ky x
+                      Nothing -> Nil
+  | otherwise     = case f Nothing of
+                      Just x -> link k (Tip k x) ky t
+                      Nothing -> Tip ky y
+alter f k Nil     = case f Nothing of
+                      Just x -> Tip k x
+                      Nothing -> Nil
+
+-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at
+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,
+-- or update a value in an 'IntMap'.  In short : @'lookup' k <$> 'alterF' f k m = f
+-- ('lookup' k m)@.
+--
+-- Example:
+--
+-- @
+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)
+-- interactiveAlter k m = alterF f k m where
+--   f Nothing -> do
+--      putStrLn $ show k ++
+--          " was not found in the map. Would you like to add it?"
+--      getUserResponse1 :: IO (Maybe String)
+--   f (Just old) -> do
+--      putStrLn "The key is currently bound to " ++ show old ++
+--          ". Would you like to change or delete it?"
+--      getUserresponse2 :: IO (Maybe String)
+-- @
+--
+-- 'alterF' is the most general operation for working with an individual
+-- key that may or may not be in a given map.
+--
+-- Note: 'alterF' is a flipped version of the 'at' combinator from
+-- 'Control.Lens.At'.
+--
+-- @since 0.5.8
+
+alterF :: Functor f
+       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)
+-- This implementation was stolen from 'Control.Lens.At'.
+alterF f k m = (<$> f mv) $ \fres ->
+  case fres of
+    Nothing -> maybe m (const (delete k m)) mv
+    Just v' -> insert k v' m
+  where mv = lookup k m
 
 {--------------------------------------------------------------------
   Union
@@ -757,6 +962,49 @@ differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMa
 differenceWithKey f m1 m2
   = mergeWithKey f id (const Nil) m1 m2
 
+-- | Remove all the keys in a given set from a map.
+--
+-- @
+-- m `withoutKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.notMember'` s) m
+-- @
+--
+-- @since 0.5.8
+withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a
+withoutKeys = go
+  where
+    go t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)
+      | shorter m1 m2  = merge1
+      | shorter m2 m1  = merge2
+      | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)
+      | otherwise      = t1
+      where
+        merge1 | nomatch p2 p1 m1  = t1
+               | zero p2 m1        = binCheckLeft p1 m1 (go l1 t2) r1
+               | otherwise         = binCheckRight p1 m1 l1 (go r1 t2)
+        merge2 | nomatch p1 p2 m2  = t1
+               | zero p1 m2        = bin p2 m2 (go t1 l2) Nil
+               | otherwise         = bin p2 m2 Nil (go t1 r2)
+
+    go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip k2' _) = merge t2' k2' t1'
+      where merge t2 k2 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = t1
+                                             | zero k2 m1 = binCheckLeft p1 m1 (merge t2 k2 l1) r1
+                                             | otherwise  = binCheckRight p1 m1 l1 (merge t2 k2 r1)
+            merge _ k2 t1@(Tip k1 _) | k1 == k2 = Nil
+                                     | otherwise = t1
+            merge _ _  Nil = Nil
+
+    go t1@(Bin _ _ _ _) IntSet.Nil = t1
+
+    go t1'@(Tip k1' _) t2' = merge t1' k1' t2'
+      where merge t1 k1 (IntSet.Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = t1
+                                                 | zero k1 m2 = bin p2 m2 (merge t1 k1 l2) Nil
+                                                 | otherwise  = bin p2 m2 Nil (merge t1 k1 r2)
+            merge t1 k1 (IntSet.Tip k2 _) | k1 == k2 = Nil
+                                          | otherwise = t1
+            merge t1 _  IntSet.Nil = t1
+
+    go Nil _ = Nil
+
 
 {--------------------------------------------------------------------
   Intersection
@@ -769,6 +1017,50 @@ intersection :: IntMap a -> IntMap b -> IntMap a
 intersection m1 m2
   = mergeWithKey' bin const (const Nil) (const Nil) m1 m2
 
+-- | /O(n+m)/. The restriction of a map to the keys in a set.
+--
+-- @
+-- m `restrictKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.member'` s) m
+-- @
+--
+-- @since 0.5.8
+restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a
+restrictKeys = go
+  where
+    go t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)
+      | shorter m1 m2  = merge1
+      | shorter m2 m1  = merge2
+      | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)
+      | otherwise      = Nil
+      where
+        merge1 | nomatch p2 p1 m1  = Nil
+               | zero p2 m1        = bin p1 m1 (go l1 t2) Nil
+               | otherwise         = bin p1 m1 Nil (go r1 t2)
+        merge2 | nomatch p1 p2 m2  = Nil
+               | zero p1 m2        = bin p2 m2 (go t1 l2) Nil
+               | otherwise         = bin p2 m2 Nil (go t1 r2)
+
+    go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip k2' _) = merge t2' k2' t1'
+      where merge t2 k2 (Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = Nil
+                                          | zero k2 m1 = bin p1 m1 (merge t2 k2 l1) Nil
+                                          | otherwise  = bin p1 m1 Nil (merge t2 k2 r1)
+            merge _ k2 t1@(Tip k1 _) | k1 == k2 = t1
+                                     | otherwise = Nil
+            merge _ _  Nil = Nil
+
+    go (Bin _ _ _ _) IntSet.Nil = Nil
+
+    go t1'@(Tip k1' _) t2' = merge t1' k1' t2'
+      where merge t1 k1 (IntSet.Bin p2 m2 l2 r2)
+              | nomatch k1 p2 m2 = Nil
+              | zero k1 m2 = bin p2 m2 (merge t1 k1 l2) Nil
+              | otherwise  = bin p2 m2 Nil (merge t1 k1 r2)
+            merge t1 k1 (IntSet.Tip k2 _) | k1 == k2 = t1
+                                          | otherwise = Nil
+            merge _ _  IntSet.Nil = Nil
+
+    go Nil _ = Nil
+
 -- | /O(n+m)/. The intersection with a combining function.
 --
 -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
@@ -829,8 +1121,9 @@ intersectionWithKey f m1 m2
 mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)
              -> IntMap a -> IntMap b -> IntMap c
 mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2
-  where combine (Tip k1 x1) (Tip _k2 x2) = case f k1 x1 x2 of Nothing -> Nil
-                                                              Just x -> Tip k1 x
+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.
+        combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil
+                                                                  Just x -> Tip k1 x
         {-# INLINE combine #-}
 {-# INLINE mergeWithKey #-}
 
@@ -851,39 +1144,39 @@ mergeWithKey' bin' f g1 g2 = go
       | shorter m1 m2  = merge1
       | shorter m2 m1  = merge2
       | p1 == p2       = bin' p1 m1 (go l1 l2) (go r1 r2)
-      | otherwise      = maybe_join p1 (g1 t1) p2 (g2 t2)
+      | otherwise      = maybe_link p1 (g1 t1) p2 (g2 t2)
       where
-        merge1 | nomatch p2 p1 m1  = maybe_join p1 (g1 t1) p2 (g2 t2)
+        merge1 | nomatch p2 p1 m1  = maybe_link p1 (g1 t1) p2 (g2 t2)
                | zero p2 m1        = bin' p1 m1 (go l1 t2) (g1 r1)
                | otherwise         = bin' p1 m1 (g1 l1) (go r1 t2)
-        merge2 | nomatch p1 p2 m2  = maybe_join p1 (g1 t1) p2 (g2 t2)
+        merge2 | nomatch p1 p2 m2  = maybe_link p1 (g1 t1) p2 (g2 t2)
                | zero p1 m2        = bin' p2 m2 (go t1 l2) (g2 r2)
                | otherwise         = bin' p2 m2 (g2 l2) (go t1 r2)
 
-    go t1'@(Bin _ _ _ _) t2@(Tip k2 x2) = merge t1'
-      where merge t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = maybe_join p1 (g1 t1) k2 (g2 t2)
-                                       | zero k2 m1 = bin' p1 m1 (merge l1) (g1 r1)
-                                       | otherwise  = bin' p1 m1 (g1 l1) (merge r1)
-            merge t1@(Tip k1 x1) | k1 == k2 = f t1 t2
-                                 | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)
-            merge Nil = g2 t2
+    go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge t2' k2' t1'
+      where merge t2 k2 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)
+                                             | zero k2 m1 = bin' p1 m1 (merge t2 k2 l1) (g1 r1)
+                                             | otherwise  = bin' p1 m1 (g1 l1) (merge t2 k2 r1)
+            merge t2 k2 t1@(Tip k1 _) | k1 == k2 = f t1 t2
+                                      | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)
+            merge t2 _  Nil = g2 t2
 
     go t1@(Bin _ _ _ _) Nil = g1 t1
 
-    go t1@(Tip k1 x1) t2' = merge t2'
-      where merge t2@(Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = maybe_join k1 (g1 t1) p2 (g2 t2)
-                                       | zero k1 m2 = bin' p2 m2 (merge l2) (g2 r2)
-                                       | otherwise  = bin' p2 m2 (g2 l2) (merge r2)
-            merge t2@(Tip k2 x2) | k1 == k2 = f t1 t2
-                                 | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)
-            merge Nil = g1 t1
+    go t1'@(Tip k1' _) t2' = merge t1' k1' t2'
+      where merge t1 k1 t2@(Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)
+                                             | zero k1 m2 = bin' p2 m2 (merge t1 k1 l2) (g2 r2)
+                                             | otherwise  = bin' p2 m2 (g2 l2) (merge t1 k1 r2)
+            merge t1 k1 t2@(Tip k2 _) | k1 == k2 = f t1 t2
+                                      | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)
+            merge t1 _  Nil = g1 t1
 
     go Nil t2 = g2 t2
 
-    maybe_join _ Nil _ t2 = t2
-    maybe_join _ t1 _ Nil = t1
-    maybe_join p1 t1 p2 t2 = join p1 t1 p2 t2
-    {-# INLINE maybe_join #-}
+    maybe_link _ Nil _ t2 = t2
+    maybe_link _ t1 _ Nil = t1
+    maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2
+    {-# INLINE maybe_link #-}
 {-# INLINE mergeWithKey' #-}
 
 {--------------------------------------------------------------------
@@ -897,10 +1190,10 @@ mergeWithKey' bin' f g1 g2 = go
 
 updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a
 updateMinWithKey f t =
-  case t of Bin p m l r | m < 0 -> bin p m l (go f r)
+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)
             _ -> go f t
   where
-    go f' (Bin p m l r) = bin p m (go f' l) r
+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r
     go f' (Tip k y) = case f' k y of
                         Just y' -> Tip k y'
                         Nothing -> Nil
@@ -913,10 +1206,10 @@ updateMinWithKey f t =
 
 updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a
 updateMaxWithKey f t =
-  case t of Bin p m l r | m < 0 -> bin p m (go f l) r
+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r
             _ -> go f t
   where
-    go f' (Bin p m l r) = bin p m l (go f' r)
+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)
     go f' (Tip k y) = case f' k y of
                         Just y' -> Tip k y'
                         Nothing -> Nil
@@ -931,10 +1224,10 @@ updateMaxWithKey f t =
 maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)
 maxViewWithKey t =
   case t of Nil -> Nothing
-            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)
+            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, binCheckLeft p m l' r)
             _ -> Just (go t)
   where
-    go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')
+    go (Bin p m l r) = case go r of (result, r') -> (result, binCheckRight p m l r')
     go (Tip k y) = ((k, y), Nil)
     go Nil = error "maxViewWithKey Nil"
 
@@ -947,10 +1240,10 @@ maxViewWithKey t =
 minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)
 minViewWithKey t =
   case t of Nil -> Nothing
-            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')
+            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, binCheckRight p m l r')
             _ -> Just (go t)
   where
-    go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)
+    go (Bin p m l r) = case go l of (result, l') -> (result, binCheckLeft p m l' r)
     go (Tip k y) = ((k, y), Nil)
     go Nil = error "minViewWithKey Nil"
 
@@ -1014,13 +1307,17 @@ findMax (Bin _ m l r)
           go (Bin _ _ _ r') = go r'
           go Nil            = error "findMax Nil"
 
--- | /O(min(n,W))/. Delete the minimal key. An error is thrown if the IntMap is already empty.
--- Note, this is not the same behavior Map.
+-- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;
+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.
 deleteMin :: IntMap a -> IntMap a
 deleteMin = maybe Nil snd . minView
 
--- | /O(min(n,W))/. Delete the maximal key. An error is thrown if the IntMap is already empty.
--- Note, this is not the same behavior Map.
+-- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;
+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.
 deleteMax :: IntMap a -> IntMap a
 deleteMax = maybe Nil snd . maxView
 
@@ -1125,11 +1422,24 @@ isSubmapOfBy _         Nil _           = True
 -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
 
 map :: (a -> b) -> IntMap a -> IntMap b
-map f t
-  = case t of
-      Bin p m l r -> Bin p m (map f l) (map f r)
-      Tip k x     -> Tip k (f x)
-      Nil         -> Nil
+map f = go
+  where
+    go (Bin p m l r) = Bin p m (go l) (go r)
+    go (Tip k x)     = Tip k (f x)
+    go Nil           = Nil
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE [1] map #-}
+{-# RULES
+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs
+ #-}
+#endif
+#if __GLASGOW_HASKELL__ >= 709
+-- Safe coercions were introduced in 7.8, but did not play well with RULES yet.
+{-# RULES
+"map/coerce" map coerce = coerce
+ #-}
+#endif
 
 -- | /O(n)/. Map a function over all values in the map.
 --
@@ -1143,6 +1453,18 @@ mapWithKey f t
       Tip k x     -> Tip k (f k x)
       Nil         -> Nil
 
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE [1] mapWithKey #-}
+{-# RULES
+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =
+  mapWithKey (\k a -> f k (g k a)) xs
+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =
+  mapWithKey (\k a -> f k (g a)) xs
+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =
+  mapWithKey (\k a -> f (g k a)) xs
+ #-}
+#endif
+
 -- | /O(n)/.
 -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
 -- That is, behaves exactly like a regular 'traverse' except that the traversing
@@ -1150,13 +1472,13 @@ mapWithKey f t
 --
 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])
 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing
-{-# INLINE traverseWithKey #-}
 traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)
 traverseWithKey f = go
   where
     go Nil = pure Nil
     go (Tip k v) = Tip k <$> f k v
     go (Bin p m l r) = Bin p m <$> go l <*> go r
+{-# INLINE traverseWithKey #-}
 
 -- | /O(n)/. The function @'mapAccum'@ threads an accumulating
 -- argument through the map in ascending order of keys.
@@ -1293,16 +1615,18 @@ partition p m
 -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
 
 partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
-partitionWithKey predicate t
-  = case t of
-      Bin p m l r
-        -> let (l1,l2) = partitionWithKey predicate l
-               (r1,r2) = partitionWithKey predicate r
-           in (bin p m l1 r1, bin p m l2 r2)
-      Tip k x
-        | predicate k x -> (t,Nil)
-        | otherwise     -> (Nil,t)
-      Nil -> (Nil,Nil)
+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0
+  where
+    go predicate t
+      = case t of
+          Bin p m l r
+            -> let (l1 :*: l2) = go predicate l
+                   (r1 :*: r2) = go predicate r
+               in bin p m l1 r1 :*: bin p m l2 r2
+          Tip k x
+            | predicate k x -> (t :*: Nil)
+            | otherwise     -> (Nil :*: t)
+          Nil -> (Nil :*: Nil)
 
 -- | /O(n)/. Map values and collect the 'Just' results.
 --
@@ -1348,15 +1672,17 @@ mapEither f m
 -- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
 
 mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
-mapEitherWithKey f (Bin p m l r)
-  = (bin p m l1 r1, bin p m l2 r2)
+mapEitherWithKey f0 t0 = toPair $ go f0 t0
   where
-    (l1,l2) = mapEitherWithKey f l
-    (r1,r2) = mapEitherWithKey f r
-mapEitherWithKey f (Tip k x) = case f k x of
-  Left y  -> (Tip k y, Nil)
-  Right z -> (Nil, Tip k z)
-mapEitherWithKey _ Nil = (Nil, Nil)
+    go f (Bin p m l r)
+      = bin p m l1 r1 :*: bin p m l2 r2
+      where
+        (l1 :*: l2) = go f l
+        (r1 :*: r2) = go f r
+    go f (Tip k x) = case f k x of
+      Left y  -> (Tip k y :*: Nil)
+      Right z -> (Nil :*: Tip k z)
+    go _ Nil = (Nil :*: Nil)
 
 -- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@
 -- where all keys in @map1@ are lower than @k@ and all keys in
@@ -1370,18 +1696,23 @@ mapEitherWithKey _ Nil = (Nil, Nil)
 
 split :: Key -> IntMap a -> (IntMap a, IntMap a)
 split k t =
-  case t of Bin _ m l r | m < 0 -> if k >= 0 -- handle negative numbers.
-                                      then case go k l of (lt, gt) -> (union r lt, gt)
-                                      else case go k r of (lt, gt) -> (lt, union gt l)
-            _ -> go k t
+  case t of
+      Bin _ m l r
+          | m < 0 -> if k >= 0 -- handle negative numbers.
+                     then case go k l of (lt :*: gt) -> let !lt' = union r lt 
+                                                        in (lt', gt)
+                     else case go k r of (lt :*: gt) -> let !gt' = union gt l
+                                                        in (lt, gt')
+      _ -> case go k t of
+          (lt :*: gt) -> (lt, gt)
   where
-    go k' t'@(Bin p m l r) | nomatch k' p m = if k' > p then (t', Nil) else (Nil, t')
-                           | zero k' m = case go k' l of (lt, gt) -> (lt, union gt r)
-                           | otherwise = case go k' r of (lt, gt) -> (union l lt, gt)
-    go k' t'@(Tip ky _) | k' > ky   = (t', Nil)
-                        | k' < ky   = (Nil, t')
-                        | otherwise = (Nil, Nil)
-    go _ Nil = (Nil, Nil)
+    go k' t'@(Bin p m l r) | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'
+                           | zero k' m = case go k' l of (lt :*: gt) -> lt :*: union gt r
+                           | otherwise = case go k' r of (lt :*: gt) -> union l lt :*: gt
+    go k' t'@(Tip ky _) | k' > ky   = (t' :*: Nil)
+                        | k' < ky   = (Nil :*: t')
+                        | otherwise = (Nil :*: Nil)
+    go _ Nil = (Nil :*: Nil)
 
 -- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot
 -- key was found in the original map.
@@ -1394,14 +1725,23 @@ split k t =
 
 splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)
 splitLookup k t =
-  case t of Bin _ m l r | m < 0 -> if k >= 0 -- handle negative numbers.
-                                      then case go k l of (lt, fnd, gt) -> (union r lt, fnd, gt)
-                                      else case go k r of (lt, fnd, gt) -> (lt, fnd, union gt l)
-            _ -> go k t
+  case t of
+      Bin _ m l r
+          | m < 0 -> if k >= 0 -- handle negative numbers.
+                     then case go k l of
+                         (lt, fnd, gt) -> let !lt' = union r lt
+                                          in (lt', fnd, gt)
+                     else case go k r of
+                         (lt, fnd, gt) -> let !gt' = union gt l
+                                          in (lt, fnd, gt')
+      _ -> go k t
   where
-    go k' t'@(Bin p m l r) | nomatch k' p m = if k' > p then (t', Nothing, Nil) else (Nil, Nothing, t')
-                           | zero k' m = case go k' l of (lt, fnd, gt) -> (lt, fnd, union gt r)
-                           | otherwise = case go k' r of (lt, fnd, gt) -> (union l lt, fnd, gt)
+    go k' t'@(Bin p m l r)
+        | nomatch k' p m = if k' > p then (t', Nothing, Nil) else (Nil, Nothing, t')
+        | zero k' m      = case go k' l of
+            (lt, fnd, gt) -> let !gt' = union gt r in (lt, fnd, gt')
+        | otherwise      = case go k' r of
+            (lt, fnd, gt) -> let !lt' = union l lt in (lt', fnd, gt)
     go k' t'@(Tip ky y) | k' > ky   = (t', Nothing, Nil)
                         | k' < ky   = (Nil, Nothing, t')
                         | otherwise = (Nil, Just y, Nil)
@@ -1439,8 +1779,7 @@ foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
                         | otherwise -> go (go z r) l
             _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip _ x)     = f x z'
     go z' (Bin _ _ l r) = go (go z' r) l
 {-# INLINE foldr' #-}
@@ -1474,8 +1813,7 @@ foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
                         | otherwise -> go (go z l) r
             _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip _ x)     = f z' x
     go z' (Bin _ _ l r) = go (go z' l) r
 {-# INLINE foldl' #-}
@@ -1490,7 +1828,7 @@ foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
 --
 -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
 -- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
-foldrWithKey :: (Int -> a -> b -> b) -> b -> IntMap a -> b
+foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
                         | otherwise -> go (go z r) l
@@ -1504,14 +1842,13 @@ foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments
 -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
-foldrWithKey' :: (Int -> a -> b -> b) -> b -> IntMap a -> b
+foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
                         | otherwise -> go (go z r) l
             _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip kx x)    = f kx x z'
     go z' (Bin _ _ l r) = go (go z' r) l
 {-# INLINE foldrWithKey' #-}
@@ -1526,7 +1863,7 @@ foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two argument
 --
 -- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
 -- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"
-foldlWithKey :: (a -> Int -> b -> a) -> a -> IntMap b -> a
+foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a
 foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
                         | otherwise -> go (go z l) r
@@ -1540,18 +1877,30 @@ foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments
 -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
-foldlWithKey' :: (a -> Int -> b -> a) -> a -> IntMap b -> a
+foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a
 foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
                         | otherwise -> go (go z l) r
             _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip kx x)    = f z' kx x
     go z' (Bin _ _ l r) = go (go z' l) r
 {-# INLINE foldlWithKey' #-}
 
+-- | /O(n)/. Fold the keys and values in the map using the given monoid, such that
+--
+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@
+--
+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.
+foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m
+foldMapWithKey f = go
+  where
+    go Nil           = mempty
+    go (Tip kx x)    = f kx x
+    go (Bin _ _ l r) = go l `mappend` go r
+{-# INLINE foldMapWithKey #-}
+
 {--------------------------------------------------------------------
   List variations
 --------------------------------------------------------------------}
@@ -1574,15 +1923,6 @@ elems = foldr (:) []
 keys  :: IntMap a -> [Key]
 keys = foldrWithKey (\k _ ks -> k : ks) []
 
--- | /O(n*min(n,W))/. The set of all keys of the map.
---
--- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]
--- > keysSet empty == Data.IntSet.empty
-
-keysSet :: IntMap a -> IntSet.IntSet
-keysSet m = IntSet.fromDistinctAscList (keys m)
-
-
 -- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the
 -- map in ascending key order. Subject to list fusion.
 --
@@ -1592,10 +1932,58 @@ keysSet m = IntSet.fromDistinctAscList (keys m)
 assocs :: IntMap a -> [(Key,a)]
 assocs = toAscList
 
+-- | /O(n*min(n,W))/. The set of all keys of the map.
+--
+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]
+-- > keysSet empty == Data.IntSet.empty
+
+keysSet :: IntMap a -> IntSet.IntSet
+keysSet Nil = IntSet.Nil
+keysSet (Tip kx _) = IntSet.singleton kx
+keysSet (Bin p m l r)
+  | m .&. IntSet.suffixBitMask == 0 = IntSet.Bin p m (keysSet l) (keysSet r)
+  | otherwise = IntSet.Tip (p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)
+  where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'
+        computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx
+        computeBm _   Nil = error "Data.IntSet.keysSet: Nil"
+
+-- | /O(n)/. Build a map from a set of keys and a function which for each key
+-- computes its value.
+--
+-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]
+-- > fromSet undefined Data.IntSet.empty == empty
+
+fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a
+fromSet _ IntSet.Nil = Nil
+fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)
+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)
+  where -- This is slightly complicated, as we to convert the dense
+        -- representation of IntSet into tree representation of IntMap.
+        --
+        -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.
+        -- We split bmask into halves corresponding to left and right subtree.
+        -- If they are both nonempty, we create a Bin node, otherwise exactly
+        -- one of them is nonempty and we construct the IntMap from that half.
+        buildTree g !prefix !bmask bits = case bits of
+          0 -> Tip prefix (g prefix)
+          _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of
+                 bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->
+                           buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2
+                       | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->
+                           buildTree g prefix bmask bits2
+                       | otherwise ->
+                           Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)
 
 {--------------------------------------------------------------------
   Lists
 --------------------------------------------------------------------}
+#if __GLASGOW_HASKELL__ >= 708
+instance GHCExts.IsList (IntMap a) where
+  type Item (IntMap a) = (Key,a)
+  fromList = fromList
+  toList   = toList
+#endif
+
 -- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list
 -- fusion.
 --
@@ -1733,14 +2121,20 @@ fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)
 --
 -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
 
-fromDistinctAscList :: [(Key,a)] -> IntMap a
+#if __GLASGOW_HASKELL__
+fromDistinctAscList :: forall a. [(Key,a)] -> IntMap a
+#else
+fromDistinctAscList ::            [(Key,a)] -> IntMap a
+#endif
 fromDistinctAscList []         = Nil
 fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada
   where
     work (kx,vx) []            stk = finish kx (Tip kx vx) stk
     work (kx,vx) (z@(kz,_):zs) stk = reduce z zs (branchMask kx kz) kx (Tip kx vx) stk
 
+#if __GLASGOW_HASKELL__
     reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a
+#endif
     reduce z zs _ px tx Nada = work z zs (Push px tx Nada)
     reduce z zs m px tx stk@(Push py ty stk') =
         let mxy = branchMask px py
@@ -1750,7 +2144,7 @@ fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada
                  else work z zs (Push px tx stk)
 
     finish _  t  Nada = t
-    finish px tx (Push py ty stk) = finish p (join py ty px tx) stk
+    finish px tx (Push py ty stk) = finish p (link py ty px tx) stk
         where m = branchMask px py
               p = mask px m
 
@@ -1794,6 +2188,12 @@ instance Ord a => Ord (IntMap a) where
 instance Functor IntMap where
     fmap = map
 
+#ifdef __GLASGOW_HASKELL__
+    a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)
+    a <$ Tip k _     = Tip k a
+    _ <$ Nil         = Nil
+#endif
+
 {--------------------------------------------------------------------
   Show
 --------------------------------------------------------------------}
@@ -1824,23 +2224,22 @@ instance (Read e) => Read (IntMap e) where
   Typeable
 --------------------------------------------------------------------}
 
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
+INSTANCE_TYPEABLE1(IntMap)
 
 {--------------------------------------------------------------------
   Helpers
 --------------------------------------------------------------------}
 {--------------------------------------------------------------------
-  Join
+  Link
 --------------------------------------------------------------------}
-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
-join p1 t1 p2 t2
+link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
+link 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
-{-# INLINE join #-}
+{-# INLINE link #-}
 
 {--------------------------------------------------------------------
   @bin@ assures that we never have empty trees within a tree.
@@ -1851,6 +2250,17 @@ bin _ _ Nil r = r
 bin p m l r   = Bin p m l r
 {-# INLINE bin #-}
 
+-- binCheckLeft only checks that the left subtree is non-empty
+binCheckLeft :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
+binCheckLeft _ _ Nil r = r
+binCheckLeft p m l r   = Bin p m l r
+{-# INLINE binCheckLeft #-}
+
+-- binCheckRight only checks that the right subtree is non-empty
+binCheckRight :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
+binCheckRight _ _ l Nil = l
+binCheckRight p m l r   = Bin p m l r
+{-# INLINE binCheckRight #-}
 
 {--------------------------------------------------------------------
   Endian independent bit twiddling
@@ -1893,70 +2303,37 @@ branchMask p1 p2
   = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
 {-# INLINE branchMask #-}
 
-{----------------------------------------------------------------------
-  Finding the highest bit (mask) in a word [x] can be done efficiently in
-  three ways:
-  * convert to a floating point value and the mantissa tells us the
-    [log2(x)] that corresponds with the highest bit position. The mantissa
-    is retrieved either via the standard C function [frexp] or by some bit
-    twiddling on IEEE compatible numbers (float). Note that one needs to
-    use at least [double] precision for an accurate mantissa of 32 bit
-    numbers.
-  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
-  * use processor specific assembler instruction (asm).
-
-  The most portable way would be [bit], but is it efficient enough?
-  I have measured the cycle counts of the different methods on an AMD
-  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
-
-  highestBitMask: method  cycles
-                  --------------
-                   frexp   200
-                   float    33
-                   bit      11
-                   asm      12
-
-  highestBit:     method  cycles
-                  --------------
-                   frexp   195
-                   float    33
-                   bit      11
-                   asm      11
-
-  Wow, the bit twiddling is on today's RISC like machines even faster
-  than a single CISC instruction (BSR)!
-----------------------------------------------------------------------}
-
-{----------------------------------------------------------------------
-  [highestBitMask] returns a word where only the highest bit is set.
-  It is found by first setting all bits in lower positions than the
-  highest bit and than taking an exclusive or with the original value.
-  Allthough the function may look expensive, GHC compiles this into
-  excellent C code that subsequently compiled into highly efficient
-  machine code. The algorithm is derived from Jorg Arndt's FXT library.
-----------------------------------------------------------------------}
-highestBitMask :: Nat -> Nat
-highestBitMask x0
-  = case (x0 .|. shiftRL x0 1) of
-     x1 -> case (x1 .|. shiftRL x1 2) of
-      x2 -> case (x2 .|. shiftRL x2 4) of
-       x3 -> case (x3 .|. shiftRL x3 8) of
-        x4 -> case (x4 .|. shiftRL x4 16) of
-         x5 -> case (x5 .|. shiftRL x5 32) of   -- for 64 bit platforms
-          x6 -> (x6 `xor` (shiftRL x6 1))
-{-# INLINE highestBitMask #-}
-
-
 {--------------------------------------------------------------------
   Utilities
 --------------------------------------------------------------------}
 
-foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict f = go
-  where
-    go z []     = z
-    go z (x:xs) = let z' = f z x in z' `seq` go z' xs
-{-# INLINE foldlStrict #-}
+-- | /O(1)/.  Decompose a map into pieces based on the structure of the underlying
+-- tree.  This function is useful for consuming a map in parallel.
+--
+-- No guarantee is made as to the sizes of the pieces; an internal, but
+-- deterministic process determines this.  However, it is guaranteed that the
+-- pieces returned will be in ascending order (all elements in the first submap
+-- less than all elements in the second, and so on).
+--
+-- Examples:
+--
+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==
+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]
+--
+-- > splitRoot empty == []
+--
+--  Note that the current implementation does not return more than two submaps,
+--  but you should not depend on this behaviour because it can change in the
+--  future without notice.
+splitRoot :: IntMap a -> [IntMap a]
+splitRoot orig =
+  case orig of
+    Nil -> []
+    x@(Tip _ _) -> [x]
+    Bin _ m l r | m < 0 -> [r, l]
+                | otherwise -> [l, r]
+{-# INLINE splitRoot #-}
+
 
 {--------------------------------------------------------------------
   Debugging