diff --git a/Data/Graph.hs b/Data/Graph.hs
--- a/Data/Graph.hs
+++ b/Data/Graph.hs
@@ -17,7 +17,7 @@
 --
 -- A version of the graph algorithms described in:
 --
---   /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,
+--   /Structuring Depth-First Search Algorithms in Haskell/,
 --   by David King and John Launchbury.
 --
 -----------------------------------------------------------------------------
diff --git a/Data/IntMap.hs b/Data/IntMap.hs
--- a/Data/IntMap.hs
+++ b/Data/IntMap.hs
@@ -90,6 +90,6 @@
 -- /O(n)/. Fold the keys and values in the map using the given
 -- right-associative binary operator. This function is an equivalent
 -- of 'foldrWithKey' and is present for compatibility only.
-foldWithKey :: (Int -> a -> b -> b) -> b -> IntMap a -> b
+foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 foldWithKey = foldrWithKey
 {-# INLINE foldWithKey #-}
diff --git a/Data/IntMap/Base.hs b/Data/IntMap/Base.hs
--- a/Data/IntMap/Base.hs
+++ b/Data/IntMap/Base.hs
@@ -222,6 +222,9 @@
 import Control.Monad ( liftM )
 import Control.DeepSeq (NFData(rnf))
 
+import Data.IntSet.Base (Key)
+import Data.StrictPair
+
 #if __GLASGOW_HASKELL__
 import Text.Read
 import Data.Data (Data(..), mkNoRepType)
@@ -285,7 +288,6 @@
 
 type Prefix = Int
 type Mask   = Int
-type Key    = Int
 
 {--------------------------------------------------------------------
   Operators
@@ -1402,16 +1404,18 @@
 -- > 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.
 --
@@ -1457,15 +1461,17 @@
 -- >     == (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
@@ -1479,18 +1485,23 @@
 
 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' `seq` (lt', gt)
+                     else case go k r of (lt :*: gt) -> let gt' = union gt l
+                                                        in gt' `seq` (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.
@@ -1503,14 +1514,23 @@
 
 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' `seq` (lt', fnd, gt)
+                     else case go k r of
+                         (lt, fnd, gt) -> let gt' = union gt l
+                                          in gt' `seq` (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 gt' `seq` (lt, fnd, gt')
+        | otherwise      = case go k' r of
+            (lt, fnd, gt) -> let lt' = union l lt in lt' `seq` (lt', fnd, gt)
     go k' t'@(Tip ky y) | k' > ky   = (t', Nothing, Nil)
                         | k' < ky   = (Nil, Nothing, t')
                         | otherwise = (Nil, Just y, Nil)
@@ -1599,7 +1619,7 @@
 --
 -- > 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
@@ -1613,7 +1633,7 @@
 -- | /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
@@ -1635,7 +1655,7 @@
 --
 -- > 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
@@ -1649,7 +1669,7 @@
 -- | /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
diff --git a/Data/IntMap/Lazy.hs b/Data/IntMap/Lazy.hs
--- a/Data/IntMap/Lazy.hs
+++ b/Data/IntMap/Lazy.hs
@@ -16,7 +16,7 @@
 -- (dictionaries).
 --
 -- API of this module is strict in the keys, but lazy in the values.
--- If you need value-strict maps, use 'Data.IntMap.Strict' instead.
+-- If you need value-strict maps, use "Data.IntMap.Strict" instead.
 -- The 'IntMap' type itself is shared between the lazy and strict modules,
 -- meaning that the same 'IntMap' value can be passed to functions in
 -- both modules (although that is rarely needed).
diff --git a/Data/IntMap/Strict.hs b/Data/IntMap/Strict.hs
--- a/Data/IntMap/Strict.hs
+++ b/Data/IntMap/Strict.hs
@@ -16,7 +16,7 @@
 -- (dictionaries).
 --
 -- API of this module is strict in both the keys and the values.
--- If you need value-lazy maps, use 'Data.IntMap.Lazy' instead.
+-- If you need value-lazy maps, use "Data.IntMap.Lazy" instead.
 -- The 'IntMap' type itself is shared between the lazy and strict modules,
 -- meaning that the same 'IntMap' value can be passed to functions in
 -- both modules (although that is rarely needed).
@@ -49,7 +49,7 @@
 -- (32 or 64).
 --
 -- Be aware that the 'Functor', 'Traversable' and 'Data' instances
--- are the same as for the 'Data.IntMap.Lazy' module, so if they are used
+-- are the same as for the "Data.IntMap.Lazy" module, so if they are used
 -- on strict maps, the resulting maps will be lazy.
 -----------------------------------------------------------------------------
 
@@ -390,16 +390,18 @@
 -- > 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` x `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> Nothing `strictPair` join k (Tip k x) p t
-      | zero k m      -> let (found,l') = insertLookupWithKey f k x l in (found `strictPair` Bin p m l' r)
-      | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found `strictPair` Bin p m l r')
-    Tip ky y
-      | k==ky         -> (Just y `strictPair` (Tip k $! f k x y))
-      | otherwise     -> (Nothing `strictPair` join k (Tip k x) ky t)
-    Nil -> Nothing `strictPair` Tip k x
+insertLookupWithKey f0 k0 x0 t0 = k0 `seq` x0 `seq` toPair $ go f0 k0 x0 t0
+  where
+    go 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') = go f k x l in (found :*: Bin p m l' r)
+          | otherwise     -> let (found :*: r') = go 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
 
 
 {--------------------------------------------------------------------
@@ -475,18 +477,20 @@
 -- > 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 `strictPair` bin p m l' r)
-      | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found `strictPair` bin p m l r')
-    Tip ky y
-      | k==ky         -> case f k y of
-                           Just y' -> y' `seq` (Just y `strictPair` Tip ky y')
-                           Nothing -> (Just y, Nil)
-      | otherwise     -> (Nothing,t)
-    Nil -> (Nothing,Nil)
+updateLookupWithKey f0 k0 t0 = k0 `seq` toPair $ go f0 k0 t0
+  where
+    go f k t =
+      case t of
+        Bin p m l r
+          | nomatch k p m -> (Nothing :*: t)
+          | zero k m      -> let (found :*: l') = go f k l in (found :*: bin p m l' r)
+          | otherwise     -> let (found :*: r') = go f k r in (found :*: bin p m l r')
+        Tip ky y
+          | k==ky         -> case f k y of
+                               Just y' -> y' `seq` (Just y :*: Tip ky y')
+                               Nothing -> (Just y :*: Nil)
+          | otherwise     -> (Nothing :*: t)
+        Nil -> (Nothing :*: Nil)
 
 
 
@@ -743,24 +747,28 @@
 -- the accumulating argument and the both elements of the
 -- result of the function.
 mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumL f a t
-  = case t of
-      Bin p m l r -> let (a1,l') = mapAccumL f a l
-                         (a2,r') = mapAccumL f a1 r
-                     in (a2 `strictPair` Bin p m l' r')
-      Tip k x     -> let (a',x') = f a k x in x' `seq` (a' `strictPair` Tip k x')
-      Nil         -> (a `strictPair` Nil)
+mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0
+  where
+    go f a t
+      = case t of
+          Bin p m l r -> let (a1 :*: l') = go f a l
+                             (a2 :*: r') = go f a1 r
+                         in (a2 :*: Bin p m l' r')
+          Tip k x     -> let (a',x') = f a k x in x' `seq` (a' :*: Tip k x')
+          Nil         -> (a :*: Nil)
 
 -- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
 -- argument through the map in descending order of keys.
 mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
-mapAccumRWithKey f a t
-  = case t of
-      Bin p m l r -> let (a1,r') = mapAccumRWithKey f a r
-                         (a2,l') = mapAccumRWithKey f a1 l
-                     in (a2 `strictPair` Bin p m l' r')
-      Tip k x     -> let (a',x') = f a k x in x' `seq` (a' `strictPair` Tip k x')
-      Nil         -> (a `strictPair` Nil)
+mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0
+  where
+    go f a t
+      = case t of
+          Bin p m l r -> let (a1 :*: r') = go f a r
+                             (a2 :*: l') = go f a1 l
+                         in (a2 :*: Bin p m l' r')
+          Tip k x     -> let (a',x') = f a k x in x' `seq` (a' :*: Tip k x')
+          Nil         -> (a :*: Nil)
 
 -- | /O(n*log n)/.
 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
@@ -822,15 +830,17 @@
 -- >     == (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 `strictPair` 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  -> y `seq` (Tip k y, Nil)
-  Right z -> z `seq` (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  -> y `seq` (Tip k y :*: Nil)
+      Right z -> z `seq` (Nil :*: Tip k z)
+    go _ Nil = (Nil :*: Nil)
 
 {--------------------------------------------------------------------
   Conversions
diff --git a/Data/IntSet.hs b/Data/IntSet.hs
--- a/Data/IntSet.hs
+++ b/Data/IntSet.hs
@@ -56,6 +56,7 @@
 #else
               IntSet(..)      -- instance Eq,Show
 #endif
+            , Key
 
             -- * Operators
             , (\\)
diff --git a/Data/IntSet/Base.hs b/Data/IntSet/Base.hs
--- a/Data/IntSet/Base.hs
+++ b/Data/IntSet/Base.hs
@@ -77,7 +77,7 @@
 
 module Data.IntSet.Base (
             -- * Set type
-              IntSet(..)      -- instance Eq,Show
+              IntSet(..), Key -- instance Eq,Show
 
             -- * Operators
             , (\\)
@@ -168,6 +168,8 @@
 import Data.Typeable
 import Control.DeepSeq (NFData)
 
+import Data.StrictPair
+
 #if __GLASGOW_HASKELL__
 import Text.Read
 import Data.Data (Data(..), mkNoRepType)
@@ -258,6 +260,7 @@
 type Prefix = Int
 type Mask   = Int
 type BitMap = Word
+type Key    = Int
 
 instance Monoid IntSet where
     mempty  = empty
@@ -301,7 +304,7 @@
 -- | /O(min(n,W))/. Is the value a member of the set?
 
 -- See Note: Local 'go' functions and capturing]
-member :: Int -> IntSet -> Bool
+member :: Key -> IntSet -> Bool
 member x = x `seq` go
   where
     go (Bin p m l r)
@@ -312,7 +315,7 @@
     go Nil = False
 
 -- | /O(min(n,W))/. Is the element not in the set?
-notMember :: Int -> IntSet -> Bool
+notMember :: Key -> IntSet -> Bool
 notMember k = not . member k
 
 -- | /O(log n)/. Find largest element smaller than the given one.
@@ -321,7 +324,7 @@
 -- > lookupLT 5 (fromList [3, 5]) == Just 3
 
 -- See Note: Local 'go' functions and capturing.
-lookupLT :: Int -> IntSet -> Maybe Int
+lookupLT :: Key -> IntSet -> Maybe Key
 lookupLT x t = x `seq` case t of
     Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r
     _ -> go Nil t
@@ -342,7 +345,7 @@
 -- > lookupGT 5 (fromList [3, 5]) == Nothing
 
 -- See Note: Local 'go' functions and capturing.
-lookupGT :: Int -> IntSet -> Maybe Int
+lookupGT :: Key -> IntSet -> Maybe Key
 lookupGT x t = x `seq` case t of
     Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r
     _ -> go Nil t
@@ -364,7 +367,7 @@
 -- > lookupLE 5 (fromList [3, 5]) == Just 5
 
 -- See Note: Local 'go' functions and capturing.
-lookupLE :: Int -> IntSet -> Maybe Int
+lookupLE :: Key -> IntSet -> Maybe Key
 lookupLE x t = x `seq` case t of
     Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r
     _ -> go Nil t
@@ -386,7 +389,7 @@
 -- > lookupGE 6 (fromList [3, 5]) == Nothing
 
 -- See Note: Local 'go' functions and capturing.
-lookupGE :: Int -> IntSet -> Maybe Int
+lookupGE :: Key -> IntSet -> Maybe Key
 lookupGE x t = x `seq` case t of
     Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r
     _ -> go Nil t
@@ -404,14 +407,14 @@
 
 -- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is
 -- given, it has m > 0.
-unsafeFindMin :: IntSet -> Maybe Int
+unsafeFindMin :: IntSet -> Maybe Key
 unsafeFindMin Nil = Nothing
 unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm
 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 :: IntSet -> Maybe Int
+unsafeFindMax :: IntSet -> Maybe Key
 unsafeFindMax Nil = Nothing
 unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm
 unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r
@@ -426,7 +429,7 @@
 {-# INLINE empty #-}
 
 -- | /O(1)/. A set of one element.
-singleton :: Int -> IntSet
+singleton :: Key -> IntSet
 singleton x
   = Tip (prefixOf x) (bitmapOf x)
 {-# INLINE singleton #-}
@@ -436,7 +439,7 @@
 --------------------------------------------------------------------}
 -- | /O(min(n,W))/. Add a value to the set. There is no left- or right bias for
 -- IntSets.
-insert :: Int -> IntSet -> IntSet
+insert :: Key -> IntSet -> IntSet
 insert x = x `seq` insertBM (prefixOf x) (bitmapOf x)
 
 -- Helper function for insert and union.
@@ -454,7 +457,7 @@
 
 -- | /O(min(n,W))/. Delete a value in the set. Returns the
 -- original set when the value was not present.
-delete :: Int -> IntSet -> IntSet
+delete :: Key -> IntSet -> IntSet
 delete x = x `seq` deleteBM (prefixOf x) (bitmapOf x)
 
 -- Deletes all values mentioned in the BitMap from the set.
@@ -641,7 +644,7 @@
   Filter
 --------------------------------------------------------------------}
 -- | /O(n)/. Filter all elements that satisfy some predicate.
-filter :: (Int -> Bool) -> IntSet -> IntSet
+filter :: (Key -> Bool) -> IntSet -> IntSet
 filter predicate t
   = case t of
       Bin p m l r
@@ -654,20 +657,22 @@
         {-# INLINE bitPred #-}
 
 -- | /O(n)/. partition the set according to some predicate.
-partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)
-partition predicate t
-  = case t of
-      Bin p m l r
-        -> let (l1,l2) = partition predicate l
-               (r1,r2) = partition predicate r
-           in (bin p m l1 r1, bin p m l2 r2)
-      Tip kx bm
-        -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm
-           in  (tip kx bm1, tip kx (bm `xor` bm1))
-      Nil -> (Nil,Nil)
-  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi
-                         | otherwise           = bm
-        {-# INLINE bitPred #-}
+partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)
+partition 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 kx bm
+            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm
+               in  tip kx bm1 :*: tip kx (bm `xor` bm1)
+          Nil -> (Nil :*: Nil)
+      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi
+                             | otherwise           = bm
+            {-# INLINE bitPred #-}
 
 
 -- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@
@@ -675,43 +680,67 @@
 -- comprises the elements of @set@ greater than @x@.
 --
 -- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])
-split :: Int -> IntSet -> (IntSet,IntSet)
+split :: Key -> IntSet -> (IntSet,IntSet)
 split x t =
-  case t of Bin _ m l r | m < 0 -> if x >= 0 then case go x l of (lt, gt) -> (union lt r, gt)
-                                             else case go x r of (lt, gt) -> (lt, union gt l)
-            _ -> go x t
+  case t of
+      Bin _ m l r
+          | m < 0 -> if x >= 0  -- handle negative numbers.
+                     then case go x l of (lt :*: gt) -> let lt' = union lt r
+                                                        in lt' `seq` (lt', gt)
+                     else case go x r of (lt :*: gt) -> let gt' = union gt l
+                                                        in gt' `seq` (lt, gt')
+      _ -> case go x t of
+          (lt :*: gt) -> (lt, gt)
   where
-    go x' t'@(Bin p m l r) | match x' p m = if zero x' m then case go x' l of (lt, gt) -> (lt, union gt r)
-                                                         else case go x' r of (lt, gt) -> (union lt l, gt)
-                           | otherwise   = if x' < p then (Nil, t')
-                                                     else (t', Nil)
-    go x' t'@(Tip kx' bm) | kx' > x'          = (Nil, t')
-                            -- equivalent to kx' > prefixOf x'
-                          | kx' < prefixOf x' = (t', Nil)
-                          | otherwise = (tip kx' (bm .&. lowerBitmap), tip kx' (bm .&. higherBitmap))
-                              where lowerBitmap = bitmapOf x' - 1
-                                    higherBitmap = complement (lowerBitmap + bitmapOf x')
-    go _ Nil = (Nil, Nil)
+    go !x' t'@(Bin p m l r)
+        | match x' p m = if zero x' m
+                         then case go x' l of
+                             (lt :*: gt) -> lt :*: union gt r
+                         else case go x' r of
+                             (lt :*: gt) -> union lt l :*: gt
+        | otherwise   = if x' < p then (Nil :*: t')
+                        else (t' :*: Nil)
+    go x' t'@(Tip kx' bm)
+        | kx' > x'          = (Nil :*: t')
+          -- equivalent to kx' > prefixOf x'
+        | kx' < prefixOf x' = (t' :*: Nil)
+        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)
+            where lowerBitmap = bitmapOf x' - 1
+                  higherBitmap = complement (lowerBitmap + bitmapOf x')
+    go _ Nil = (Nil :*: Nil)
 
 -- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot
 -- element was found in the original set.
-splitMember :: Int -> IntSet -> (IntSet,Bool,IntSet)
+splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)
 splitMember x t =
-  case t of Bin _ m l r | m < 0 -> if x >= 0 then case go x l of (lt, fnd, gt) -> (union lt r, fnd, gt)
-                                             else case go x r of (lt, fnd, gt) -> (lt, fnd, union gt l)
-            _ -> go x t
+  case t of
+      Bin _ m l r | m < 0 -> if x >= 0
+                             then case go x l of
+                                 (lt, fnd, gt) -> let lt' = union lt r
+                                                  in lt' `seq` (lt', fnd, gt)
+                             else case go x r of
+                                 (lt, fnd, gt) -> let gt' = union gt l
+                                                  in gt' `seq` (lt, fnd, gt')
+      _ -> go x t
   where
-    go x' t'@(Bin p m l r) | match x' p m = if zero x' m then case go x' l of (lt, fnd, gt) -> (lt, fnd, union gt r)
-                                                         else case go x' r of (lt, fnd, gt) -> (union lt l, fnd, gt)
-                           | otherwise   = if x' < p then (Nil, False, t')
-                                                     else (t', False, Nil)
-    go x' t'@(Tip kx' bm) | kx' > x'          = (Nil, False, t')
-                            -- equivalent to kx' > prefixOf x'
-                          | kx' < prefixOf x' = (t', False, Nil)
-                          | otherwise = (tip kx' (bm .&. lowerBitmap), (bm .&. bitmapOfx') /= 0, tip kx' (bm .&. higherBitmap))
-                              where bitmapOfx' = bitmapOf x'
-                                    lowerBitmap = bitmapOfx' - 1
-                                    higherBitmap = complement (lowerBitmap + bitmapOfx')
+    go x' t'@(Bin p m l r)
+        | match x' p m = if zero x' m
+                         then case go x' l of
+                             (lt, fnd, gt) -> (lt, fnd, union gt r)
+                         else case go x' r of
+                             (lt, fnd, gt) -> (union lt l, fnd, gt)
+        | otherwise   = if x' < p then (Nil, False, t') else (t', False, Nil)
+    go x' t'@(Tip kx' bm)
+        | kx' > x'          = (Nil, False, t')
+          -- equivalent to kx' > prefixOf x'
+        | kx' < prefixOf x' = (t', False, Nil)
+        | otherwise = let lt = tip kx' (bm .&. lowerBitmap)
+                          found = (bm .&. bitmapOfx') /= 0
+                          gt = tip kx' (bm .&. higherBitmap)
+                      in lt `seq` found `seq` gt `seq` (lt, found, gt)
+            where bitmapOfx' = bitmapOf x'
+                  lowerBitmap = bitmapOfx' - 1
+                  higherBitmap = complement (lowerBitmap + bitmapOfx')
     go _ Nil = (Nil, False, Nil)
 
 
@@ -721,7 +750,7 @@
 
 -- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set
 -- stripped of that element, or 'Nothing' if passed an empty set.
-maxView :: IntSet -> Maybe (Int, IntSet)
+maxView :: IntSet -> Maybe (Key, IntSet)
 maxView 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)
@@ -733,7 +762,7 @@
 
 -- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set
 -- stripped of that element, or 'Nothing' if passed an empty set.
-minView :: IntSet -> Maybe (Int, IntSet)
+minView :: IntSet -> Maybe (Key, IntSet)
 minView 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')
@@ -746,18 +775,18 @@
 -- | /O(min(n,W))/. Delete and find the minimal element.
 --
 -- > deleteFindMin set = (findMin set, deleteMin set)
-deleteFindMin :: IntSet -> (Int, IntSet)
+deleteFindMin :: IntSet -> (Key, IntSet)
 deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView
 
 -- | /O(min(n,W))/. Delete and find the maximal element.
 --
 -- > deleteFindMax set = (findMax set, deleteMax set)
-deleteFindMax :: IntSet -> (Int, IntSet)
+deleteFindMax :: IntSet -> (Key, IntSet)
 deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView
 
 
 -- | /O(min(n,W))/. The minimal element of the set.
-findMin :: IntSet -> Int
+findMin :: IntSet -> Key
 findMin Nil = error "findMin: empty set has no minimal element"
 findMin (Tip kx bm) = kx + lowestBitSet bm
 findMin (Bin _ m l r)
@@ -768,7 +797,7 @@
           find Nil            = error "findMin Nil"
 
 -- | /O(min(n,W))/. The maximal element of a set.
-findMax :: IntSet -> Int
+findMax :: IntSet -> Key
 findMax Nil = error "findMax: empty set has no maximal element"
 findMax (Tip kx bm) = kx + highestBitSet bm
 findMax (Bin _ m l r)
@@ -797,7 +826,7 @@
 -- It's worth noting that the size of the result may be smaller if,
 -- for some @(x,y)@, @x \/= y && f x == f y@
 
-map :: (Int->Int) -> IntSet -> IntSet
+map :: (Key -> Key) -> IntSet -> IntSet
 map f = fromList . List.map f . toList
 
 {--------------------------------------------------------------------
@@ -808,7 +837,7 @@
 -- for compatibility only.
 --
 -- /Please note that fold will be deprecated in the future and removed./
-fold :: (Int -> b -> b) -> b -> IntSet -> b
+fold :: (Key -> b -> b) -> b -> IntSet -> b
 fold = foldr
 {-# INLINE fold #-}
 
@@ -818,7 +847,7 @@
 -- For example,
 --
 -- > toAscList set = foldr (:) [] set
-foldr :: (Int -> b -> b) -> b -> IntSet -> b
+foldr :: (Key -> b -> b) -> b -> IntSet -> b
 foldr 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
@@ -832,7 +861,7 @@
 -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
-foldr' :: (Int -> b -> b) -> b -> IntSet -> b
+foldr' :: (Key -> b -> b) -> b -> IntSet -> b
 foldr' 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
@@ -850,7 +879,7 @@
 -- For example,
 --
 -- > toDescList set = foldl (flip (:)) [] set
-foldl :: (a -> Int -> a) -> a -> IntSet -> a
+foldl :: (a -> Key -> a) -> a -> IntSet -> a
 foldl 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
@@ -865,7 +894,7 @@
 -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
-foldl' :: (a -> Int -> a) -> a -> IntSet -> a
+foldl' :: (a -> Key -> a) -> a -> IntSet -> a
 foldl' 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
@@ -882,7 +911,7 @@
 --------------------------------------------------------------------}
 -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.
 -- Subject to list fusion.
-elems :: IntSet -> [Int]
+elems :: IntSet -> [Key]
 elems
   = toAscList
 
@@ -890,28 +919,28 @@
   Lists
 --------------------------------------------------------------------}
 -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.
-toList :: IntSet -> [Int]
+toList :: IntSet -> [Key]
 toList
   = toAscList
 
 -- | /O(n)/. Convert the set to an ascending list of elements. Subject to list
 -- fusion.
-toAscList :: IntSet -> [Int]
+toAscList :: IntSet -> [Key]
 toAscList = foldr (:) []
 
 -- | /O(n)/. Convert the set to a descending list of elements. Subject to list
 -- fusion.
-toDescList :: IntSet -> [Int]
+toDescList :: IntSet -> [Key]
 toDescList = foldl (flip (:)) []
 
 -- List fusion for the list generating functions.
 #if __GLASGOW_HASKELL__
 -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.
 -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.
-foldrFB :: (Int -> b -> b) -> b -> IntSet -> b
+foldrFB :: (Key -> b -> b) -> b -> IntSet -> b
 foldrFB = foldr
 {-# INLINE[0] foldrFB #-}
-foldlFB :: (a -> Int -> a) -> a -> IntSet -> a
+foldlFB :: (a -> Key -> a) -> a -> IntSet -> a
 foldlFB = foldl
 {-# INLINE[0] foldlFB #-}
 
@@ -935,7 +964,7 @@
 
 
 -- | /O(n*min(n,W))/. Create a set from a list of integers.
-fromList :: [Int] -> IntSet
+fromList :: [Key] -> IntSet
 fromList xs
   = foldlStrict ins empty xs
   where
@@ -943,7 +972,7 @@
 
 -- | /O(n)/. Build a set from an ascending list of elements.
 -- /The precondition (input list is ascending) is not checked./
-fromAscList :: [Int] -> IntSet
+fromAscList :: [Key] -> IntSet
 fromAscList [] = Nil
 fromAscList (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)
   where
@@ -954,7 +983,7 @@
 
 -- | /O(n)/. Build a set from an ascending list of distinct elements.
 -- /The precondition (input list is strictly ascending) is not checked./
-fromDistinctAscList :: [Int] -> IntSet
+fromDistinctAscList :: [Key] -> IntSet
 fromDistinctAscList []         = Nil
 fromDistinctAscList (z0 : zs0) = work (prefixOf z0) (bitmapOf z0) zs0 Nada
   where
@@ -1468,9 +1497,13 @@
     Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"
 ----------------------------------------------------------------------}
 bitcount :: Int -> Word -> Int
+#if MIN_VERSION_base(4,5,0)
+bitcount a x = a + popCount x
+#else
 bitcount a0 x0 = go a0 x0
   where go a 0 = a
         go a x = go (a + 1) (x .&. (x-1))
+#endif
 {-# INLINE bitcount #-}
 
 
diff --git a/Data/Map/Base.hs b/Data/Map/Base.hs
--- a/Data/Map/Base.hs
+++ b/Data/Map/Base.hs
@@ -250,6 +250,7 @@
             , balanceR
             , delta
             , join
+            , insertMax
             , merge
             , glue
             , trim
@@ -263,6 +264,7 @@
 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
 import qualified Data.Set.Base as Set
 import Data.StrictPair
+import Data.Bits (shiftL, shiftR)
 import Data.Monoid (Monoid(..))
 import Control.Applicative (Applicative(..), (<$>))
 import Data.Traversable (Traversable(traverse))
@@ -1548,13 +1550,15 @@
 -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
 
 partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
-partitionWithKey _ Tip = (Tip,Tip)
-partitionWithKey p (Bin _ kx x l r)
-  | p kx x    = (join kx x l1 r1,merge l2 r2)
-  | otherwise = (merge l1 r1,join kx x l2 r2)
+partitionWithKey p0 t0 = toPair $ go p0 t0
   where
-    (l1,l2) = partitionWithKey p l
-    (r1,r2) = partitionWithKey p r
+    go _ Tip = (Tip :*: Tip)
+    go p (Bin _ kx x l r)
+      | p kx x    = join kx x l1 r1 :*: merge l2 r2
+      | otherwise = merge l1 r1 :*: join kx x l2 r2
+      where
+        (l1 :*: l2) = go p l
+        (r1 :*: r2) = go p r
 
 -- | /O(n)/. Map values and collect the 'Just' results.
 --
@@ -1598,13 +1602,15 @@
 -- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
 
 mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEitherWithKey _ Tip = (Tip, Tip)
-mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
-  Left y  -> (join kx y l1 r1, merge l2 r2)
-  Right z -> (merge l1 r1, join kx z l2 r2)
- where
-    (l1,l2) = mapEitherWithKey f l
-    (r1,r2) = mapEitherWithKey f r
+mapEitherWithKey f0 t0 = toPair $ go f0 t0
+  where
+    go _ Tip = (Tip :*: Tip)
+    go f (Bin _ kx x l r) = case f kx x of
+      Left y  -> join kx y l1 r1 :*: merge l2 r2
+      Right z -> merge l1 r1 :*: join kx z l2 r2
+     where
+        (l1 :*: l2) = go f l
+        (r1 :*: r2) = go f r
 
 {--------------------------------------------------------------------
   Mapping
@@ -1911,15 +1917,52 @@
 -- If the list contains more than one value for the same key, the last value
 -- for the key is retained.
 --
+-- If the keys of the list are ordered, linear-time implementation is used,
+-- with the performance equal to 'fromDistinctAscList'.
+--
 -- > fromList [] == empty
 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
 
+-- For some reason, when 'singleton' is used in fromList or in
+-- create, it is not inlined, so we inline it manually.
 fromList :: Ord k => [(k,a)] -> Map k a
-fromList xs
-  = foldlStrict ins empty xs
+fromList [] = Tip
+fromList [(kx, x)] = Bin 1 kx x Tip Tip
+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0
+                           | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
-    ins t (k,x) = insert k x t
+    not_ordered _ [] = False
+    not_ordered kx ((ky,_) : _) = kx >= ky
+    {-# INLINE not_ordered #-}
+
+    fromList' t0 xs = foldlStrict ins t0 xs
+      where ins t (k,x) = insert k x t
+
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go _ t [(kx, x)] = insertMax kx x t
+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs
+                              | otherwise = case create s xss of
+                                  (r, ys, []) -> go (s `shiftL` 1) (join kx x l r) ys
+                                  (r, _,  ys) -> fromList' (join kx x l r) ys
+
+    -- The create is returning a triple (tree, xs, ys). Both xs and ys
+    -- represent not yet processed elements and only one of them can be nonempty.
+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree
+    -- and must be inserted using fromList'. Otherwise the keys have been
+    -- ordered so far.
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [], [])
+    create s xs@(xp : xss)
+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)
+                                    | otherwise -> (Bin 1 kx x Tip Tip, xss, [])
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, [], _) -> res
+                      (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)
+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)
+                                               | otherwise -> case create (s `shiftR` 1) yss of
+                                                   (r, zs, ws) -> (join ky y l r, zs, ws)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE fromList #-}
 #endif
@@ -2082,24 +2125,25 @@
 -- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True
 -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
 
+-- For some reason, when 'singleton' is used in fromDistinctAscList or in
+-- create, it is not inlined, so we inline it manually.
 fromDistinctAscList :: [(k,a)] -> Map k a
-fromDistinctAscList xs
-  = create const (length xs) xs
+fromDistinctAscList [] = Tip
+fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
-    -- 1) use continuations so that we use heap space instead of stack space.
-    -- 2) special case for n==5 to create bushier trees.
-    create c 0 xs' = c Tip xs'
-    create c 5 xs' = case xs' of
-                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
-                            -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
-                       _ -> error "fromDistinctAscList create"
-    create c n xs' = seq nr $ create (createR nr c) nl xs'
-      where nl = n `div` 2
-            nr = n - nl - 1
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go s l ((kx, x) : xs) = case create s xs of
+                              (r, ys) -> go (s `shiftL` 1) (join kx x l r) ys
 
-    createR n c l ((k,x):ys) = create (createB l k x c) n ys
-    createR _ _ _ []         = error "fromDistinctAscList createR []"
-    createB l k x c r zs     = c (bin k x l r) zs
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [])
+    create s xs@(x' : xs')
+      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs')
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, []) -> res
+                      (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (r, zs) -> (join ky y l r, zs)
 
 
 {--------------------------------------------------------------------
@@ -2145,23 +2189,27 @@
 
 -- See Note: Type of local 'go' function
 trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe a, Map k a)
-trimLookupLo lk NothingS t = greater lk t
-  where greater :: Ord k => k -> Map k a -> (Maybe a, Map k a)
-        greater lo t'@(Bin _ kx x l r) = case compare lo kx of LT -> lookup lo l `strictPair` t'
-                                                               EQ -> (Just x, r)
-                                                               GT -> greater lo r
-        greater _ Tip = (Nothing, Tip)
-trimLookupLo lk (JustS hk) t = middle lk hk t
-  where middle :: Ord k => k -> k -> Map k a -> (Maybe a, Map k a)
-        middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of LT | kx < hi -> lookup lo l `strictPair` t'
-                                                                    | otherwise -> middle lo hi l
-                                                                 EQ -> Just x `strictPair` lesser hi r
-                                                                 GT -> middle lo hi r
-        middle _ _ Tip = (Nothing, Tip)
+trimLookupLo lk0 mhk0 t0 = toPair $ go lk0 mhk0 t0
+  where
+    go lk NothingS t = greater lk t
+      where greater :: Ord k => k -> Map k a -> StrictPair (Maybe a) (Map k a)
+            greater lo t'@(Bin _ kx x l r) = case compare lo kx of
+                LT -> lookup lo l :*: t'
+                EQ -> (Just x :*: r)
+                GT -> greater lo r
+            greater _ Tip = (Nothing :*: Tip)
+    go lk (JustS hk) t = middle lk hk t
+      where middle :: Ord k => k -> k -> Map k a -> StrictPair (Maybe a) (Map k a)
+            middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of
+                LT | kx < hi -> lookup lo l :*: t'
+                   | otherwise -> middle lo hi l
+                EQ -> Just x :*: lesser hi r
+                GT -> middle lo hi r
+            middle _ _ Tip = (Nothing :*: Tip)
 
-        lesser :: Ord k => k -> Map k a -> Map k a
-        lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l
-        lesser _ t' = t'
+            lesser :: Ord k => k -> Map k a -> Map k a
+            lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l
+            lesser _ t' = t'
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE trimLookupLo #-}
 #endif
@@ -2209,13 +2257,15 @@
 -- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
 
 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
-split k t = k `seq`
-  case t of
-    Tip            -> (Tip, Tip)
-    Bin _ kx x l r -> case compare k kx of
-      LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
-      GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
-      EQ -> (l,r)
+split k0 t0 = k0 `seq` toPair $ go k0 t0
+  where
+    go k t =
+      case t of
+        Tip            -> (Tip :*: Tip)
+        Bin _ kx x l r -> case compare k kx of
+          LT -> let (lt :*: gt) = go k l in lt :*: join kx x gt r
+          GT -> let (lt :*: gt) = go k r in join kx x l lt :*: gt
+          EQ -> (l :*: r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE split #-}
 #endif
@@ -2234,8 +2284,12 @@
   case t of
     Tip            -> (Tip,Nothing,Tip)
     Bin _ kx x l r -> case compare k kx of
-      LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
-      GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
+      LT -> let (lt,z,gt) = splitLookup k l
+                gt' = join kx x gt r
+            in gt' `seq` (lt,z,gt')
+      GT -> let (lt,z,gt) = splitLookup k r
+                lt' = join kx x l lt
+            in lt' `seq` (lt',z,gt)
       EQ -> (l,Just x,r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE splitLookup #-}
diff --git a/Data/Map/Lazy.hs b/Data/Map/Lazy.hs
--- a/Data/Map/Lazy.hs
+++ b/Data/Map/Lazy.hs
@@ -16,7 +16,7 @@
 -- (dictionaries).
 --
 -- API of this module is strict in the keys, but lazy in the values.
--- If you need value-strict maps, use 'Data.Map.Strict' instead.
+-- If you need value-strict maps, use "Data.Map.Strict" instead.
 -- The 'Map' type itself is shared between the lazy and strict modules,
 -- meaning that the same 'Map' value can be passed to functions in
 -- both modules (although that is rarely needed).
diff --git a/Data/Map/Strict.hs b/Data/Map/Strict.hs
--- a/Data/Map/Strict.hs
+++ b/Data/Map/Strict.hs
@@ -16,7 +16,7 @@
 -- (dictionaries).
 --
 -- API of this module is strict in both the keys and the values.
--- If you need value-lazy maps, use 'Data.Map.Lazy' instead.
+-- If you need value-lazy maps, use "Data.Map.Lazy" instead.
 -- The 'Map' type is shared between the lazy and strict modules,
 -- meaning that the same 'Map' value can be passed to functions in
 -- both modules (although that is rarely needed).
@@ -45,7 +45,7 @@
 -- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).
 --
 -- Be aware that the 'Functor', 'Traversable' and 'Data' instances
--- are the same as for the 'Data.Map.Lazy' module, so if they are used
+-- are the same as for the "Data.Map.Lazy" module, so if they are used
 -- on strict maps, the resulting maps will be lazy.
 -----------------------------------------------------------------------------
 
@@ -267,6 +267,7 @@
     )
 import qualified Data.Set.Base as Set
 import Data.StrictPair
+import Data.Bits (shiftL, shiftR)
 
 -- Use macros to define strictness of functions.  STRICT_x_OF_y
 -- denotes an y-ary function strict in the x-th parameter. Similarly
@@ -274,6 +275,8 @@
 -- y-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
+#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined
 #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined
 #define STRICT_1_2_OF_3(fn) fn arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined
 #define STRICT_2_3_OF_4(fn) fn _ arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined
@@ -434,19 +437,19 @@
 -- See Map.Base.Note: Type of local 'go' function
 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
                     -> (Maybe a, Map k a)
-insertLookupWithKey = go
+insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0
   where
-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)
     STRICT_2_3_OF_4(go)
-    go _ kx x Tip = Nothing `strictPair` singleton kx x
+    go _ kx x Tip = Nothing :*: singleton kx x
     go f kx x (Bin sy ky y l r) =
         case compare kx ky of
-            LT -> let (found, l') = go f kx x l
-                  in found `strictPair` balanceL ky y l' r
-            GT -> let (found, r') = go f kx x r
-                  in found `strictPair` balanceR ky y l r'
+            LT -> let (found :*: l') = go f kx x l
+                  in found :*: balanceL ky y l' r
+            GT -> let (found :*: r') = go f kx x r
+                  in found :*: balanceR ky y l r'
             EQ -> let x' = f kx x y
-                  in x' `seq` (Just y `strictPair` Bin sy kx x' l r)
+                  in x' `seq` (Just y :*: Bin sy kx x' l r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE insertLookupWithKey #-}
 #else
@@ -547,20 +550,20 @@
 
 -- See Map.Base.Note: Type of local 'go' function
 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
-updateLookupWithKey = go
+updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0
  where
-   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
+   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)
    STRICT_2_OF_3(go)
-   go _ _ Tip = (Nothing,Tip)
+   go _ _ Tip = (Nothing :*: Tip)
    go f k (Bin sx kx x l r) =
           case compare k kx of
-               LT -> let (found,l') = go f k l
-                     in found `strictPair` balanceR kx x l' r
-               GT -> let (found,r') = go f k r
-                     in found `strictPair` balanceL kx x l r'
+               LT -> let (found :*: l') = go f k l
+                     in found :*: balanceR kx x l' r
+               GT -> let (found :*: r') = go f k r
+                     in found :*: balanceL kx x l r'
                EQ -> case f kx x of
-                       Just x' -> x' `seq` (Just x' `strictPair` Bin sx kx x' l r)
-                       Nothing -> (Just x,glue l r)
+                       Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)
+                       Nothing -> (Just x :*: glue l r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE updateLookupWithKey #-}
 #else
@@ -899,13 +902,15 @@
 -- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
 
 mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
-mapEitherWithKey _ Tip = (Tip, Tip)
-mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
-  Left y  -> y `seq` (join kx y l1 r1 `strictPair` merge l2 r2)
-  Right z -> z `seq` (merge l1 r1 `strictPair` join kx z l2 r2)
- where
-    (l1,l2) = mapEitherWithKey f l
-    (r1,r2) = mapEitherWithKey f r
+mapEitherWithKey f0 t0 = toPair $ go f0 t0
+  where
+    go _ Tip = (Tip :*: Tip)
+    go f (Bin _ kx x l r) = case f kx x of
+      Left y  -> y `seq` (join kx y l1 r1 :*: merge l2 r2)
+      Right z -> z `seq` (merge l1 r1 :*: join kx z l2 r2)
+     where
+        (l1 :*: l2) = go f l
+        (r1 :*: r2) = go f r
 
 {--------------------------------------------------------------------
   Mapping
@@ -1006,15 +1011,52 @@
 -- If the list contains more than one value for the same key, the last value
 -- for the key is retained.
 --
+-- If the keys of the list are ordered, linear-time implementation is used,
+-- with the performance equal to 'fromDistinctAscList'.
+--
 -- > fromList [] == empty
 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
 
+-- For some reason, when 'singleton' is used in fromList or in
+-- create, it is not inlined, so we inline it manually.
 fromList :: Ord k => [(k,a)] -> Map k a
-fromList xs
-  = foldlStrict ins empty xs
+fromList [] = Tip
+fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip
+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0
+                           | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
-    ins t (k,x) = insert k x t
+    not_ordered _ [] = False
+    not_ordered kx ((ky,_) : _) = kx >= ky
+    {-# INLINE not_ordered #-}
+
+    fromList' t0 xs = foldlStrict ins t0 xs
+      where ins t (k,x) = insert k x t
+
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go _ t [(kx, x)] = x `seq` insertMax kx x t
+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs
+                              | otherwise = case create s xss of
+                                  (r, ys, []) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys
+                                  (r, _,  ys) -> x `seq` fromList' (join kx x l r) ys
+
+    -- The create is returning a triple (tree, xs, ys). Both xs and ys
+    -- represent not yet processed elements and only one of them can be nonempty.
+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree
+    -- and must be inserted using fromList'. Otherwise the keys have been
+    -- ordered so far.
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [], [])
+    create s xs@(xp : xss)
+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)
+                                    | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, [], _) -> res
+                      (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)
+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)
+                                               | otherwise -> case create (s `shiftR` 1) yss of
+                                                   (r, zs, ws) -> y `seq` (join ky y l r, zs, ws)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE fromList #-}
 #endif
@@ -1117,23 +1159,22 @@
 -- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True
 -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
 
+-- For some reason, when 'singleton' is used in fromDistinctAscList or in
+-- create, it is not inlined, so we inline it manually.
 fromDistinctAscList :: [(k,a)] -> Map k a
-fromDistinctAscList xs
-  = create const (length xs) xs
+fromDistinctAscList [] = Tip
+fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
-    -- 1) use continuations so that we use heap space instead of stack space.
-    -- 2) special case for n==5 to create bushier trees.
-    create c 0 xs' = c Tip xs'
-    create c 5 xs' = case xs' of
-                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
-                            -> x1 `seq` x2 `seq` x3 `seq` x4 `seq` x5 `seq`
-                               c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3))
-                                  (singleton k5 x5)) xx
-                       _ -> error "fromDistinctAscList create"
-    create c n xs' = seq nr $ create (createR nr c) nl xs'
-      where nl = n `div` 2
-            nr = n - nl - 1
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go s l ((kx, x) : xs) = case create s xs of
+                              (r, ys) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys
 
-    createR n c l ((k,x):ys) = x `seq` create (createB l k x c) n ys
-    createR _ _ _ []         = error "fromDistinctAscList createR []"
-    createB l k x c r zs     = x `seq` c (bin k x l r) zs
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [])
+    create s xs@(x' : xs')
+      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs')
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, []) -> res
+                      (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (r, zs) -> y `seq` (join ky y l r, zs)
diff --git a/Data/Set/Base.hs b/Data/Set/Base.hs
--- a/Data/Set/Base.hs
+++ b/Data/Set/Base.hs
@@ -177,11 +177,14 @@
 
 import Prelude hiding (filter,foldl,foldr,null,map)
 import qualified Data.List as List
+import Data.Bits (shiftL, shiftR)
 import Data.Monoid (Monoid(..))
 import qualified Data.Foldable as Foldable
 import Data.Typeable
 import Control.DeepSeq (NFData(rnf))
 
+import Data.StrictPair
+
 #if __GLASGOW_HASKELL__
 import GHC.Exts ( build )
 import Text.Read
@@ -623,11 +626,13 @@
 -- the predicate and one with all elements that don't satisfy the predicate.
 -- See also 'split'.
 partition :: (a -> Bool) -> Set a -> (Set a,Set a)
-partition _ Tip = (Tip, Tip)
-partition p (Bin _ x l r) = case (partition p l, partition p r) of
-  ((l1, l2), (r1, r2))
-    | p x       -> (join x l1 r1, merge l2 r2)
-    | otherwise -> (merge l1 r1, join x l2 r2)
+partition p0 t0 = toPair $ go p0 t0
+  where
+    go _ Tip = (Tip :*: Tip)
+    go p (Bin _ x l r) = case (go p l, go p r) of
+      ((l1 :*: l2), (r1 :*: r2))
+        | p x       -> join x l1 r1 :*: merge l2 r2
+        | otherwise -> merge l1 r1 :*: join x l2 r2
 
 {----------------------------------------------------------------------
   Map
@@ -773,10 +778,49 @@
 #endif
 
 -- | /O(n*log n)/. Create a set from a list of elements.
+--
+-- If the elemens are ordered, linear-time implementation is used,
+-- with the performance equal to 'fromDistinctAscList'.
+
+-- For some reason, when 'singleton' is used in fromList or in
+-- create, it is not inlined, so we inline it manually.
 fromList :: Ord a => [a] -> Set a
-fromList = foldlStrict ins empty
+fromList [] = Tip
+fromList [x] = Bin 1 x Tip Tip
+fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0
+                    | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0
   where
-    ins t x = insert x t
+    not_ordered _ [] = False
+    not_ordered x (y : _) = x >= y
+    {-# INLINE not_ordered #-}
+
+    fromList' t0 xs = foldlStrict ins t0 xs
+      where ins t x = insert x t
+
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go _ t [x] = insertMax x t
+    go s l xs@(x : xss) | not_ordered x xss = fromList' l xs
+                        | otherwise = case create s xss of
+                            (r, ys, []) -> go (s `shiftL` 1) (join x l r) ys
+                            (r, _,  ys) -> fromList' (join x l r) ys
+
+    -- The create is returning a triple (tree, xs, ys). Both xs and ys
+    -- represent not yet processed elements and only one of them can be nonempty.
+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree
+    -- and must be inserted using fromList'. Otherwise the keys have been
+    -- ordered so far.
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [], [])
+    create s xs@(x : xss)
+      | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)
+                                      else (Bin 1 x Tip Tip, xss, [])
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, [], _) -> res
+                      (l, [y], zs) -> (insertMax y l, [], zs)
+                      (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)
+                                         | otherwise -> case create (s `shiftR` 1) yss of
+                                                   (r, zs, ws) -> (join y l r, zs, ws)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE fromList #-}
 #endif
@@ -811,24 +855,26 @@
 
 -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
 -- /The precondition (input list is strictly ascending) is not checked./
+
+-- For some reason, when 'singleton' is used in fromDistinctAscList or in
+-- create, it is not inlined, so we inline it manually.
 fromDistinctAscList :: [a] -> Set a
-fromDistinctAscList xs
-  = create const (length xs) xs
+fromDistinctAscList [] = Tip
+fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
   where
-    -- 1) use continutations so that we use heap space instead of stack space.
-    -- 2) special case for n==5 to create bushier trees.
-    create c 0 xs' = c Tip xs'
-    create c 5 xs' = case xs' of
-                       (x1:x2:x3:x4:x5:xx)
-                            -> c (bin x4 (bin x2 (singleton x1) (singleton x3)) (singleton x5)) xx
-                       _ -> error "fromDistinctAscList create 5"
-    create c n xs' = seq nr $ create (createR nr c) nl xs'
-      where nl = n `div` 2
-            nr = n - nl - 1
+    STRICT_1_OF_3(go)
+    go _ t [] = t
+    go s l (x : xs) = case create s xs of
+                        (r, ys) -> go (s `shiftL` 1) (join x l r) ys
 
-    createR n c l (x:ys) = create (createB l x c) n ys
-    createR _ _ _ []     = error "fromDistinctAscList createR []"
-    createB l x c r zs   = c (bin x l r) zs
+    STRICT_1_OF_2(create)
+    create _ [] = (Tip, [])
+    create s xs@(x : xs')
+      | s == 1 = (Bin 1 x Tip Tip, xs')
+      | otherwise = case create (s `shiftR` 1) xs of
+                      res@(_, []) -> res
+                      (l, y:ys) -> case create (s `shiftR` 1) ys of
+                        (r, zs) -> (join y l r, zs)
 
 {--------------------------------------------------------------------
   Eq converts the set to a list. In a lazy setting, this
@@ -958,12 +1004,14 @@
 -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
 -- comprises the elements of @set@ greater than @x@.
 split :: Ord a => a -> Set a -> (Set a,Set a)
-split _ Tip = (Tip,Tip)
-split x (Bin _ y l r)
-  = case compare x y of
-      LT -> let (lt,gt) = split x l in (lt,join y gt r)
-      GT -> let (lt,gt) = split x r in (join y l lt,gt)
-      EQ -> (l,r)
+split x0 t0 = toPair $ go x0 t0
+  where
+    go _ Tip = (Tip :*: Tip)
+    go x (Bin _ y l r)
+      = case compare x y of
+          LT -> let (lt :*: gt) = go x l in (lt :*: join y gt r)
+          GT -> let (lt :*: gt) = go x r in (join y l lt :*: gt)
+          EQ -> (l :*: r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE split #-}
 #endif
@@ -974,8 +1022,12 @@
 splitMember _ Tip = (Tip, False, Tip)
 splitMember x (Bin _ y l r)
    = case compare x y of
-       LT -> let (lt, found, gt) = splitMember x l in (lt, found, join y gt r)
-       GT -> let (lt, found, gt) = splitMember x r in (join y l lt, found, gt)
+       LT -> let (lt, found, gt) = splitMember x l
+                 gt' = join y gt r
+             in gt' `seq` (lt, found, gt')
+       GT -> let (lt, found, gt) = splitMember x r
+                 lt' = join y l lt
+             in lt' `seq` (lt', found, gt)
        EQ -> (l, True, r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINABLE splitMember #-}
diff --git a/Data/StrictPair.hs b/Data/StrictPair.hs
--- a/Data/StrictPair.hs
+++ b/Data/StrictPair.hs
@@ -1,6 +1,9 @@
-module Data.StrictPair (strictPair) where
+module Data.StrictPair (StrictPair(..), toPair) where
 
--- | Evaluate both argument to WHNF and create a pair of the result.
-strictPair :: a -> b -> (a, b)
-strictPair x y = x `seq` y `seq` (x, y)
-{-# INLINE strictPair #-}
+-- | Same as regular Haskell pairs, but (x :*: _|_) = (_|_ :*: y) =
+-- _|_
+data StrictPair a b = !a :*: !b
+
+toPair :: StrictPair a b -> (a, b)
+toPair (x :*: y) = (x, y)
+{-# INLINE toPair #-}
diff --git a/benchmarks/IntMap.hs b/benchmarks/IntMap.hs
--- a/benchmarks/IntMap.hs
+++ b/benchmarks/IntMap.hs
@@ -39,6 +39,9 @@
         , bench "alter"  $ whnf (alt keys) m
         , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m
         , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m
+        , bench "fromList" $ whnf M.fromList elems
+        , bench "fromAscList" $ whnf M.fromAscList elems
+        , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems
         ]
   where
     elems = zip keys values
diff --git a/benchmarks/IntSet.hs b/benchmarks/IntSet.hs
--- a/benchmarks/IntSet.hs
+++ b/benchmarks/IntSet.hs
@@ -32,11 +32,14 @@
         , bench "union" $ whnf (S.union s_even) s_odd
         , bench "difference" $ whnf (S.difference s) s_even
         , bench "intersection" $ whnf (S.intersection s) s_even
+        , bench "fromList" $ whnf S.fromList elems
+        , bench "fromAscList" $ whnf S.fromAscList elems
+        , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems
         ]
   where
-    elems = [1..2^10]
-    elems_even = [2,4..2^10]
-    elems_odd = [1,3..2^10]
+    elems = [1..2^12]
+    elems_even = [2,4..2^12]
+    elems_odd = [1,3..2^12]
 
 member :: [Int] -> S.IntSet -> Int
 member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs
diff --git a/benchmarks/Makefile b/benchmarks/Makefile
--- a/benchmarks/Makefile
+++ b/benchmarks/Makefile
@@ -4,7 +4,7 @@
 	ghc -O2 -DTESTING $< -i../$(TOP) -o $@ -outputdir tmp -rtsopts
 
 bench-%.csv: bench-%
-	./bench-$* -v -u bench-$*.csv
+	./bench-$* $(BENCHMARK) -v -u bench-$*.csv
 
 .PHONY: force clean veryclean
 force:
diff --git a/benchmarks/Map.hs b/benchmarks/Map.hs
--- a/benchmarks/Map.hs
+++ b/benchmarks/Map.hs
@@ -57,9 +57,14 @@
         , bench "union" $ whnf (M.union m_even) m_odd
         , bench "difference" $ whnf (M.difference m) m_even
         , bench "intersection" $ whnf (M.intersection m) m_even
+        , bench "split" $ whnf (M.split (bound `div` 2)) m
+        , bench "fromList" $ whnf M.fromList elems
+        , bench "fromList-desc" $ whnf M.fromList (reverse elems)
+        , bench "fromAscList" $ whnf M.fromAscList elems
+        , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems
         ]
   where
-    bound = 2^10
+    bound = 2^12
     elems = zip keys values
     elems_even = zip evens evens
     elems_odd = zip odds odds
diff --git a/benchmarks/Set.hs b/benchmarks/Set.hs
--- a/benchmarks/Set.hs
+++ b/benchmarks/Set.hs
@@ -33,11 +33,15 @@
         , bench "union" $ whnf (S.union s_even) s_odd
         , bench "difference" $ whnf (S.difference s) s_even
         , bench "intersection" $ whnf (S.intersection s) s_even
+        , bench "fromList" $ whnf S.fromList elems
+        , bench "fromList-desc" $ whnf S.fromList (reverse elems)
+        , bench "fromAscList" $ whnf S.fromAscList elems
+        , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems
         ]
   where
-    elems = [1..2^10]
-    elems_even = [2,4..2^10]
-    elems_odd = [1,3..2^10]
+    elems = [1..2^12]
+    elems_even = [2,4..2^12]
+    elems_odd = [1,3..2^12]
 
 member :: [Int] -> S.Set Int -> Int
 member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs
diff --git a/containers.cabal b/containers.cabal
--- a/containers.cabal
+++ b/containers.cabal
@@ -1,5 +1,5 @@
 name: containers
-version: 0.5.0.0
+version: 0.5.1.0
 license: BSD3
 license-file: LICENSE
 maintainer: fox@ucw.cz
diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs
--- a/tests/intmap-properties.hs
+++ b/tests/intmap-properties.hs
@@ -27,7 +27,7 @@
 default (Int)
 
 main :: IO ()
-main = defaultMainWithOpts
+main = defaultMain
          [
                testCase "index"      test_index
              , testCase "size"       test_size
@@ -137,6 +137,7 @@
              , testProperty "fromList then toList" prop_list
              , testProperty "toDescList"           prop_descList
              , testProperty "toAscList+toDescList" prop_ascDescList
+             , testProperty "fromList"             prop_fromList
              , testProperty "alter"                prop_alter
              , testProperty "index"                prop_index
              , testProperty "null"                 prop_null
@@ -165,13 +166,7 @@
              , testProperty "foldl'"               prop_foldl'
              , testProperty "keysSet"              prop_keysSet
              , testProperty "fromSet"              prop_fromSet
-             ] opts
-
-  where
-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500
-                                                      , topt_maximum_unsuitable_generated_tests = Just 500
-                                                      }
-                  }
+             ]
 
 {--------------------------------------------------------------------
   Arbitrary, reasonably balanced trees
@@ -852,6 +847,15 @@
 prop_ascDescList :: [Int] -> Bool
 prop_ascDescList xs = toAscList m == reverse (toDescList m)
   where m = fromList $ zip xs $ repeat ()
+
+prop_fromList :: [Int] -> Bool
+prop_fromList xs
+  = case fromList (zip xs xs) of
+      t -> t == fromAscList (zip sort_xs sort_xs) &&
+           t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) &&
+           t == List.foldr (uncurry insert) empty (zip xs xs)
+  where sort_xs = sort xs
+        nub_sort_xs = List.map List.head $ List.group sort_xs
 
 ----------------------------------------------------------------
 
diff --git a/tests/intset-properties.hs b/tests/intset-properties.hs
--- a/tests/intset-properties.hs
+++ b/tests/intset-properties.hs
@@ -1,4 +1,10 @@
+{-# LANGUAGE CPP #-}
+#if MIN_VERSION_base(4,5,0)
+import Data.Bits ((.&.), popCount)
+import Data.Word (Word)
+#else
 import Data.Bits ((.&.))
+#endif
 import Data.IntSet
 import Data.List (nub,sort)
 import qualified Data.List as List
@@ -12,59 +18,57 @@
 import Test.QuickCheck hiding ((.&.))
 
 main :: IO ()
-main = defaultMainWithOpts [ testCase "lookupLT" test_lookupLT
-                           , testCase "lookupGT" test_lookupGT
-                           , testCase "lookupLE" test_lookupLE
-                           , testCase "lookupGE" test_lookupGE
-                           , testCase "split" test_split
-                           , testProperty "prop_Single" prop_Single
-                           , testProperty "prop_Member" prop_Member
-                           , testProperty "prop_NotMember" prop_NotMember
-                           , testProperty "prop_LookupLT" prop_LookupLT
-                           , testProperty "prop_LookupGT" prop_LookupGT
-                           , testProperty "prop_LookupLE" prop_LookupLE
-                           , testProperty "prop_LookupGE" prop_LookupGE
-                           , testProperty "prop_InsertDelete" prop_InsertDelete
-                           , testProperty "prop_MemberFromList" prop_MemberFromList
-                           , testProperty "prop_UnionInsert" prop_UnionInsert
-                           , testProperty "prop_UnionAssoc" prop_UnionAssoc
-                           , testProperty "prop_UnionComm" prop_UnionComm
-                           , testProperty "prop_Diff" prop_Diff
-                           , testProperty "prop_Int" prop_Int
-                           , testProperty "prop_Ordered" prop_Ordered
-                           , testProperty "prop_List" prop_List
-                           , testProperty "prop_DescList" prop_DescList
-                           , testProperty "prop_AscDescList" prop_AscDescList
-                           , testProperty "prop_fromList" prop_fromList
-                           , testProperty "prop_MaskPow2" prop_MaskPow2
-                           , testProperty "prop_Prefix" prop_Prefix
-                           , testProperty "prop_LeftRight" prop_LeftRight
-                           , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
-                           , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
-                           , testProperty "prop_isSubsetOf" prop_isSubsetOf
-                           , testProperty "prop_isSubsetOf2" prop_isSubsetOf2
-                           , testProperty "prop_size" prop_size
-                           , testProperty "prop_findMax" prop_findMax
-                           , testProperty "prop_findMin" prop_findMin
-                           , testProperty "prop_ord" prop_ord
-                           , testProperty "prop_readShow" prop_readShow
-                           , testProperty "prop_foldR" prop_foldR
-                           , testProperty "prop_foldR'" prop_foldR'
-                           , testProperty "prop_foldL" prop_foldL
-                           , testProperty "prop_foldL'" prop_foldL'
-                           , testProperty "prop_map" prop_map
-                           , testProperty "prop_maxView" prop_maxView
-                           , testProperty "prop_minView" prop_minView
-                           , testProperty "prop_split" prop_split
-                           , testProperty "prop_splitMember" prop_splitMember
-                           , testProperty "prop_partition" prop_partition
-                           , testProperty "prop_filter" prop_filter
-                           ] opts
-  where
-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500
-                                                      , topt_maximum_unsuitable_generated_tests = Just 500
-                                                      }
-                  }
+main = defaultMain [ testCase "lookupLT" test_lookupLT
+                   , testCase "lookupGT" test_lookupGT
+                   , testCase "lookupLE" test_lookupLE
+                   , testCase "lookupGE" test_lookupGE
+                   , testCase "split" test_split
+                   , testProperty "prop_Single" prop_Single
+                   , testProperty "prop_Member" prop_Member
+                   , testProperty "prop_NotMember" prop_NotMember
+                   , testProperty "prop_LookupLT" prop_LookupLT
+                   , testProperty "prop_LookupGT" prop_LookupGT
+                   , testProperty "prop_LookupLE" prop_LookupLE
+                   , testProperty "prop_LookupGE" prop_LookupGE
+                   , testProperty "prop_InsertDelete" prop_InsertDelete
+                   , testProperty "prop_MemberFromList" prop_MemberFromList
+                   , testProperty "prop_UnionInsert" prop_UnionInsert
+                   , testProperty "prop_UnionAssoc" prop_UnionAssoc
+                   , testProperty "prop_UnionComm" prop_UnionComm
+                   , testProperty "prop_Diff" prop_Diff
+                   , testProperty "prop_Int" prop_Int
+                   , testProperty "prop_Ordered" prop_Ordered
+                   , testProperty "prop_List" prop_List
+                   , testProperty "prop_DescList" prop_DescList
+                   , testProperty "prop_AscDescList" prop_AscDescList
+                   , testProperty "prop_fromList" prop_fromList
+                   , testProperty "prop_MaskPow2" prop_MaskPow2
+                   , testProperty "prop_Prefix" prop_Prefix
+                   , testProperty "prop_LeftRight" prop_LeftRight
+                   , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
+                   , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
+                   , testProperty "prop_isSubsetOf" prop_isSubsetOf
+                   , testProperty "prop_isSubsetOf2" prop_isSubsetOf2
+                   , testProperty "prop_size" prop_size
+                   , testProperty "prop_findMax" prop_findMax
+                   , testProperty "prop_findMin" prop_findMin
+                   , testProperty "prop_ord" prop_ord
+                   , testProperty "prop_readShow" prop_readShow
+                   , testProperty "prop_foldR" prop_foldR
+                   , testProperty "prop_foldR'" prop_foldR'
+                   , testProperty "prop_foldL" prop_foldL
+                   , testProperty "prop_foldL'" prop_foldL'
+                   , testProperty "prop_map" prop_map
+                   , testProperty "prop_maxView" prop_maxView
+                   , testProperty "prop_minView" prop_minView
+                   , testProperty "prop_split" prop_split
+                   , testProperty "prop_splitMember" prop_splitMember
+                   , testProperty "prop_partition" prop_partition
+                   , testProperty "prop_filter" prop_filter
+#if MIN_VERSION_base(4,5,0)
+                   , testProperty "prop_bitcount" prop_bitcount
+#endif
+                   ]
 
 ----------------------------------------------------------------
 -- Unit tests
@@ -310,3 +314,13 @@
 
 prop_filter :: IntSet -> Int -> Bool
 prop_filter s i = partition odd s == (filter odd s, filter even s)
+
+#if MIN_VERSION_base(4,5,0)
+prop_bitcount :: Int -> Word -> Bool
+prop_bitcount a w = bitcount_orig a w == bitcount_new a w
+  where
+    bitcount_orig a0 x0 = go a0 x0
+      where go a 0 = a
+            go a x = go (a + 1) (x .&. (x-1))
+    bitcount_new a x = a + popCount x
+#endif
diff --git a/tests/map-properties.hs b/tests/map-properties.hs
--- a/tests/map-properties.hs
+++ b/tests/map-properties.hs
@@ -27,7 +27,7 @@
 default (Int)
 
 main :: IO ()
-main = defaultMainWithOpts
+main = defaultMain
          [ testCase "ticket4242" test_ticket4242
          , testCase "index"      test_index
          , testCase "size"       test_size
@@ -126,7 +126,7 @@
          , testCase "minViewWithKey" test_minViewWithKey
          , testCase "maxViewWithKey" test_maxViewWithKey
          , testCase "valid" test_valid
-         , testProperty "fromList"             prop_fromList
+         , testProperty "valid"                prop_valid
          , testProperty "insert to singleton"  prop_singleton
          , testProperty "insert"               prop_insert
          , testProperty "insert then lookup"   prop_insertLookup
@@ -158,6 +158,7 @@
          , testProperty "fromList then toList" prop_list
          , testProperty "toDescList"           prop_descList
          , testProperty "toAscList+toDescList" prop_ascDescList
+         , testProperty "fromList"             prop_fromList
          , testProperty "alter"                prop_alter
          , testProperty "index"                prop_index
          , testProperty "null"                 prop_null
@@ -188,13 +189,7 @@
          , testProperty "foldl'"               prop_foldl'
          , testProperty "keysSet"              prop_keysSet
          , testProperty "fromSet"              prop_fromSet
-         ] opts
-
-  where
-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500
-                                                      , topt_maximum_unsuitable_generated_tests = Just 500
-                                                      }
-                  }
+         ]
 
 {--------------------------------------------------------------------
   Arbitrary, reasonably balanced trees
@@ -831,8 +826,8 @@
 -- QuickCheck
 ----------------------------------------------------------------
 
-prop_fromList :: UMap -> Bool
-prop_fromList t = valid t
+prop_valid :: UMap -> Bool
+prop_valid t = valid t
 
 prop_singleton :: Int -> Int -> Bool
 prop_singleton k x = insert k x empty == singleton k x
@@ -989,6 +984,15 @@
 prop_ascDescList :: [Int] -> Bool
 prop_ascDescList xs = toAscList m == reverse (toDescList m)
   where m = fromList $ zip xs $ repeat ()
+
+prop_fromList :: [Int] -> Bool
+prop_fromList xs
+  = case fromList (zip xs xs) of
+      t -> t == fromAscList (zip sort_xs sort_xs) &&
+           t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) &&
+           t == List.foldr (uncurry insert) empty (zip xs xs)
+  where sort_xs = sort xs
+        nub_sort_xs = List.map List.head $ List.group sort_xs
 
 ----------------------------------------------------------------
 
diff --git a/tests/seq-properties.hs b/tests/seq-properties.hs
--- a/tests/seq-properties.hs
+++ b/tests/seq-properties.hs
@@ -21,7 +21,7 @@
 
 
 main :: IO ()
-main = defaultMainWithOpts
+main = defaultMain
        [ testProperty "fmap" prop_fmap
        , testProperty "(<$)" prop_constmap
        , testProperty "foldr" prop_foldr
@@ -90,13 +90,7 @@
        , testProperty "zipWith3" prop_zipWith3
        , testProperty "zip4" prop_zip4
        , testProperty "zipWith4" prop_zipWith4
-       ] opts
-
-  where
-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500
-                                                      , topt_maximum_unsuitable_generated_tests = Just 500
-                                                      }
-                  }
+       ]
 
 ------------------------------------------------------------------------
 -- Arbitrary
