Speeding up unstableSort (#425)
authorDonnacha Oisín Kidney <oisdk@users.noreply.github.com>
Tue, 2 May 2017 00:58:31 +0000 (01:58 +0100)
committerDavid Feuer <David.Feuer@gmail.com>
Tue, 2 May 2017 00:58:31 +0000 (20:58 -0400)
* Trying out quicker sort - pairing, with state

* Specialise pragmas for queue-state

* Put back sequence benchmarks; put sorting benchmarks in own file

* Correct queuestate type

* Both versions use same state now

* Added benchmarks for strictly increasing sequences

* Remove implementation with intermediate list - let's look at other optimisations now

* Formatting of pqState

* Changed pqState -> popMin

* Removed duplicate functions

* Benchmarks include stable sort

* Now compares to stable sort in benchmarks

* Added comments

* Put benchmarks in with other sequence benchmarks

* Added note on replicate specialisation

* Stopped using pattern synonym in unstableSortBy

Data/Sequence/Internal.hs
benchmarks/Sequence.hs

index 9879321..a533862 100644 (file)
@@ -1207,6 +1207,7 @@ replicateA :: Applicative f => Int -> f a -> f (Seq a)
 replicateA n x
   | n >= 0      = Seq <$> applicativeTree n 1 (Elem <$> x)
   | otherwise   = error "replicateA takes a nonnegative integer argument"
+{-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-}
 
 -- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
 --
@@ -4327,6 +4328,39 @@ zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'
 --
 -- wasserman.louis@gmail.com, 7/20/09
 ------------------------------------------------------------------------
+-- David Feuer wrote an unstable sort for arbitrary traversables,
+-- https://www.reddit.com/r/haskell/comments/63a4ea/fast_total_sorting_of_arbitrary_traversable/,
+-- which turned out to be competitive with the unstable sort here.
+-- Feuer suggested that this indicated some room to improve on the
+-- unstable sort.
+--
+-- The two main improvements to the original function are a specialize
+-- pragma on replicateA (this gives a 26.5% speedup) and removal of the
+-- intermediate list (a further 11.7% speedup). These numbers are all on
+-- purely random sequences of length 50000:
+--
+-- Times (ms)            min    est    max  std dev   R²
+-- to/from list:        70.90  72.44  75.07  2.224  0.998
+-- 7/20/09 heapsort:    59.84  61.44  63.08  1.554  0.998
+-- 7/20/09 w/pragma:    44.22  45.14  46.25  1.631  0.998
+-- 4/30/17 heapsort:    38.21  39.86  40.87  1.203  0.996
+--
+-- It should also be noted that Data.List.sortBy has become
+-- significantly quicker. Data.List.sortBy also now recognizes strictly
+-- increasing sequences, making it much quicker for that case:
+--
+-- Times (ms)            min    est    max  std dev   R²
+-- to/from list:        7.140  7.351  7.634  0.335  0.993
+-- 7/20/09 heapsort:    19.52  19.78  20.13  0.445  0.999
+-- 7/20/09 w/pragma:    8.050  8.271  8.514  0.357  0.995
+-- 4/30/17 heapsort:    7.240  7.612  7.925  0.389  0.991
+--
+-- Another happy result of the specialization of 'replicateA' is that
+-- the stable sort seems to speed up by 10-20%, and 'iterateN' looks
+-- like it's about three times as fast.
+--
+-- mail@doisinkidney.com, 4/30/17
+------------------------------------------------------------------------
 
 -- | /O(n log n)/.  'sort' sorts the specified 'Seq' by the natural
 -- ordering of its elements.  The sort is stable.
@@ -4344,22 +4378,18 @@ sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))
 
 -- | /O(n log n)/.  'unstableSort' sorts the specified 'Seq' by
 -- the natural ordering of its elements, but the sort is not stable.
--- This algorithm is frequently faster and uses less memory than 'sort',
--- and performs extremely well -- frequently twice as fast as 'sort' --
--- when the sequence is already nearly sorted.
+-- This algorithm is frequently faster and uses less memory than 'sort'.
 unstableSort :: Ord a => Seq a -> Seq a
 unstableSort = unstableSortBy compare
 
 -- | /O(n log n)/.  A generalization of 'unstableSort', 'unstableSortBy'
 -- takes an arbitrary comparator and sorts the specified sequence.
 -- The sort is not stable.  This algorithm is frequently faster and
--- uses less memory than 'sortBy', and performs extremely well --
--- frequently twice as fast as 'sortBy' -- when the sequence is already
--- nearly sorted.
+-- uses less memory than 'sortBy'.
 unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a
 unstableSortBy cmp (Seq xs) =
