Change the worker/wrapper to explicitly pass arguments.
authorMilan Straka <fox@ucw.cz>
Sat, 16 Oct 2010 19:57:57 +0000 (19:57 +0000)
committerMilan Straka <fox@ucw.cz>
Sat, 16 Oct 2010 19:57:57 +0000 (19:57 +0000)
As the benchmarking showed, it is not a good idea to create
closures in the worker/wrapper transformation, as the captured
arguments of the enclosing function have to be allocated on the
heap. It is better to explicitly pass the arguments on the stack.
This saves memory and add no time penalty if the arguments are
the first arguments of recursive function (GHC refrains from
needless copying).

The worker is often strict in some arguments. I did not want
to use BangPatterns, so I used macros to indicate strictness.
If majority thinks BangPatters are fine, I will gladly change it.

Data/IntMap.hs
Data/IntSet.hs
Data/Map.hs
Data/Set.hs

index 8e5a5b3..ee8b2b5 100644 (file)
@@ -198,6 +198,13 @@ import GlaExts ( Word(..), Int(..), shiftRL# )
 import Data.Word
 #endif
 
+-- Use macros to define strictness of functions.
+-- STRICTxy denotes an y-ary function strict in the x-th parameter.
+#define STRICT12(fn) fn arg _ | arg `seq` False = undefined
+#define STRICT13(fn) fn arg _ _ | arg `seq` False = undefined
+#define STRICT23(fn) fn _ arg _ | arg `seq` False = undefined
+#define STRICT24(fn) fn _ arg _ _ | arg `seq` False = undefined
+
 infixl 9 \\{-This comment teaches CPP correct behaviour -}
 
 -- A "Nat" is a natural machine word (an unsigned Int)
@@ -354,14 +361,15 @@ notMember k m = not $ member k m
 
 -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.
 lookup :: Key -> IntMap a -> Maybe a
-lookup k = k `seq` go
-  where go (Bin _ m l r)
-          | zero k m  = go l
-          | otherwise = go r
-        go (Tip kx x)
+lookup = go
+  where STRICT12(go)
+        go k (Bin _ m l r)
+          | zero k m  = go k l
+          | otherwise = go k r
+        go k (Tip kx x)
           | k == kx   = Just x
           | otherwise = Nothing
-        go Nil        = Nothing
+        go k Nil      = Nothing
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE lookup #-}
 #endif
@@ -431,15 +439,16 @@ singleton k x
 -- > insert 5 'x' empty                         == singleton 5 'x'
 
 insert :: Key -> a -> IntMap a -> IntMap a
-insert k x = k `seq` go
-  where go t@(Bin p m l r)
+insert = go
+  where STRICT13(go)
+        go k x t@(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)
-        go t@(Tip ky _)
+          | zero k m      = Bin p m (go k x l) r
+          | otherwise     = Bin p m l (go k x r)
+        go k x t@(Tip ky _)
           | k==ky         = Tip k x
           | otherwise     = join k (Tip k x) ky t
-        go Nil            = Tip k x
+        go k x Nil            = Tip k x
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE insert #-}
 #endif
@@ -474,18 +483,19 @@ 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 = k `seq` go
+insertWithKey = go
   where
-    go t@(Bin p m l r)
+    STRICT24(go)
+    go f k x t@(Bin p m l r)
         | nomatch k p m = join k (Tip k x) p t
-        | zero k m      = Bin p m (go l) r
-        | otherwise     = Bin p m l (go r)
+        | zero k m      = Bin p m (go f k x l) r
+        | otherwise     = Bin p m l (go f k x r)
 
-    go t@(Tip ky y)
+    go f k x t@(Tip ky y)
         | k==ky         = Tip k (f k x y)
         | otherwise     = join k (Tip k x) ky t
 
-    go Nil = Tip k x
+    go _ k x Nil = Tip k x
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE insertWithKey #-}
 #endif
@@ -507,18 +517,19 @@ insertWithKey f k x = k `seq` go
 -- > 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 = k `seq` go
+insertLookupWithKey = go
   where
-      go t@(Bin p m l r)
+      STRICT24(go)
+      go f k x t@(Bin p m l r)
         | nomatch k p m = (Nothing,join k (Tip k x) p t)
-        | zero k m      = case go l of (found, l') -> (found,Bin p m l' r)
-        | otherwise     = case go r of (found, r') -> (found,Bin p m l r')
+        | zero k m      = case go f k x l of (found, l') -> (found,Bin p m l' r)
+        | otherwise     = case go f k x r of (found, r') -> (found,Bin p m l r')
 
-      go t@(Tip ky y)
+      go f k x t@(Tip ky y)
         | k==ky         = (Just y,Tip k (f k x y))
         | otherwise     = (Nothing,join k (Tip k x) ky t)
 
-      go Nil = (Nothing,Tip k x)
+      go _ k x Nil = (Nothing,Tip k x)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE insertLookupWithKey #-}
 #endif
@@ -536,18 +547,19 @@ insertLookupWithKey f k x = k `seq` go
 -- > delete 5 empty                         == empty
 
 delete :: Key -> IntMap a -> IntMap a
-delete k = k `seq` go
+delete = go
   where
-      go t@(Bin p m l r)
+      STRICT12(go)
+      go k t@(Bin p m l r)
         | nomatch k p m = t
-        | zero k m      = bin p m (go l) r
-        | otherwise     = bin p m l (go r)
+        | zero k m      = bin p m (go l) r
+        | otherwise     = bin p m l (go r)
 
-      go t@(Tip ky _)
+      go t@(Tip ky _)
         | k==ky         = Nil
         | otherwise     = t
 
-      go Nil = Nil
+      go Nil = Nil
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE delete #-}
 #endif
@@ -607,20 +619,21 @@ 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 = k `seq` go
+updateWithKey = go
   where
-      go t@(Bin p m l r)
+      STRICT23(go)
+      go f k t@(Bin p m l r)
         | nomatch k p m = t
-        | zero k m      = bin p m (go l) r
-        | otherwise     = bin p m l (go r)
+        | zero k m      = bin p m (go f k l) r
+        | otherwise     = bin p m l (go f k r)
 
-      go t@(Tip ky y)
+      go f k t@(Tip ky y)
         | k==ky         = case f k y of
                              Just y' -> Tip ky y'
                              Nothing -> Nil
         | otherwise     = t
 
-      go Nil = Nil
+      go _ _ Nil = Nil
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateWithKey #-}
 #endif
@@ -636,20 +649,21 @@ updateWithKey f k = k `seq` go
 -- > 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 = k `seq` go
+updateLookupWithKey = go
   where
-      go t@(Bin p m l r)
+      STRICT23(go)
+      go f k t@(Bin p m l r)
         | nomatch k p m = (Nothing,t)
-        | zero k m      = case updateLookupWithKey f k l of (found, l') -> (found,bin p m l' r)
-        | otherwise     = case updateLookupWithKey f k r of (found, r') -> (found,bin p m l r')
+        | zero k m      = case go f k l of (found, l') -> (found,bin p m l' r)
+        | otherwise     = case go f k r of (found, r') -> (found,bin p m l r')
 
-      go t@(Tip ky y)
+      go 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)
 
