author David Feuer Sun, 4 Sep 2016 07:28:39 +0000 (03:28 -0400) committer David Feuer Sun, 4 Sep 2016 07:53:29 +0000 (03:53 -0400)
* `Data.Map.fromDistinctAscList` and `fromDistinctDescList`
were accumulating thunks for no good reason. Make them
build their structures eagerly. This cuts time by a good
bit (a third, maybe).

* Make the same functions in `Data.Set` just a tad more eager
as well.

index a3bc550..0b8202f 100644 (file)
@@ -3431,15 +3431,16 @@ fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
where
go !_ t [] = t
go s l ((kx, x) : xs) = case create s xs of
-                              (r, ys) -> go (s `shiftL` 1) (link kx x l r) ys
+                                (r :*: ys) -> let !t' = link kx x l r
+                                              in go (s `shiftL` 1) t' ys

-    create !_ [] = (Tip, [])
+    create !_ [] = (Tip :*: [])
create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, 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) -> (link ky y l r, zs)
+                      res@(_ :*: []) -> res
+                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (r :*: zs) -> (link ky y l r :*: zs)

-- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
-- /The precondition is not checked./
@@ -3456,15 +3457,16 @@ fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs
where
go !_ t [] = t
go s r ((kx, x) : xs) = case create s xs of
-                               (l, ys) -> go (s `shiftL` 1) (link kx x l r) ys
+                               (l :*: ys) -> let !t' = link kx x l r
+                                             in go (s `shiftL` 1) t' ys

-     create !_ [] = (Tip, [])
+     create !_ [] = (Tip :*: [])
create s xs@(x' : xs')
-       | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, 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
-                       (r, (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                         (l, zs) -> (link ky y l r, zs)
+                       res@(_ :*: []) -> res
+                       (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                         (l :*: zs) -> (link ky y l r :*: zs)

{-
-- Functions very similar to these were used to implement
index 5ed14b3..c8882a0 100644 (file)
@@ -1670,16 +1670,18 @@ fromDistinctAscList [] = Tip
fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
where
go !_ t [] = t
-    go s l ((kx, x) : xs) = case create s xs of
-                              (r, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys
+    go s l ((kx, x) : xs) =
+      case create s xs of
+        (r :*: ys) -> x `seq` let !t' = link kx x l r
+                           in go (s `shiftL` 1) t' ys

-    create !_ [] = (Tip, [])
+    create !_ [] = (Tip :*: [])
create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, 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` (link ky y l r, zs)
+                      res@(_ :*: []) -> res
+                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (r :*: zs) -> y `seq` (link ky y l r :*: zs)

-- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
-- /The precondition is not checked./
@@ -1695,13 +1697,15 @@ fromDistinctDescList [] = Tip
fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
where
go !_ t [] = t
-    go s r ((kx, x) : xs) = case create s xs of
-                              (l, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys
+    go s r ((kx, x) : xs) =
+      case create s xs of
+        (l :*: ys) -> x `seq` let !t' = link kx x l r
+                              in go (s `shiftL` 1) t' ys

-    create !_ [] = (Tip, [])
+    create !_ [] = (Tip :*: [])
create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, 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
-                      (r, (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                        (l, zs) -> y `seq` (link ky y l r, zs)
+                      res@(_ :*: []) -> res
+                      (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (l :*: zs) -> y `seq` (link ky y l r :*: zs)
index 2fefcb6..c0b6160 100644 (file)
@@ -974,7 +974,8 @@ fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
where
go !_ t [] = t
go s l (x : xs) = case create s xs of
-                        (r :*: ys) -> go (s `shiftL` 1) (link x l r) ys
+                        (r :*: ys) -> let !t' = link x l r
+                                      in go (s `shiftL` 1) t' ys

create !_ [] = (Tip :*: [])
create s xs@(x : xs')
@@ -995,7 +996,8 @@ fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
where
go !_ t [] = t
go s r (x : xs) = case create s xs of
-                        (l :*: ys) -> go (s `shiftL` 1) (link x l r) ys
+                        (l :*: ys) -> let !t' = link x l r
+                                      in go (s `shiftL` 1) t' ys

create !_ [] = (Tip :*: [])
create s xs@(x : xs')
index 2ffd740..09b1e83 100644 (file)
@@ -16,6 +16,8 @@ module Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where
-- @
data StrictPair a b = !a :*: !b

+infixr 1 :*:
+
-- | Convert a strict pair to a standard pair.
toPair :: StrictPair a b -> (a, b)
toPair (x :*: y) = (x, y)