-    fromList2 (size xs) $ maybe [] (unrollPQ cmp) $
-        toPQ cmp (\ (Elem x) -> PQueue x Nil) xs
+    maybe (Seq EmptyT) (execState (replicateA (size xs) (popMin cmp))) $
+    toPQ cmp (\(Elem x) -> PQueue x Nil) xs
 
 -- | fromList2, given a list and its length, constructs a completely
 -- balanced Seq whose elements are that list using the replicateA
@@ -4402,21 +4432,19 @@ draw (PQueue x ts0) = x : drawSubTrees ts0
     shift first other = Data.List.zipWith (++) (first : repeat other)
 #endif
 
--- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into
--- a sorted list.
-unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]
-unrollPQ cmp = unrollPQ'
+-- | 'popMin', given an ordering function, constructs a stateful action
+-- which pops the smallest elements from a queue. This action will fail
+-- on empty queues.
+popMin :: (e -> e -> Ordering) -> State (PQueue e) e
+popMin cmp = State unrollPQ'
   where
     {-# INLINE unrollPQ' #-}
-    unrollPQ' (PQueue x ts) = x:mergePQs0 ts
+    unrollPQ' (PQueue x ts) = (mergePQs ts, x)
+    mergePQs (t :& Nil) = t
+    mergePQs (t1 :& t2 :& Nil) = t1 <+> t2
+    mergePQs (t1 :& t2 :& ts) = (t1 <+> t2) <+> mergePQs ts
+    mergePQs Nil = error "popMin: tried to pop from empty queue"
     (<+>) = mergePQ cmp
-    mergePQs0 Nil = []
-    mergePQs0 (t :& Nil) = unrollPQ' t
-    mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <+> t2) ts
-    mergePQs !t ts = case ts of
-        Nil             -> unrollPQ' t
-        t1 :& Nil       -> unrollPQ' (t <+> t1)
-        t1 :& t2 :& ts' -> mergePQs (t <+> (t1 <+> t2)) ts'
 
 -- | 'toPQ', given an ordering function and a mechanism for queueifying
 -- elements, converts a 'FingerTree' to a 'PQueue'.
index 99d1ca4..1600c3f 100644 (file)
@@ -24,6 +24,11 @@ main = do
         r1000 = rlist 1000
         r10000 = rlist 10000
     evaluate $ rnf [r10, r100, r1000, r10000]
+    let rs10 = S.fromList r10
+        rs100 = S.fromList r100
+        rs1000 = S.fromList r1000
+        rs10000 = S.fromList r10000
+    evaluate $ rnf [rs10, rs100, rs1000, rs10000]
     let u10 = S.replicate 10 () :: S.Seq ()
         u100 = S.replicate 100 () :: S.Seq ()
         u1000 = S.replicate 1000 () :: S.Seq ()
@@ -128,6 +133,30 @@ main = do
          , bench "nf2500/100/ff" $
               nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (2500,100)
          ]
+      , bgroup "sort"
+         [ bgroup "already sorted"
+            [ bench "10" $ nf S.sort s10
+            , bench "100" $ nf S.sort s100
+            , bench "1000" $ nf S.sort s1000
+            , bench "10000" $ nf S.sort s10000]
+         , bgroup "random"
+            [ bench "10" $ nf S.sort rs10
+            , bench "100" $ nf S.sort rs100
+            , bench "1000" $ nf S.sort rs1000
+            , bench "10000" $ nf S.sort rs10000]
+         ]
+      , bgroup "unstableSort"
+         [ bgroup "already sorted"
+            [ bench "10" $ nf S.unstableSort s10
+            , bench "100" $ nf S.unstableSort s100
+            , bench "1000" $ nf S.unstableSort s1000
+            , bench "10000" $ nf S.unstableSort s10000]
+         , bgroup "random"
+            [ bench "10" $ nf S.unstableSort rs10
+            , bench "100" $ nf S.unstableSort rs100
+            , bench "1000" $ nf S.unstableSort rs1000
+            , bench "10000" $ nf S.unstableSort rs10000]
+         ]
       ]
 
 {-
@@ -165,7 +194,6 @@ deleteAtPoints points xs =
 fakedeleteAtPoints :: [Int] -> S.Seq a -> S.Seq a
 fakedeleteAtPoints points xs =
   foldl' (\acc k -> fakeDeleteAt k acc) xs points
-
 -- For comparison with deleteAt. deleteAt is several
 -- times faster for long sequences.
 fakeDeleteAt :: Int -> S.Seq a -> S.Seq a