[commit: packages/containers] cleaned_bugfix394, master, merge-doc-target, merge-fixes-5.9, revert-408-bugfix_394: Make Data.Map.fromDistinct{Asc, Desc}List eager (4fcf139)
git at git.haskell.org
git at git.haskell.org
Mon Apr 17 21:45:24 UTC 2017
Repository : ssh://git@git.haskell.org/containers
On branches: cleaned_bugfix394,master,merge-doc-target,merge-fixes-5.9,revert-408-bugfix_394
Link : http://git.haskell.org/packages/containers.git/commitdiff/4fcf139d54bb0b872317f239267024e341555646
>---------------------------------------------------------------
commit 4fcf139d54bb0b872317f239267024e341555646
Author: David Feuer <David.Feuer at gmail.com>
Date: Sun Sep 4 03:28:39 2016 -0400
Make Data.Map.fromDistinct{Asc,Desc}List eager
* `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.
>---------------------------------------------------------------
4fcf139d54bb0b872317f239267024e341555646
Data/Map/Internal.hs | 26 ++++++++++++++------------
Data/Map/Strict/Internal.hs | 32 ++++++++++++++++++--------------
Data/Set/Internal.hs | 6 ++++--
Utils/Containers/Internal/StrictPair.hs | 2 ++
4 files changed, 38 insertions(+), 28 deletions(-)
diff --git a/Data/Map/Internal.hs b/Data/Map/Internal.hs
index a3bc550..0b8202f 100644
--- a/Data/Map/Internal.hs
+++ b/Data/Map/Internal.hs
@@ -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
diff --git a/Data/Map/Strict/Internal.hs b/Data/Map/Strict/Internal.hs
index 5ed14b3..c8882a0 100644
--- a/Data/Map/Strict/Internal.hs
+++ b/Data/Map/Strict/Internal.hs
@@ -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)
diff --git a/Data/Set/Internal.hs b/Data/Set/Internal.hs
index 2fefcb6..c0b6160 100644
--- a/Data/Set/Internal.hs
+++ b/Data/Set/Internal.hs
@@ -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')
diff --git a/Utils/Containers/Internal/StrictPair.hs b/Utils/Containers/Internal/StrictPair.hs
index 2ffd740..09b1e83 100644
--- a/Utils/Containers/Internal/StrictPair.hs
+++ b/Utils/Containers/Internal/StrictPair.hs
@@ -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)
More information about the ghc-commits
mailing list