diff --git a/tests/set-properties.hs b/tests/set-properties.hs
--- a/tests/set-properties.hs
+++ b/tests/set-properties.hs
@@ -11,62 +11,57 @@
 import Test.QuickCheck
 
 main :: IO ()
-main = defaultMainWithOpts [ testCase "lookupLT" test_lookupLT
-                           , testCase "lookupGT" test_lookupGT
-                           , testCase "lookupLE" test_lookupLE
-                           , testCase "lookupGE" test_lookupGE
-                           , testProperty "prop_Valid" prop_Valid
-                           , testProperty "prop_Single" prop_Single
-                           , testProperty "prop_Member" prop_Member
-                           , testProperty "prop_NotMember" prop_NotMember
-                           , testProperty "prop_LookupLT" prop_LookupLT
-                           , testProperty "prop_LookupGT" prop_LookupGT
-                           , testProperty "prop_LookupLE" prop_LookupLE
-                           , testProperty "prop_LookupGE" prop_LookupGE
-                           , testProperty "prop_InsertValid" prop_InsertValid
-                           , testProperty "prop_InsertDelete" prop_InsertDelete
-                           , testProperty "prop_DeleteValid" prop_DeleteValid
-                           , testProperty "prop_Join" prop_Join
-                           , testProperty "prop_Merge" prop_Merge
-                           , testProperty "prop_UnionValid" prop_UnionValid
-                           , testProperty "prop_UnionInsert" prop_UnionInsert
-                           , testProperty "prop_UnionAssoc" prop_UnionAssoc
-                           , testProperty "prop_UnionComm" prop_UnionComm
-                           , testProperty "prop_DiffValid" prop_DiffValid
-                           , testProperty "prop_Diff" prop_Diff
-                           , testProperty "prop_IntValid" prop_IntValid
-                           , testProperty "prop_Int" prop_Int
-                           , testProperty "prop_Ordered" prop_Ordered
-                           , testProperty "prop_List" prop_List
-                           , testProperty "prop_DescList" prop_DescList
-                           , testProperty "prop_AscDescList" prop_AscDescList
-                           , testProperty "prop_fromList" prop_fromList
-                           , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
-                           , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
-                           , testProperty "prop_isSubsetOf" prop_isSubsetOf
-                           , testProperty "prop_isSubsetOf2" prop_isSubsetOf2
-                           , testProperty "prop_size" prop_size
-                           , testProperty "prop_findMax" prop_findMax
-                           , testProperty "prop_findMin" prop_findMin
-                           , testProperty "prop_ord" prop_ord
-                           , testProperty "prop_readShow" prop_readShow
-                           , testProperty "prop_foldR" prop_foldR
-                           , testProperty "prop_foldR'" prop_foldR'
-                           , testProperty "prop_foldL" prop_foldL
-                           , testProperty "prop_foldL'" prop_foldL'
-                           , testProperty "prop_map" prop_map
-                           , testProperty "prop_maxView" prop_maxView
-                           , testProperty "prop_minView" prop_minView
-                           , testProperty "prop_split" prop_split
-                           , testProperty "prop_splitMember" prop_splitMember
-                           , testProperty "prop_partition" prop_partition
-                           , testProperty "prop_filter" prop_filter
-                           ] opts
-  where
-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500
-                                                      , topt_maximum_unsuitable_generated_tests = Just 500
-                                                      }
-                  }
+main = defaultMain [ testCase "lookupLT" test_lookupLT
+                   , testCase "lookupGT" test_lookupGT
+                   , testCase "lookupLE" test_lookupLE
+                   , testCase "lookupGE" test_lookupGE
+                   , testProperty "prop_Valid" prop_Valid
+                   , testProperty "prop_Single" prop_Single
+                   , testProperty "prop_Member" prop_Member
+                   , testProperty "prop_NotMember" prop_NotMember
+                   , testProperty "prop_LookupLT" prop_LookupLT
+                   , testProperty "prop_LookupGT" prop_LookupGT
+                   , testProperty "prop_LookupLE" prop_LookupLE
+                   , testProperty "prop_LookupGE" prop_LookupGE
+                   , testProperty "prop_InsertValid" prop_InsertValid
+                   , testProperty "prop_InsertDelete" prop_InsertDelete
+                   , testProperty "prop_DeleteValid" prop_DeleteValid
+                   , testProperty "prop_Join" prop_Join
+                   , testProperty "prop_Merge" prop_Merge
+                   , testProperty "prop_UnionValid" prop_UnionValid
+                   , testProperty "prop_UnionInsert" prop_UnionInsert
+                   , testProperty "prop_UnionAssoc" prop_UnionAssoc
+                   , testProperty "prop_UnionComm" prop_UnionComm
+                   , testProperty "prop_DiffValid" prop_DiffValid
+                   , testProperty "prop_Diff" prop_Diff
+                   , testProperty "prop_IntValid" prop_IntValid
+                   , testProperty "prop_Int" prop_Int
+                   , testProperty "prop_Ordered" prop_Ordered
+                   , testProperty "prop_List" prop_List
+                   , testProperty "prop_DescList" prop_DescList
+                   , testProperty "prop_AscDescList" prop_AscDescList
+                   , testProperty "prop_fromList" prop_fromList
+                   , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf
+                   , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2
+                   , testProperty "prop_isSubsetOf" prop_isSubsetOf
+                   , testProperty "prop_isSubsetOf2" prop_isSubsetOf2
+                   , testProperty "prop_size" prop_size
+                   , testProperty "prop_findMax" prop_findMax
+                   , testProperty "prop_findMin" prop_findMin
+                   , testProperty "prop_ord" prop_ord
+                   , testProperty "prop_readShow" prop_readShow
+                   , testProperty "prop_foldR" prop_foldR
+                   , testProperty "prop_foldR'" prop_foldR'
+                   , testProperty "prop_foldL" prop_foldL
+                   , testProperty "prop_foldL'" prop_foldL'
+                   , testProperty "prop_map" prop_map
+                   , testProperty "prop_maxView" prop_maxView
+                   , testProperty "prop_minView" prop_minView
+                   , testProperty "prop_split" prop_split
+                   , testProperty "prop_splitMember" prop_splitMember
+                   , testProperty "prop_partition" prop_partition
+                   , testProperty "prop_filter" prop_filter
+                   ]
 
 ----------------------------------------------------------------
 -- Unit tests