-      go Nil = (Nothing,Nil)
+      go _ _ Nil = (Nothing,Nil)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateLookupWithKey #-}
 #endif
@@ -658,16 +672,17 @@ updateLookupWithKey f k = k `seq` go
 -- '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) -> Int -> IntMap a -> IntMap a
-alter f k = k `seq` go
+alter = go
   where 
-    go t@(Bin p m l r)
+    STRICT23(go)
+    go f k t@(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 (go l) r
-        | otherwise     = bin p m l (go r)
+        | zero k m      = bin p m (go f k l) r
+        | otherwise     = bin p m l (go f k r)
 
-    go t@(Tip ky y)         
+    go f k t@(Tip ky y)         
         | k==ky         = case f (Just y) of
                              Just x -> Tip ky x
                              Nothing -> Nil
@@ -676,7 +691,7 @@ alter f k = k `seq` go
                              Just x -> join k (Tip k x) ky t
                              Nothing -> Tip ky y
 
-    go Nil              = case f Nothing of
+    go f k Nil              = case f Nothing of
                              Just x -> Tip k x
                              Nothing -> Nil
 #if __GLASGOW_HASKELL__>= 700
@@ -957,22 +972,22 @@ intersectionWithKey _ _ Nil = Nil
 -- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
 
 updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMinWithKey = go
+updateMinWithKey = go
   where
-     go (Bin p m l r) | m < 0 = let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
-     go (Bin p m l r)         = let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
-     go (Tip k y) = Tip k (f k y)
-     go Nil       = error "maxView: empty map has no maximal element"
+     go (Bin p m l r) | m < 0 = let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
+     go (Bin p m l r)         = let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
+     go (Tip k y) = Tip k (f k y)
+     go Nil       = error "maxView: empty map has no maximal element"
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateMinWithKey #-}
 #endif
 
 updateMinWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMinWithKeyUnsigned = go
+updateMinWithKeyUnsigned = go
   where
-     go (Bin p m l r) = let t' = go l in Bin p m t' r
-     go (Tip k y)     = Tip k (f k y)
-     go Nil           = error "updateMinWithKeyUnsigned Nil"
+     go f (Bin p m l r) = let t' = go f l in Bin p m t' r
+     go (Tip k y)     = Tip k (f k y)
+     go Nil           = error "updateMinWithKeyUnsigned Nil"
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateMinWithKeyUnsigned #-}
 #endif
@@ -983,22 +998,22 @@ updateMinWithKeyUnsigned f = go
 -- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
 
 updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMaxWithKey = go
+updateMaxWithKey = go
   where
-    go (Bin p m l r) | m < 0 = let t' = updateMaxWithKeyUnsigned f l in Bin p m t' r
-    go (Bin p m l r)         = let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
-    go (Tip k y)        = Tip k (f k y)
-    go Nil              = error "maxView: empty map has no maximal element"
+    go (Bin p m l r) | m < 0 = let t' = updateMaxWithKeyUnsigned f l in Bin p m t' r
+    go (Bin p m l r)         = let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
+    go (Tip k y)        = Tip k (f k y)
+    go Nil              = error "maxView: empty map has no maximal element"
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateMaxWithKey #-}
 #endif
 
 updateMaxWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a
-updateMaxWithKeyUnsigned = go
+updateMaxWithKeyUnsigned = go
   where
-    go (Bin p m l r) = let t' = go r in Bin p m l t'
-    go (Tip k y)     = Tip k (f k y)
-    go Nil           = error "updateMaxWithKeyUnsigned Nil"
+    go f (Bin p m l r) = let t' = go f r in Bin p m l t'
+    go (Tip k y)     = Tip k (f k y)
+    go Nil           = error "updateMaxWithKeyUnsigned Nil"
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateMaxWithKeyUnsigned #-}
 #endif
@@ -1289,11 +1304,11 @@ map f = mapWithKey (\_ x -> f x)
 -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
 
 mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
-mapWithKey = go
+mapWithKey = go
   where
-   go (Bin p m l r) = Bin p m (go l) (go r)
-   go (Tip k x)     = Tip k (f k x)
-   go Nil           = Nil
+   go f (Bin p m l r) = Bin p m (go f l) (go f r)
+   go (Tip k x)     = Tip k (f k x)
+   go Nil           = Nil
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE mapWithKey #-}
 #endif
@@ -1372,13 +1387,13 @@ filter p m
 -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
 
 filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
-filterWithKey = go
+filterWithKey = go
   where
-    go (Bin pr m l r) = bin pr m (go l) (go r)
-    go t@(Tip k x)
+    go p (Bin pr m l r) = bin pr m (go p l) (go p r)
+    go t@(Tip k x)
         | p k x      = t
         | otherwise  = Nil
-    go Nil = Nil
+    go Nil = Nil
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE filterWithKey #-}
 #endif
@@ -1438,13 +1453,13 @@ mapMaybe f = mapMaybeWithKey (\_ x -> f x)
 -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
 
 mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b
-mapMaybeWithKey = go
+mapMaybeWithKey = go
   where
-    go (Bin p m l r) = bin p m (go l) (go r)
-    go (Tip k x)     = case f k x of
+    go f (Bin p m l r) = bin p m (go f l) (go f r)
+    go (Tip k x)     = case f k x of
                           Just y  -> Tip k y
                           Nothing -> Nil
-    go Nil = Nil
+    go Nil = Nil
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE mapMaybeWithKey #-}
 #endif
@@ -1619,11 +1634,11 @@ foldr f z t
 #endif
 
 foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldr' = go
+foldr' = go
   where
-    go z (Bin _ _ l r) = go (go z r) l
-    go z (Tip k x)     = f k x z
-    go z Nil           = z
+    go f z (Bin _ _ l r) = go f (go f z r) l
+    go z (Tip k x)     = f k x z
+    go z Nil           = z
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldr' #-}
 #endif
@@ -2139,10 +2154,11 @@ highestBitMask x0
 --------------------------------------------------------------------}
 
 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict = go
