6 files changed, 138 insertions, 2 deletions

diff --git a/stdlib/array.ml b/stdlib/array.ml
index d77cf624d..175a3516f 100644
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -144,6 +144,7 @@ let to_list a =
     if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
   tolist (length a - 1) []
 
+(* Cannot use List.length here because the List module depends on Array. *)
 let rec list_length accu = function
   | [] -> accu
   | h::t -> list_length (succ accu) t
@@ -274,3 +275,5 @@ let stable_sort cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
+
+let fast_sort = stable_sort;;
diff --git a/stdlib/array.mli b/stdlib/array.mli
index 3d0c31895..3d1c60ce0 100644
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -192,6 +192,12 @@ val stable_sort : ('a -> 'a -> int) -> 'a array -> unit
    It is usually faster than the current implementation of {!Array.sort}.
 *)
 
+val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster
+    on typical input.
+*)
+
+
 (**/**)
 (** {6 Undocumented functions} *)
 
diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
index 64b664410..0616ada1e 100644
--- a/stdlib/arrayLabels.mli
+++ b/stdlib/arrayLabels.mli
@@ -178,6 +178,12 @@ val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
    It is faster than the current implementation of {!ArrayLabels.sort}.
 *)
 
+val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster
+    on typical input.
+*)
+
+
 (**/**)
 
 (** {6 Undocumented functions} *)
diff --git a/stdlib/list.ml b/stdlib/list.ml
index a6aeceef5..fbdb6819c 100644
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -195,6 +195,101 @@ let rec combine l1 l2 =
 
 (** sorting *)
 
+let rec merge cmp l1 l2 =
+  match l1, l2 with
+  | [], l2 -> l2
+  | l1, [] -> l1
+  | h1 :: t1, h2 :: t2 ->
+      if cmp h1 h2 <= 0
+      then h1 :: merge cmp t1 l2
+      else h2 :: merge cmp l1 t2
+;;
+
+let rec chop k l =
+  if k = 0 then l else begin
+    match l with
+    | x::t -> chop (k-1) t
+    | _ -> assert false
+  end
+;;
+
+let stable_sort cmp l =
+  let rec rev_merge l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> rev_append l2 accu
+    | l1, [] -> rev_append l1 accu
+    | h1::t1, h2::t2 ->
+        if cmp h1 h2 <= 0
+        then rev_merge t1 l2 (h1::accu)
+        else rev_merge l1 t2 (h2::accu)
+  in
+  let rec rev_merge_rev l1 l2 accu =
+    match l1, l2 with
+    | [], l2 -> rev_append l2 accu
+    | l1, [] -> rev_append l1 accu
+    | h1::t1, h2::t2 ->
+        if cmp h1 h2 > 0
+        then rev_merge_rev t1 l2 (h1::accu)
+        else rev_merge_rev l1 t2 (h2::accu)
+  in
+  let rec sort n l =
+    match n, l with
+    | 2, x1 :: x2 :: _ ->
+       if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       if cmp x1 x2 <= 0 then begin
+         if cmp x2 x3 <= 0 then [x1; x2; x3]
+         else if cmp x1 x3 <= 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         if cmp x1 x3 <= 0 then [x2; x1; x3]
+         else if cmp x2 x3 <= 0 then [x2; x3; x1]
+         else [x3; x2; x1]
+       end
+    | n, l ->
+       let n1 = n asr 1 in
+       let n2 = n - n1 in
+       let l2 = chop n1 l in
+       let s1 = rev_sort n1 l in
+       let s2 = rev_sort n2 l2 in
+       rev_merge_rev s1 s2 []
+  and rev_sort n l =
+    match n, l with
+    | 2, x1 :: x2 :: _ ->
+       if cmp x1 x2 > 0 then [x1; x2] else [x2; x1]
+    | 3, x1 :: x2 :: x3 :: _ ->
+       if cmp x1 x2 > 0 then begin
+         if cmp x2 x3 > 0 then [x1; x2; x3]
+         else if cmp x1 x3 > 0 then [x1; x3; x2]
+         else [x3; x1; x2]
+       end else begin
+         if cmp x1 x3 > 0 then [x2; x1; x3]
+         else if cmp x2 x3 > 0 then [x2; x3; x1]
+         else [x3; x2; x1]
+       end
+    | n, l ->
+       let n1 = n asr 1 in
+       let n2 = n - n1 in
+       let l2 = chop n1 l in
+       let s1 = sort n1 l in
+       let s2 = sort n2 l2 in
+       rev_merge s1 s2 []
+  in
+  let len = length l in
+  if len < 2 then l else sort len l
+;;
+
+let sort = stable_sort;;
+let fast_sort = stable_sort;;
+
+(* Note: on a list of length between about 100000 (depending on the minor
+   heap size and the type of the list) and Sys.max_array_size, it is
+   actually faster to use the following, but it might also use more memory
+   because the argument list cannot be deallocated incrementally.
+
+   Also, there seems to be a bug in this code or in the
+   implementation of obj_truncate.
+
 external obj_truncate : 'a array -> int -> unit = "obj_truncate"
 
 let array_to_list_in_place a =
@@ -217,5 +312,4 @@ let stable_sort cmp l =
   Array.stable_sort cmp a;
   array_to_list_in_place a
 ;;
-
-let sort = stable_sort;;
+*)
diff --git a/stdlib/list.mli b/stdlib/list.mli
index 6484464a5..443d2317c 100644
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -260,3 +260,17 @@ val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
    The current implementation uses Merge Sort. It runs in constant
    heap space and logarithmic stack space.
 *)
+
+val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster
+    on typical input. *)
+
+val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+(** Merge two lists:
+    Assuming that [l1] and [l2] are sorted according to the
+    comparison function [cmp], [merge cmp l1 l2] will return a
+    sorted list containting all the elements of [l1] and [l2].
+    If several elements compare equal, the elements of [l1] will be
+    before the elements of [l2].
+    Not tail-recursive (sum of the lenghts of the arguments).
+*)
diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli
index 1f26c0c56..d1f95d293 100644
--- a/stdlib/listLabels.mli
+++ b/stdlib/listLabels.mli
@@ -268,3 +268,16 @@ val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
    heap space and logarithmic stack space.
 *)
 
+val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster
+    on typical input. *)
+
+val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+(** Merge two lists:
+    Assuming that [l1] and [l2] are sorted according to the
+    comparison function [cmp], [merge cmp l1 l2] will return a
+    sorted list containting all the elements of [l1] and [l2].
+    If several elements compare equal, the elements of [l1] will be
+    before the elements of [l2].
+    Not tail-recursive (sum of the lenghts of the arguments).
+*)