X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FList.hs;h=3c9fd265958bf8d8cbc5e0518510dcf42312de69;hb=7dfe4a22aa6a2c598b1496c661c7d532aaafa94f;hp=16cbeb826cc6f63e628e0d0b3e8777d5e87d015f;hpb=f944cc5444d0af4769f48100a93d31c0759a0ee1;p=ghc-base.git

diff --git a/Data/List.hs b/Data/List.hs
index 16cbeb8..3c9fd26 100644
--- a/Data/List.hs
+++ b/Data/List.hs
@@ -399,6 +399,9 @@ unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
 -- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4]
 --
 -- If the first list contains duplicates, so will the result.
+--
+-- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4]
+--
 -- It is a special case of 'intersectBy', which allows the programmer to
 -- supply their own equality test.
 
@@ -568,6 +571,17 @@ genericLength           :: (Num i) => [b] -> i
 genericLength []        =  0
 genericLength (_:l)     =  1 + genericLength l
 
+{-# RULES
+  "genericLengthInt"     genericLength = (strictGenericLength :: [a] -> Int);
+  "genericLengthInteger" genericLength = (strictGenericLength :: [a] -> Integer);
+ #-}
+
+strictGenericLength     :: (Num i) => [b] -> i
+strictGenericLength l   =  gl l 0
+                        where
+                           gl [] a     = a
+                           gl (_:xs) a = let a' = a + 1 in a' `seq` gl xs a'
+
 -- | The 'genericTake' function is an overloaded version of 'take', which
 -- accepts any 'Integral' value as the number of elements to take.
 genericTake             :: (Integral i) => i -> [a] -> [a]
@@ -779,10 +793,50 @@ sort = sortBy compare
 sortBy cmp = foldr (insertBy cmp) []
 #else
 
+{-
+GHC's mergesort replaced by a better implementation, 24/12/2009.
+This code originally contributed to the nhc12 compiler by Thomas Nordin
+in 2002.  Rumoured to have been based on code by Lennart Augustsson, e.g.
+    http://www.mail-archive.com/haskell@haskell.org/msg01822.html
+and possibly to bear similarities to a 1982 paper by Richard O'Keefe:
+"A smooth applicative merge sort".
+
+Benchmarks show it to be often 2x the speed of the previous implementation.
+Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/2143
+-}
+
+sort = sortBy compare
+sortBy cmp = mergeAll . sequences
+  where
+    sequences (a:b:xs)
+      | a `cmp` b == GT = descending b [a]  xs
+      | otherwise       = ascending  b (a:) xs
+    sequences xs = [xs]
+
+    descending a as (b:bs)
+      | a `cmp` b == GT = descending b (a:as) bs
+    descending a as bs  = (a:as): sequences bs
+
+    ascending a as (b:bs)
+      | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs
+    ascending a as bs   = as [a]: sequences bs
+
+    mergeAll [x] = x
+    mergeAll xs  = mergeAll (mergePairs xs)
+
+    mergePairs (a:b:xs) = merge a b: mergePairs xs
+    mergePairs xs       = xs
+
+    merge as@(a:as') bs@(b:bs')
+      | a `cmp` b == GT = b:merge as  bs'
+      | otherwise       = a:merge as' bs
+    merge [] bs         = bs
+    merge as []         = as
+
+{-
 sortBy cmp l = mergesort cmp l
 sort l = mergesort compare l
 
-{-
 Quicksort replaced by mergesort, 14/5/2002.
 
 From: Ian Lynagh <igloo@earth.li>
@@ -823,7 +877,6 @@ func            100000           sorted        sort        5831.47
 func            100000           sorted        mergesort   2.23
 func            100000           revsorted     sort        5872.34
 func            100000           revsorted     mergesort   2.24
--}
 
 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
 mergesort cmp = mergesort' cmp . map wrap
@@ -849,8 +902,9 @@ merge cmp (x:xs) (y:ys)
 wrap :: a -> [a]
 wrap x = [x]
 
-{-
-OLD: qsort version
+
+
+OLDER: qsort version
 
 -- qsort is stable and does not concatenate.
 qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]