+foldlStrict = go
   where
-    go z []     = z
-    go z (x:xs) = z `seq` go (f z x) xs
+    STRICT23(go)
+    go f z []     = z
+    go f z (x:xs) = go f (f z x) xs
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldlStrict #-}
 #endif
index 426dc9a..c67b9b2 100644 (file)
@@ -132,6 +132,11 @@ import GlaExts ( Word(..), Int(..), shiftRL# )
 import Data.Word
 #endif
 
+-- Use macros to define strictness of functions.
+-- STRICTxy denotes an y-ary function strict in the x-th parameter.
+#define STRICT12(fn) fn arg _ | arg `seq` False = undefined
+#define STRICT23(fn) fn _ arg _ | arg `seq` False = undefined
+
 infixl 9 \\{-This comment teaches CPP correct behaviour -}
 
 -- A "Nat" is a natural machine word (an unsigned Int)
@@ -238,13 +243,14 @@ size t
 
 -- | /O(min(n,W))/. Is the value a member of the set?
 member :: Int -> IntSet -> Bool
-member x Nil = x `seq` False
-member x t = x `seq` go t
-  where go (Bin p m l r)
+member = go
+  where STRICT12(go)
+        go x (Bin p m l r)
           | nomatch x p m = False
-          | zero x m      = go l
-          | otherwise     = go r
-        go (Tip y) = x == y
+          | zero x m      = go x l
+          | otherwise     = go x r
+        go x (Tip y) = x == y
+        go _ Nil = False
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE member #-}
 #endif
@@ -258,14 +264,15 @@ notMember k = not . member k
 
 -- 'lookup' is used by 'intersection' for left-biasing
 lookup :: Int -> IntSet -> Maybe Int
-lookup k Nil = k `seq` Nothing
-lookup k t = k `seq` go t
-  where go (Bin _ m l r)
-          | zero k m  = go l
-          | otherwise = go r
-        go (Tip kx)
+lookup = go
+  where STRICT12(go)
+        go k (Bin _ m l r)
+          | zero k m  = go l
+          | otherwise = go r
+        go (Tip kx)
           | k == kx   = Just kx
           | otherwise = Nothing
+        go _ Nil = Nothing
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE lookup #-}
 #endif
@@ -296,30 +303,32 @@ singleton x
 -- an element of the set, it is replaced by the new one, ie. 'insert'
 -- is left-biased.
 insert :: Int -> IntSet -> IntSet
-insert x = x `seq` go
-  where go t@(Bin p m l r )
+insert = go
+  where STRICT12(go)
+        go x t@(Bin p m l r )
           | nomatch x p m = join x (Tip x) p t
-          | zero x m      = Bin p m (go l) r
-          | otherwise     = Bin p m l (go r)
-        go t@(Tip y)
+          | zero x m      = Bin p m (go l) r
+          | otherwise     = Bin p m l (go r)
+        go t@(Tip y)
           | x==y          = Tip x
           | otherwise     = join x (Tip x) y t
-        go Nil            = Tip x
+        go Nil            = Tip x
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE insert #-}
 #endif
 
 -- right-biased insertion, used by 'union'
 insertR :: Int -> IntSet -> IntSet
-insertR x = x `seq` go
-  where go t@(Bin p m l r )
+insertR = go
+  where STRICT12(go)
+        go x t@(Bin p m l r )
           | nomatch x p m = join x (Tip x) p t
-          | zero x m      = Bin p m (go l) r
-          | otherwise     = Bin p m l (go r)
-        go t@(Tip y)
+          | zero x m      = Bin p m (go l) r
+          | otherwise     = Bin p m l (go r)
+        go t@(Tip y)
           | x==y          = t
           | otherwise     = join x (Tip x) y t
-        go Nil            = Tip x
+        go Nil            = Tip x
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE insertR #-}
 #endif
@@ -327,15 +336,16 @@ insertR x = x `seq` go
 -- | /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 x = x `seq` go
-  where go t@(Bin p m l r)
+delete = go
+  where STRICT12(go)
+        go x t@(Bin p m l r)
           | nomatch x p m = t
-          | zero x m      = bin p m (go l) r
-          | otherwise     = bin p m l (go r)
-        go t@(Tip y)
+          | zero x m      = bin p m (go l) r
+          | otherwise     = bin p m l (go r)
+        go t@(Tip y)
           | x==y          = Nil
           | otherwise     = t
-        go t@Nil          = t
+        go t@Nil          = t
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE delete #-}
 #endif
@@ -1146,10 +1156,11 @@ highestBitMask x0
   Utilities 
 --------------------------------------------------------------------}
 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict f z xs
-  = case xs of
-      []     -> z
-      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
+foldlStrict = go
+  where
+    STRICT23(go)
+    go f z []     = z
+    go f z (x:xs) = go f (f z x) xs
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldlStrict #-}
 #endif
index 5f64bb7..cf4372c 100644 (file)
@@ -208,6 +208,13 @@ import Text.Read
 import Data.Data (Data(..), mkNoRepType, gcast2)
 #endif
 
+-- Use macros to define strictness of functions.
+-- STRICTxy denotes an y-ary function strict in the x-th parameter.
+#define STRICT12(fn) fn arg _ | arg `seq` False = undefined
+#define STRICT13(fn) fn arg _ _ | arg `seq` False = undefined
+#define STRICT23(fn) fn _ arg _ | arg `seq` False = undefined
+#define STRICT24(fn) fn _ arg _ _ | arg `seq` False = undefined
+
 {--------------------------------------------------------------------
   Operators
 --------------------------------------------------------------------}
@@ -323,24 +330,26 @@ size (Bin sz _ _ _ _) = sz
 -- >   Pete's currency: Nothing
 
 lookup :: Ord k => k -> Map k a -> Maybe a
-lookup k = k `seq` go
+lookup = go
   where
-    go Tip = Nothing
-    go (Bin _ kx x l r) =
+    STRICT12(go)
+    go k Tip = Nothing
+    go k (Bin _ kx x l r) =
         case compare k kx of
-            LT -> go l
-            GT -> go r
+            LT -> go l
+            GT -> go r
             EQ -> Just x
 {-# INLINE lookup #-}
 
 lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
-lookupAssoc k = k `seq` go
+lookupAssoc = go
   where
-    go Tip = Nothing
-    go (Bin _ kx x l r) =
+    STRICT12(go)
+    go k Tip = Nothing
+    go k (Bin _ kx x l r) =
         case compare k kx of
-            LT -> go l
-            GT -> go r
+            LT -> go l
+            GT -> go r
             EQ -> Just (kx,x)
 {-# INLINE lookupAssoc #-}
 
@@ -428,13 +437,14 @@ singleton k x = Bin 1 k x Tip Tip
 -- > insert 5 'x' empty                         == singleton 5 'x'
 
 insert :: Ord k => k -> a -> Map k a -> Map k a
-insert kx x = kx `seq` go
+insert = go
   where
-    go Tip = singleton kx x
-    go (Bin sz ky y l r) =
+    STRICT13(go)
+    go kx x Tip = singleton kx x
+    go kx x (Bin sz ky y l r) =
         case compare kx ky of
-            LT -> balanceL ky y (go l) r
-            GT -> balanceR ky y l (go r)
+            LT -> balanceL ky y (go kx x l) r
+            GT -> balanceR ky y l (go kx x r)
             EQ -> Bin sz kx x l r
 {-# INLINE insert #-}
 
@@ -476,26 +486,28 @@ insertWith' f = insertWithKey' (\_ x' y' -> f x' y')
 -- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"
 
 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey f kx x = kx `seq` go
+insertWithKey = go
   where
-    go Tip = singleton kx x
-    go (Bin sy ky y l r) =
+    STRICT24(go)
+    go f kx x Tip = singleton kx x
+    go f kx x (Bin sy ky y l r) =
         case compare kx ky of
-            LT -> balanceL ky y (go l) r
-            GT -> balanceR ky y l (go r)
+            LT -> balanceL ky y (go f kx x l) r
+            GT -> balanceR ky y l (go f kx x r)
             EQ -> Bin sy kx (f kx x y) l r
 {-# INLINE insertWithKey #-}
 
 -- | Same as 'insertWithKey', but the combining function is applied strictly.
 insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
-insertWithKey' f kx x = kx `seq` go
+insertWithKey' = go
   where
-    go Tip = singleton kx $! x
-    go (Bin sy ky y l r) =
+    STRICT24(go)
+    go f kx x Tip = x `seq` singleton kx x
+    go f kx x (Bin sy ky y l r) =
         case compare kx ky of
-            LT -> balanceL ky y (go l) r
-            GT -> balanceR ky y l (go r)
-            EQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r)
+            LT -> balanceL ky y (go f kx x l) r
+            GT -> balanceR ky y l (go f kx x r)
+            EQ -> let x' = f kx x y in x' `seq` (Bin sy kx x' l r)
 {-# INLINE insertWithKey' #-}
 
 -- | /O(log n)/. Combines insert operation with old value retrieval.
@@ -516,14 +528,15 @@ insertWithKey' f kx x = kx `seq` go
 
 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
                     -> (Maybe a, Map k a)
-insertLookupWithKey f kx x = kx `seq` go
+insertLookupWithKey = go
   where
-    go Tip = (Nothing, singleton kx x)
-    go (Bin sy ky y l r) =
+    STRICT24(go)
+    go f 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 l
+            LT -> let (found, l') = go f kx x l
                   in (found, balanceL ky y l' r)
-            GT -> let (found, r') = go r
+            GT -> let (found, r') = go f kx x r
                   in (found, balanceR ky y l r')
             EQ -> (Just y, Bin sy kx (f kx x y) l r)
 {-# INLINE insertLookupWithKey #-}
@@ -531,14 +544,15 @@ insertLookupWithKey f kx x = kx `seq` go
 -- | /O(log n)/. A strict version of 'insertLookupWithKey'.
 insertLookupWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
                      -> (Maybe a, Map k a)
-insertLookupWithKey' f kx x = kx `seq` go
+insertLookupWithKey' = go
   where
-    go Tip = x `seq` (Nothing, singleton kx x)
-    go (Bin sy ky y l r) =
+    STRICT24(go)
+    go f kx x Tip = x `seq` (Nothing, singleton kx x)
+    go f kx x (Bin sy ky y l r) =
         case compare kx ky of
-            LT -> let (found, l') = go l
+            LT -> let (found, l') = go f kx x l
                   in (found, balanceL ky y l' r)
-            GT -> let (found, r') = go 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, Bin sy kx x' l r)
 {-# INLINE insertLookupWithKey' #-}
@@ -555,13 +569,14 @@ insertLookupWithKey' f kx x = kx `seq` go
 -- > delete 5 empty                         == empty
 
 delete :: Ord k => k -> Map k a -> Map k a
-delete k = k `seq` go
+delete = go
   where
-    go Tip = Tip
-    go (Bin _ kx x l r) =
+    STRICT12(go)
+    go k Tip = Tip
+    go k (Bin _ kx x l r) =
         case compare k kx of
-            LT -> balanceR kx x (go l) r
-            GT -> balanceL kx x l (go r)
+            LT -> balanceR kx x (go l) r
+            GT -> balanceL kx x l (go r)
             EQ -> glue l r
 {-# INLINE delete #-}
 
@@ -613,13 +628,14 @@ update f = updateWithKey (\_ x -> f x)
 -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
 
 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
-updateWithKey f k = k `seq` go
+updateWithKey = go
   where
-    go Tip = Tip
-    go (Bin sx kx x l r) =
+    STRICT23(go)
+    go f k Tip = Tip
+    go f k(Bin sx kx x l r) =
         case compare k kx of
-           LT -> balanceR kx x (go l) r
-           GT -> balanceL kx x l (go r)
+           LT -> balanceR kx x (go f k l) r
+           GT -> balanceL kx x l (go f k r)
            EQ -> case f kx x of
                    Just x' -> Bin sx kx x' l r
                    Nothing -> glue l r
@@ -635,13 +651,14 @@ updateWithKey f k = k `seq` go
 -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
 
 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
-updateLookupWithKey f k = k `seq` go
+updateLookupWithKey = go
  where
-   go Tip = (Nothing,Tip)
-   go (Bin sx kx x l r) =
+   STRICT23(go)
+   go f k Tip = (Nothing,Tip)
+   go f k (Bin sx kx x l r) =
           case compare k kx of
-               LT -> let (found,l') = go l in (found,balanceR kx x l' r)
-               GT -> let (found,r') = go r in (found,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' -> (Just x',Bin sx kx x' l r)
                        Nothing -> (Just x,glue l r)
@@ -660,15 +677,16 @@ updateLookupWithKey f k = k `seq` go
 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
 
 alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
-alter f k = k `seq` go
+alter = go
   where
-    go Tip = case f Nothing of
+    STRICT23(go)
+    go f k Tip = case f Nothing of
                Nothing -> Tip
                Just x  -> singleton k x
 
-    go (Bin sx kx x l r) = case compare k kx of
-               LT -> balance kx x (go l) r
-               GT -> balance kx x l (go r)
+    go f k (Bin sx kx x l r) = case compare k kx of
+               LT -> balance kx x (go f k l) r
+               GT -> balance kx x l (go f k r)
                EQ -> case f (Just x) of
                        Just x' -> Bin sx kx x' l r
                        Nothing -> glue l r
@@ -704,13 +722,15 @@ findIndex k t
 -- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")]))   == False
 
 lookupIndex :: Ord k => k -> Map k a -> Maybe Int
-lookupIndex k = k `seq` go 0
+lookupIndex k = go k 0
   where
-    go idx Tip  = idx `seq` Nothing
-    go idx (Bin _ kx _ l r)
-      = idx `seq` case compare k kx of
-          LT -> go idx l
-          GT -> go (idx + size l + 1) r 
+    STRICT13(go)
+    STRICT23(go)
+    go k idx Tip  = Nothing
+    go k idx (Bin _ kx _ l r)
+      = case compare k kx of
+          LT -> go k idx l
+          GT -> go k (idx + size l + 1) r 
           EQ -> Just (idx + size l)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE lookupIndex #-}
@@ -724,6 +744,7 @@ lookupIndex k = k `seq` go 0
 -- > elemAt 2 (fromList [(5,"a"), (3,"b")])    Error: index out of range
 
 elemAt :: Int -> Map k a -> (k,a)
+STRICT12(elemAt)
 elemAt _ Tip = error "Map.elemAt: index out of range"
 elemAt i (Bin _ kx x l r)
   = case compare i sizeL of
@@ -749,12 +770,13 @@ elemAt i (Bin _ kx x l r)
 -- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range
 
 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
-updateAt f i0 t = i0 `seq` go i0 t
+updateAt = go
  where
-    go _ Tip  = error "Map.updateAt: index out of range"
-    go i (Bin sx kx x l r) = case compare i sizeL of
-      LT -> balanceR kx x (go i l) r
-      GT -> balanceL kx x l (go (i-sizeL-1) r)
+    STRICT23(go)
+    go f _ Tip  = error "Map.updateAt: index out of range"
+    go f i (Bin sx kx x l r) = case compare i sizeL of
+      LT -> balanceR kx x (go f i l) r
+      GT -> balanceL kx x l (go f (i-sizeL-1) r)
       EQ -> case f kx x of
               Just x' -> Bin sx kx x' l r
               Nothing -> glue l r
@@ -866,13 +888,13 @@ updateMax f m
 -- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
 
 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMinWithKey = go
+updateMinWithKey = go
  where
-    go (Bin sx kx x Tip r) = case f kx x of
+    go (Bin sx kx x Tip r) = case f kx x of
                                   Nothing -> r
                                   Just x' -> Bin sx kx x' Tip r
-    go (Bin _ kx x l r)    = balanceR kx x (go l) r
-    go Tip                 = Tip
+    go f (Bin _ kx x l r)    = balanceR kx x (go f l) r
+    go Tip                 = Tip
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateMinWithKey #-}
 #endif
@@ -883,13 +905,13 @@ updateMinWithKey f = go
 -- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
 
 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
-updateMaxWithKey = go
+updateMaxWithKey = go
  where
-    go (Bin sx kx x l Tip) = case f kx x of
+    go (Bin sx kx x l Tip) = case f kx x of
                               Nothing -> l
                               Just x' -> Bin sx kx x' l Tip
-    go (Bin _ kx x l r)    = balanceL kx x l (go r)
-    go Tip                 = Tip
+    go f (Bin _ kx x l r)    = balanceL kx x l (go f r)
+    go Tip                 = Tip
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE updateMaxWithKey #-}
 #endif
@@ -1332,12 +1354,12 @@ filter p m
 -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
 
 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
-filterWithKey = go
+filterWithKey = go
   where
-    go Tip = Tip
-    go (Bin _ kx x l r)
-          | p kx x    = join kx x (go l) (go r)
-          | otherwise = merge (go l) (go r)
+    go Tip = Tip
+    go (Bin _ kx x l r)
+          | p kx x    = join kx x (go p l) (go p r)
+          | otherwise = merge (go p l) (go p r)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE filterWithKey #-}
 #endif
@@ -1394,12 +1416,12 @@ mapMaybe f = mapMaybeWithKey (\_ x -> f x)
 -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
 
 mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b
-mapMaybeWithKey = go
+mapMaybeWithKey = go
   where
-    go Tip = Tip
-    go (Bin _ kx x l r) = case f kx x of
-        Just y  -> join kx y (go l) (go r)
-        Nothing -> merge (go l) (go r)
+    go Tip = Tip
+    go (Bin _ kx x l r) = case f kx x of
+        Just y  -> join kx y (go f l) (go f r)
+        Nothing -> merge (go f l) (go f r)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE mapMaybeWithKey #-}
 #endif
@@ -1461,10 +1483,10 @@ map f = mapWithKey (\_ x -> f x)
 -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
 
 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
-mapWithKey = go
+mapWithKey = go
   where
-    go Tip = Tip
-    go (Bin sx kx x l r) = Bin sx kx (f kx x) (go l) (go r)
+    go Tip = Tip
+    go f (Bin sx kx x l r) = Bin sx kx (f kx x) (go f l) (go f r)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE mapWithKey #-}
 #endif
@@ -1498,13 +1520,13 @@ mapAccumWithKey f a t
 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
 -- argument throught the map in ascending order of keys.
 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumL = go
+mapAccumL = go
   where
-    go a Tip               = (a,Tip)
-    go a (Bin sx kx x l r) =
-                 let (a1,l') = go a l
+    go a Tip               = (a,Tip)
+    go a (Bin sx kx x l r) =
+                 let (a1,l') = go a l
                      (a2,x') = f a1 kx x
-                     (a3,r') = go a2 r
+                     (a3,r') = go a2 r
                  in (a3,Bin sx kx x' l' r')
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE mapAccumL #-}
@@ -1513,13 +1535,13 @@ mapAccumL f = go
 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
 -- argument through the map in descending order of keys.
 mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
-mapAccumRWithKey = go
+mapAccumRWithKey = go
   where
-    go a Tip = (a,Tip)
-    go a (Bin sx kx x l r) =
-                 let (a1,r') = go a r
+    go a Tip = (a,Tip)
+    go a (Bin sx kx x l r) =
+                 let (a1,r') = go a r
                      (a2,x') = f a1 kx x
-                     (a3,l') = go a2 l
+                     (a3,l') = go a2 l
                  in (a3,Bin sx kx x' l' r')
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE mapAccumRWithKey #-}
@@ -1625,10 +1647,10 @@ foldWithKey = foldrWithKey
 -- | /O(n)/. Post-order fold.  The function will be applied from the lowest
 -- value to the highest.
 foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
-foldrWithKey = go
+foldrWithKey = go
   where
-    go z Tip              = z
-    go z (Bin _ kx x l r) = go (f kx x (go z r)) l
+    go z Tip              = z
+    go f z (Bin _ kx x l r) = go f (f kx x (go f z r)) l
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldrWithKey #-}
 #endif
@@ -1636,10 +1658,10 @@ foldrWithKey f = go
 -- | /O(n)/. Pre-order fold.  The function will be applied from the highest
 -- value to the lowest.
 foldlWithKey :: (b -> k -> a -> b) -> b -> Map k a -> b
-foldlWithKey = go
+foldlWithKey = go
   where
-    go z Tip              = z
-    go z (Bin _ kx x l r) = go (f (go z l) kx x) r
+    go z Tip              = z
+    go f z (Bin _ kx x l r) = go f (f (go f z l) kx x) r
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldlWithKey #-}
 #endif
@@ -1906,13 +1928,13 @@ data MaybeS a = NothingS | JustS !a
 --------------------------------------------------------------------}
 trim :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k a
 trim NothingS   NothingS   t = t
-trim (JustS lo) NothingS   t = greater t where greater (Bin _ k _ _ r) | k <= lo = greater r
-                                               greater t' = t'
-trim NothingS   (JustS hi) t = lesser t  where lesser  (Bin _ k _ l _) | k >= hi = lesser  l
-                                               lesser  t' = t'
-trim (JustS lo) (JustS hi) t = middle t  where middle  (Bin _ k _ _ r) | k <= lo = middle  r
-                                               middle  (Bin _ k _ l _) | k >= hi = middle  l
-                                               middle  t' = t'
+trim (JustS lo) NothingS   t = greater lo t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r
+                                                  greater lo t' = t'
+trim NothingS   (JustS hi) t = lesser hi t  where lesser  hi (Bin _ k _ l _) | k >= hi = lesser  hi l
+                                                  lesser  hi t' = t'
+trim (JustS lo) (JustS hi) t = middle lo hi t  where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r
+                                                     middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l
+                                                     middle lo hi t' = t'
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE trim #-}
 #endif
@@ -1939,22 +1961,22 @@ trimLookupLo lo hi t@(Bin _ kx x l r)
 --------------------------------------------------------------------}
 filterGt :: Ord k => MaybeS k -> Map k v -> Map k v
 filterGt NothingS t = t
-filterGt (JustS b) t = filter' t
-  where filter' Tip = Tip
-        filter' (Bin _ kx x l r) = case compare b kx of LT -> join kx x (filter' l) r
-                                                        EQ -> r
-                                                        GT -> filter' r
+filterGt (JustS b) t = filter' t
+  where filter' Tip = Tip
+        filter' b (Bin _ kx x l r) = case compare b kx of LT -> join kx x (filter' b l) r
+                                                          EQ -> r
+                                                          GT -> filter' b r
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE filterGt #-}
 #endif
 
 filterLt :: Ord k => MaybeS k -> Map k v -> Map k v
 filterLt NothingS t = t
-filterLt (JustS b) t = filter' t
-  where filter' Tip = Tip
-        filter' (Bin _ kx x l r) = case compare kx b of LT -> join kx x l (filter' r)
-                                                        EQ -> l
-                                                        GT -> filter' l
+filterLt (JustS b) t = filter' t
+  where filter' Tip = Tip
+        filter' b (Bin _ kx x l r) = case compare kx b of LT -> join kx x l (filter' b r)
+                                                          EQ -> l
+                                                          GT -> filter' b l
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE filterLt #-}
 #endif
@@ -1973,12 +1995,13 @@ filterLt (JustS b) t = filter' t
 -- > 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 = go
+split = go
   where
-    go Tip              = (Tip, Tip)
-    go (Bin _ kx x l r) = case compare k kx of
-          LT -> let (lt,gt) = go l in (lt,join kx x gt r)
-          GT -> let (lt,gt) = go r in (join kx x l lt,gt)
+    STRICT12(go)
+    go k Tip              = (Tip, Tip)
+    go k (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 #-}
@@ -1994,12 +2017,13 @@ split k = go
 -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
 
 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
-splitLookup = go
+splitLookup = go
   where
-    go Tip              = (Tip,Nothing,Tip)
-    go (Bin _ kx x l r) = case compare k kx of
-      LT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)
-      GT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt)
+    STRICT12(go)
+    go k Tip              = (Tip,Nothing,Tip)
+    go k (Bin _ kx x l r) = case compare k kx of
+      LT -> let (lt,z,gt) = go k l in (lt,z,join kx x gt r)
+      GT -> let (lt,z,gt) = go k r in (join kx x l lt,z,gt)
       EQ -> (l,Just x,r)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE splitLookup #-}
@@ -2007,12 +2031,13 @@ splitLookup k = go
 
 -- | /O(log n)/.
 splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
-splitLookupWithKey = go
+splitLookupWithKey = go
   where
-    go Tip              = (Tip,Nothing,Tip)
-    go (Bin _ kx x l r) = case compare k kx of
-      LT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)
-      GT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt)
+    STRICT12(go)
+    go k Tip              = (Tip,Nothing,Tip)
+    go k (Bin _ kx x l r) = case compare k kx of
+      LT -> let (lt,z,gt) = go k l in (lt,z,join kx x gt r)
+      GT -> let (lt,z,gt) = go k r in (join kx x l lt,z,gt)
       EQ -> (l,Just (kx, x),r)
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE splitLookupWithKey #-}
@@ -2510,10 +2535,11 @@ validsize t
   Utilities
 --------------------------------------------------------------------}
 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict = go
+foldlStrict = go
   where
-    go z []     = z
-    go z (x:xs) = z `seq` go (f z x) xs
+    STRICT23(go)
+    go f z []     = z
+    go f z (x:xs) = go f (f z x) xs
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldlStrict #-}
 #endif
index c6b347c..ef2c720 100644 (file)
@@ -135,6 +135,11 @@ import Text.Read
 import Data.Data (Data(..), mkNoRepType, gcast1)
 #endif
 
+-- Use macros to define strictness of functions.
+-- STRICTxy denotes an y-ary function strict in the x-th parameter.
+#define STRICT12(fn) fn arg _ | arg `seq` False = undefined
+#define STRICT23(fn) fn _ arg _ | arg `seq` False = undefined
+
 {--------------------------------------------------------------------
   Operators
 --------------------------------------------------------------------}
@@ -206,15 +211,16 @@ size = go
 
 -- | /O(log n)/. Is the element in the set?
 member :: Ord a => a -> Set a -> Bool
-member x = x `seq` go
+member = go
   where
-    go Tip = False
-    go (Bin _ y l r) = case compare x y of
-        LT -> go l
-        GT -> go r
-        EQ -> True       
+    STRICT12(go)
+    go x Tip = False
+    go x (Bin _ y l r) = case compare x y of
+          LT -> go x l
+          GT -> go x r
+          EQ -> True
 {-# INLINE member #-}
-        
+
 -- | /O(log n)/. Is the element not in the set?
 notMember :: Ord a => a -> Set a -> Bool
 notMember a t = not $ member a t
@@ -244,35 +250,38 @@ singleton x = Bin 1 x Tip Tip
 -- If the set already contains an element equal to the given value,
 -- it is replaced with the new value.
 insert :: Ord a => a -> Set a -> Set a
-insert x = x `seq` go
+insert = go
   where
-    go Tip = singleton x
-    go (Bin sz y l r) = case compare x y of
-        LT -> balanceL y (go l) r
-        GT -> balanceR y l (go r)
+    STRICT12(go)
+    go x Tip = singleton x
+    go x (Bin sz y l r) = case compare x y of
+        LT -> balanceL y (go x l) r
+        GT -> balanceR y l (go x r)
         EQ -> Bin sz x l r
 {-# INLINE insert #-}
 
 -- Insert an element to the set only if it is not in the set. Used by
 -- `union`.
 insertR :: Ord a => a -> Set a -> Set a
-insertR x = x `seq` go
+insertR = go
   where
-    go Tip = singleton x
-    go t@(Bin _ y l r) = case compare x y of
-        LT -> balanceL y (go l) r
-        GT -> balanceR y l (go r)
+    STRICT12(go)
+    go x Tip = singleton x
+    go x t@(Bin _ y l r) = case compare x y of
+        LT -> balanceL y (go x l) r
+        GT -> balanceR y l (go x r)
         EQ -> t
 {-# INLINE insertR #-}
 
 -- | /O(log n)/. Delete an element from a set.
 delete :: Ord a => a -> Set a -> Set a
-delete x = x `seq` go
+delete = go
   where
-    go Tip = Tip
-    go (Bin _ y l r) = case compare x y of
-        LT -> balanceR y (go l) r
-        GT -> balanceL y l (go r)
+    STRICT12(go)
+    go x Tip = Tip
+    go x (Bin _ y l r) = case compare x y of
+        LT -> balanceR y (go x l) r
+        GT -> balanceL y l (go x r)
         EQ -> glue l r
 {-# INLINE delete #-}
 
@@ -526,10 +535,10 @@ fold = foldr
 
 -- | /O(n)/. Post-order fold.
 foldr :: (a -> b -> b) -> b -> Set a -> b
-foldr = go
+foldr = go
   where
-    go z Tip           = z
-    go z (Bin _ x l r) = go (f x (go z r)) l
+    go z Tip           = z
+    go f z (Bin _ x l r) = go f (f x (go f z r)) l
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldr #-}
 #endif
@@ -697,13 +706,13 @@ data MaybeS a = NothingS | JustS !a
 --------------------------------------------------------------------}
 trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a
 trim NothingS   NothingS   t = t
-trim (JustS lx) NothingS   t = greater t where greater (Bin _ x _ r) | x <= lx = greater r
-                                               greater t' = t'
-trim NothingS   (JustS hx) t = lesser t  where lesser  (Bin _ x l _) | x >= hx = lesser  l
-                                               lesser  t' = t'
-trim (JustS lx) (JustS hx) t = middle t  where middle  (Bin _ x _ r) | x <= lx = middle  r
-                                               middle  (Bin _ x l _) | x >= hx = middle  l
-                                               middle  t' = t'
+trim (JustS lx) NothingS   t = greater lx t where greater lx (Bin _ x _ r) | x <= lx = greater lx r
+                                                  greater _  t' = t'
+trim NothingS   (JustS hx) t = lesser hx t  where lesser  hx (Bin _ x l _) | x >= hx = lesser  hx l
+                                                  lesser  _  t' = t'
+trim (JustS lx) (JustS hx) t = middle lx hx t  where middle lx hx (Bin _ x _ r) | x <= lx = middle lx hx r
+                                                     middle lx hx (Bin _ x l _) | x >= hx = middle lx hx l
+                                                     middle _  _  t' = t'
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE trim #-}
 #endif
@@ -714,22 +723,22 @@ trim (JustS lx) (JustS hx) t = middle t  where middle  (Bin _ x _ r) | x <= lx =
 --------------------------------------------------------------------}
 filterGt :: Ord a => MaybeS a -> Set a -> Set a
 filterGt NothingS t = t
-filterGt (JustS b) t = filter' t
-  where filter' Tip = Tip
-        filter' (Bin _ x l r) = case compare b x of LT -> join x (filter' l) r
-                                                    EQ -> r
-                                                    GT -> filter' r
+filterGt (JustS b) t = filter' t
+  where filter' Tip = Tip
+        filter' b (Bin _ x l r) = case compare b x of LT -> join x (filter' b l) r
+                                                      EQ -> r
+                                                      GT -> filter' b r
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE filterGt #-}
 #endif
 
 filterLt :: Ord a => MaybeS a -> Set a -> Set a
 filterLt NothingS t = t
-filterLt (JustS b) t = filter' t
-  where filter' Tip = Tip
-        filter' (Bin _ x l r) = case compare x b of LT -> join x l (filter' r)
-                                                    EQ -> l
-                                                    GT -> filter' l
+filterLt (JustS b) t = filter' t
+  where filter' Tip = Tip
+        filter' b (Bin _ x l r) = case compare x b of LT -> join x l (filter' b r)
+                                                      EQ -> l
+                                                      GT -> filter' b l
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE filterLt #-}
 #endif
@@ -1050,10 +1059,11 @@ bin x l r
   Utilities
 --------------------------------------------------------------------}
 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict = go
+foldlStrict = go
   where
-    go z []     = z
-    go z (x:xs) = z `seq` go (f z x) xs
+    STRICT23(go)
+    go f z []     = z
+    go f z (x:xs) = go f (f z x) xs
 #if __GLASGOW_HASKELL__>= 700
 {-# INLINABLE foldlStrict #-}
 #endif