diff -ur ocaml-3.11.0.orig/build/install.sh ocaml-3.11.0/build/install.sh
--- ocaml-3.11.0.orig/build/install.sh	2008-08-05 15:05:23.000000000 +0200
+++ ocaml-3.11.0/build/install.sh	2009-04-21 20:26:57.000000000 +0200
@@ -172,6 +172,7 @@
   stdlib/camlinternalOO.cmi stdlib/camlinternalOO.mli \
   stdlib/char.cmi stdlib/char.mli \
   stdlib/complex.cmi stdlib/complex.mli \
+  stdlib/custom_value.cmi stdlib/custom_value.mli \
   stdlib/digest.cmi stdlib/digest.mli \
   stdlib/filename.cmi stdlib/filename.mli \
   stdlib/format.cmi stdlib/format.mli \
@@ -216,6 +217,7 @@
  stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx stdlib/camlinternalOO.$O stdlib/camlinternalOO.p.$O \
  stdlib/char.cmx stdlib/char.p.cmx stdlib/char.$O stdlib/char.p.$O \
  stdlib/complex.cmx stdlib/complex.p.cmx stdlib/complex.$O stdlib/complex.p.$O \
+ stdlib/custom_value.cmx stdlib/custom_value.p.cmx stdlib/custom_value.$O stdlib/custom_value.p.$O \
  stdlib/digest.cmx stdlib/digest.p.cmx stdlib/digest.$O stdlib/digest.p.$O \
  stdlib/filename.cmx stdlib/filename.p.cmx stdlib/filename.$O stdlib/filename.p.$O \
  stdlib/format.cmx stdlib/format.p.cmx stdlib/format.$O stdlib/format.p.$O \
diff -ur ocaml-3.11.0.orig/byterun/compare.c ocaml-3.11.0/byterun/compare.c
--- ocaml-3.11.0.orig/byterun/compare.c	2008-01-11 17:13:16.000000000 +0100
+++ ocaml-3.11.0/byterun/compare.c	2009-04-21 22:59:26.000000000 +0200
@@ -20,64 +20,16 @@
 #include "memory.h"
 #include "misc.h"
 #include "mlvalues.h"
+#include "callback.h"
 
 /* Structural comparison on trees. */
 
 struct compare_item { value * v1, * v2; mlsize_t count; };
 
-#define COMPARE_STACK_INIT_SIZE 256
-#define COMPARE_STACK_MAX_SIZE (1024*1024)
-
-static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE];
-
-static struct compare_item * compare_stack = compare_stack_init;
-static struct compare_item * compare_stack_limit = compare_stack_init
-                                                   + COMPARE_STACK_INIT_SIZE;
+#define COMPARE_STACK_SIZE 256
 
 CAMLexport int caml_compare_unordered;
 
-/* Free the compare stack if needed */
-static void compare_free_stack(void)
-{
-  if (compare_stack != compare_stack_init) {
-    free(compare_stack);
-    /* Reinitialize the globals for next time around */
-    compare_stack = compare_stack_init;
-    compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE;
-  }
-}
-
-/* Same, then raise Out_of_memory */
-static void compare_stack_overflow(void)
-{
-  caml_gc_message (0x04, "Stack overflow in structural comparison\n", 0);
-  compare_free_stack();
-  caml_raise_out_of_memory();
-}
-
-/* Grow the compare stack */
-static struct compare_item * compare_resize_stack(struct compare_item * sp)
-{
-  asize_t newsize = 2 * (compare_stack_limit - compare_stack);
-  asize_t sp_offset = sp - compare_stack;
-  struct compare_item * newstack;
-
-  if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow();
-  if (compare_stack == compare_stack_init) {
-    newstack = malloc(sizeof(struct compare_item) * newsize);
-    if (newstack == NULL) compare_stack_overflow();
-    memcpy(newstack, compare_stack_init,
-           sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE);
-  } else {
-    newstack =
-      realloc(compare_stack, sizeof(struct compare_item) * newsize);
-    if (newstack == NULL) compare_stack_overflow();
-  }
-  compare_stack = newstack;
-  compare_stack_limit = newstack + newsize;
-  return newstack + sp_offset;
-}
-
 /* Structural comparison */
 
 #define LESS -1
@@ -93,10 +45,11 @@
 
 static intnat compare_val(value v1, value v2, int total)
 {
-  struct compare_item * sp;
+  struct compare_item compare_stack[COMPARE_STACK_SIZE];
+  struct compare_item * compare_stack_limit = compare_stack + COMPARE_STACK_SIZE - 1;
+  struct compare_item * sp = compare_stack - 1;
   tag_t t1, t2;
 
-  sp = compare_stack;
   while (1) {
     if (v1 == v2 && total) goto next_item;
     if (Is_long(v1)) {
@@ -183,11 +136,9 @@
       break;
     }
     case Abstract_tag:
-      compare_free_stack();
       caml_invalid_argument("equal: abstract value");
     case Closure_tag:
     case Infix_tag:
-      compare_free_stack();
       caml_invalid_argument("equal: functional value");
     case Object_tag: {
       intnat oid1 = Oid_val(v1);
@@ -198,16 +149,19 @@
     case Custom_tag: {
       int res;
       int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare;
-      if (compare == NULL) {
-        compare_free_stack();
+      if (compare == NULL)
         caml_invalid_argument("equal: abstract value");
-      }
       caml_compare_unordered = 0;
       res = Custom_ops_val(v1)->compare(v1, v2);
       if (caml_compare_unordered && !total) return UNORDERED;
       if (res != 0) return res;
       break;
     }
+    case User_tag: {
+      int res = Long_val(caml_callback2(Data_user_compare(v1), Data_user_val(v1), Data_user_val(v2)));
+      if (res != 0) return res;
+      break;
+    }
     default: {
       mlsize_t sz1 = Wosize_val(v1);
       mlsize_t sz2 = Wosize_val(v2);
@@ -216,11 +170,16 @@
       if (sz1 == 0) break;
       /* Remember that we still have to compare fields 1 ... sz - 1 */
       if (sz1 > 1) {
-        sp++;
-        if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
-        sp->v1 = &Field(v1, 1);
-        sp->v2 = &Field(v2, 1);
-        sp->count = sz1 - 1;
+        if (sp == compare_stack_limit) {
+          int res = compare_val(v1, v2, total);
+          if (res != 0) return res;
+          break;
+        } else {
+          sp++;
+          sp->v1 = &Field(v1, 1);
+          sp->v2 = &Field(v2, 1);
+          sp->count = sz1 - 1;
+        }
       }
       /* Continue comparison with first field */
       v1 = Field(v1, 0);
@@ -230,7 +189,7 @@
     }
   next_item:
     /* Pop one more item to compare, if any */
-    if (sp == compare_stack) return EQUAL; /* we're done */
+    if (sp < compare_stack) return EQUAL; /* we're done */
     v1 = *((sp->v1)++);
     v2 = *((sp->v2)++);
     if (--(sp->count) == 0) sp--;
@@ -240,8 +199,6 @@
 CAMLprim value caml_compare(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 1);
-  /* Free stack if needed */
-  if (compare_stack != compare_stack_init) compare_free_stack();
   if (res < 0)
     return Val_int(LESS);
   else if (res > 0)
@@ -253,41 +210,35 @@
 CAMLprim value caml_equal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res == 0);
 }
 
 CAMLprim value caml_notequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res != 0);
 }
 
 CAMLprim value caml_lessthan(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res < 0 && res != UNORDERED);
 }
 
 CAMLprim value caml_lessequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res <= 0 && res != UNORDERED);
 }
 
 CAMLprim value caml_greaterthan(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res > 0);
 }
 
 CAMLprim value caml_greaterequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res >= 0);
 }
diff -ur ocaml-3.11.0.orig/byterun/mlvalues.h ocaml-3.11.0/byterun/mlvalues.h
--- ocaml-3.11.0.orig/byterun/mlvalues.h	2008-08-01 16:10:36.000000000 +0200
+++ ocaml-3.11.0/byterun/mlvalues.h	2009-04-21 20:03:56.000000000 +0200
@@ -255,6 +255,12 @@
 #define Data_custom_val(v) ((void *) &Field((v), 1))
 struct custom_operations;       /* defined in [custom.h] */
 
+/* User blocks. The first value of a user block is its content and the
+   second is a comparison function. */
+#define User_tag 245
+#define Data_user_val(v) (Field((v), 0))
+#define Data_user_compare(v) (Field((v), 1))
+
 /* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */
 
 #define Int32_val(v) (*((int32 *) Data_custom_val(v)))
diff -ur ocaml-3.11.0.orig/stdlib/.depend ocaml-3.11.0/stdlib/.depend
--- ocaml-3.11.0.orig/stdlib/.depend	2008-10-15 15:13:07.000000000 +0200
+++ ocaml-3.11.0/stdlib/.depend	2009-04-21 20:55:09.000000000 +0200
@@ -64,6 +64,8 @@
 char.cmx: char.cmi 
 complex.cmo: complex.cmi 
 complex.cmx: complex.cmi 
+custom_value.cmo: custom_value.cmi 
+custom_value.cmx: custom_value.cmi 
 digest.cmo: string.cmi printf.cmi digest.cmi 
 digest.cmx: string.cmx printf.cmx digest.cmi 
 filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
diff -ur ocaml-3.11.0.orig/stdlib/Makefile.shared ocaml-3.11.0/stdlib/Makefile.shared
--- ocaml-3.11.0.orig/stdlib/Makefile.shared	2008-08-01 18:57:10.000000000 +0200
+++ ocaml-3.11.0/stdlib/Makefile.shared	2009-04-21 20:27:15.000000000 +0200
@@ -35,7 +35,7 @@
   digest.cmo random.cmo callback.cmo \
   camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
   genlex.cmo weak.cmo \
-  filename.cmo complex.cmo \
+  filename.cmo complex.cmo custom_value.cmo \
   arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo
 
 all: stdlib.cma std_exit.cmo camlheader camlheader_ur
diff -ur ocaml-3.11.0.orig/stdlib/obj.ml ocaml-3.11.0/stdlib/obj.ml
--- ocaml-3.11.0.orig/stdlib/obj.ml	2008-01-29 14:11:15.000000000 +0100
+++ ocaml-3.11.0/stdlib/obj.ml	2009-04-21 20:00:44.000000000 +0200
@@ -36,6 +36,7 @@
 let unmarshal str pos =
   (Marshal.from_string str pos, pos + Marshal.total_size str pos)
 
+let user_tag = 245
 let lazy_tag = 246
 let closure_tag = 247
 let object_tag = 248
diff -ur ocaml-3.11.0.orig/stdlib/obj.mli ocaml-3.11.0/stdlib/obj.mli
--- ocaml-3.11.0.orig/stdlib/obj.mli	2008-01-29 14:11:15.000000000 +0100
+++ ocaml-3.11.0/stdlib/obj.mli	2009-04-21 20:00:35.000000000 +0200
@@ -34,6 +34,7 @@
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 
+val user_tag : int
 val lazy_tag : int
 val closure_tag : int
 val object_tag : int
diff -ur ocaml-3.11.0.orig/stdlib/stdlib.mllib ocaml-3.11.0/stdlib/stdlib.mllib
--- ocaml-3.11.0.orig/stdlib/stdlib.mllib	2008-08-01 18:57:10.000000000 +0200
+++ ocaml-3.11.0/stdlib/stdlib.mllib	2009-04-21 20:29:50.000000000 +0200
@@ -13,6 +13,7 @@
 CamlinternalOO
 Char
 Complex
+Custom_value
 Digest
 Filename
 Format
diff -ur ocaml-3.11.0.orig/stdlib/StdlibModules ocaml-3.11.0/stdlib/StdlibModules
--- ocaml-3.11.0.orig/stdlib/StdlibModules	2008-08-01 18:57:10.000000000 +0200
+++ ocaml-3.11.0/stdlib/StdlibModules	2009-04-21 20:27:08.000000000 +0200
@@ -13,6 +13,7 @@
   camlinternalOO \
   char \
   complex \
+  custom_value \
   digest \
   filename \
   format \
diff -ur ocaml-3.11.0.orig/utils/config.mlp ocaml-3.11.0/utils/config.mlp
--- ocaml-3.11.0.orig/utils/config.mlp	2008-04-16 08:50:31.000000000 +0200
+++ ocaml-3.11.0/utils/config.mlp	2009-04-21 20:00:17.000000000 +0200
@@ -52,7 +52,7 @@
 
 let interface_suffix = ref ".mli"
 
-let max_tag = 245
+let max_tag = 244
 (* This is normally the same as in obj.ml, but we have to define it
    separately because it can differ when we're in the middle of a
    bootstrapping phase. *)

diff -ur ocaml-3.11.0.orig/stdlib/map.ml ocaml-3.11.0/stdlib/map.ml
--- ocaml-3.11.0.orig/stdlib/map.ml	2005-08-13 22:59:37.000000000 +0200
+++ ocaml-3.11.0/stdlib/map.ml	2009-04-22 00:36:53.000000000 +0200
@@ -196,3 +196,177 @@
       in equal_aux (cons_enum m1 End) (cons_enum m2 End)
 
 end
+
+
+type ('a, 'b) map =
+    Empty
+  | Node of ('a, 'b) map * 'a * 'b * ('a, 'b) map * int
+
+let height = function
+    Empty -> 0
+  | Node(_,_,_,_,h) -> h
+
+let create l x d r =
+  let hl = height l and hr = height r in
+  Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let bal l x d r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+  let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+  if hl > hr + 2 then begin
+    match l with
+        Empty -> invalid_arg "Map.bal"
+      | Node(ll, lv, ld, lr, _) ->
+          if height ll >= height lr then
+            create ll lv ld (create lr x d r)
+          else begin
+            match lr with
+                Empty -> invalid_arg "Map.bal"
+              | Node(lrl, lrv, lrd, lrr, _)->
+                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+          end
+  end else if hr > hl + 2 then begin
+    match r with
+        Empty -> invalid_arg "Map.bal"
+      | Node(rl, rv, rd, rr, _) ->
+          if height rr >= height rl then
+            create (create l x d rl) rv rd rr
+          else begin
+            match rl with
+                Empty -> invalid_arg "Map.bal"
+              | Node(rll, rlv, rld, rlr, _) ->
+                  create (create l x d rll) rlv rld (create rlr rv rd rr)
+          end
+  end else
+    Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+let empty = Empty
+
+let is_empty = function Empty -> true | _ -> false
+
+let rec add x data = function
+    Empty ->
+      Node(Empty, x, data, Empty, 1)
+  | Node(l, v, d, r, h) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then
+        Node(l, x, data, r, h)
+      else if c < 0 then
+        bal (add x data l) v d r
+      else
+        bal l v d (add x data r)
+
+let rec find x = function
+    Empty ->
+      raise Not_found
+  | Node(l, v, d, r, _) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then d
+      else find x (if c < 0 then l else r)
+
+let rec mem x = function
+    Empty ->
+      false
+  | Node(l, v, d, r, _) ->
+      let c = Pervasives.compare x v in
+      c = 0 || mem x (if c < 0 then l else r)
+
+let rec min_binding = function
+    Empty -> raise Not_found
+  | Node(Empty, x, d, r, _) -> (x, d)
+  | Node(l, x, d, r, _) -> min_binding l
+
+let rec remove_min_binding = function
+    Empty -> invalid_arg "Map.remove_min_elt"
+  | Node(Empty, x, d, r, _) -> r
+  | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+
+let merge t1 t2 =
+  match (t1, t2) with
+      (Empty, t) -> t
+    | (t, Empty) -> t
+    | (_, _) ->
+        let (x, d) = min_binding t2 in
+        bal t1 x d (remove_min_binding t2)
+
+let rec remove x = function
+    Empty ->
+      Empty
+  | Node(l, v, d, r, h) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then
+        merge l r
+      else if c < 0 then
+        bal (remove x l) v d r
+      else
+        bal l v d (remove x r)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, v, d, r, _) ->
+      iter f l; f v d; iter f r
+
+let rec map f = function
+    Empty               -> Empty
+  | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
+
+let rec mapi f = function
+    Empty               -> Empty
+  | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h)
+
+let rec fold f m accu =
+  match m with
+      Empty -> accu
+    | Node(l, v, d, r, _) ->
+        fold f r (f v d (fold f l accu))
+
+type ('a, 'b) enumeration = End | More of 'a * 'b * ('a, 'b) map * ('a, 'b) enumeration
+
+let rec cons_enum m e =
+  match m with
+      Empty -> e
+    | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+
+let compare m1 m2 =
+  let rec compare_aux e1 e2 =
+    match (e1, e2) with
+        (End, End) -> 0
+      | (End, _)  -> -1
+      | (_, End) -> 1
+      | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+          let c = Pervasives.compare v1 v2 in
+          if c <> 0 then c else
+            let c = Pervasives.compare d1 d2 in
+            if c <> 0 then c else
+              compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+  in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+let equal m1 m2 =
+  let rec equal_aux e1 e2 =
+    match (e1, e2) with
+        (End, End) -> true
+      | (End, _)  -> false
+      | (_, End) -> false
+      | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+          v1 = v2 && d1 = d2 &&
+    equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+  in equal_aux (cons_enum m1 End) (cons_enum m2 End)
+
+
+type ('a, 'b) t = ('a, 'b) map Custom_value.t
+
+let make m = Custom_value.make compare m
+let get = Custom_value.get_value
+
+let empty = make empty
+let is_empty m = is_empty (get m)
+let add k v m = make (add k v (get m))
+let find k m = find k (get m)
+let remove k m = make (remove k (get m))
+let mem k m = mem k (get m)
+let iter f m = iter f (get m)
+let map f m = make (map f (get m))
+let mapi f m = make (mapi f (get m))
+let fold f m x = fold f (get m) x
+let compare m1 m2 = compare (get m1) (get m2)
+let equal m1 m2 = equal (get m1) (get m2)
diff -ur ocaml-3.11.0.orig/stdlib/map.mli ocaml-3.11.0/stdlib/map.mli
--- ocaml-3.11.0.orig/stdlib/map.mli	2005-10-25 20:34:07.000000000 +0200
+++ ocaml-3.11.0/stdlib/map.mli	2009-04-22 00:35:56.000000000 +0200
@@ -109,3 +109,19 @@
 module Make (Ord : OrderedType) : S with type key = Ord.t
 (** Functor building an implementation of the map structure
    given a totally ordered type. *)
+
+(** {6 Polymorphic maps} *)
+
+type (+'a, +'b) t
+val empty: ('a, 'b) t
+val is_empty: ('a, 'b) t -> bool
+val add: 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t
+val find: 'a -> ('a, 'b) t -> 'b
+val remove: 'a -> ('a, 'b) t -> ('a, 'b) t
+val mem: 'a -> ('a, 'b) t -> bool
+val iter: ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+val map: ('a -> 'b) -> ('c, 'a) t -> ('c, 'b) t
+val mapi: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
+val fold: ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+val compare: ('a, 'b) t -> ('a, 'b) t -> int
+val equal: ('a, 'b) t -> ('a, 'b) t -> bool
diff -ur ocaml-3.11.0.orig/stdlib/set.ml ocaml-3.11.0/stdlib/set.ml
--- ocaml-3.11.0.orig/stdlib/set.ml	2004-11-25 01:04:15.000000000 +0100
+++ ocaml-3.11.0/stdlib/set.ml	2009-04-22 00:18:26.000000000 +0200
@@ -328,3 +328,305 @@
     let choose = min_elt
 
   end
+
+
+
+type 'a set = Empty | Node of 'a set * 'a * 'a set * int
+
+let height = function
+    Empty -> 0
+  | Node(_, _, _, h) -> h
+
+(* Creates a new node with left son l, value v and right son r.
+   We must have all elements of l < v < all elements of r.
+   l and r must be balanced and | height l - height r | <= 2.
+   Inline expansion of height for better speed. *)
+
+let create l v r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+  let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+
+(* Same as create, but performs one step of rebalancing if necessary.
+   Assumes l and r balanced and | height l - height r | <= 3.
+   Inline expansion of create for better speed in the most frequent case
+   where no rebalancing is required. *)
+
+let bal l v r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+  let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  if hl > hr + 2 then begin
+    match l with
+        Empty -> invalid_arg "Set.bal"
+      | Node(ll, lv, lr, _) ->
+          if height ll >= height lr then
+            create ll lv (create lr v r)
+          else begin
+            match lr with
+                Empty -> invalid_arg "Set.bal"
+              | Node(lrl, lrv, lrr, _)->
+                  create (create ll lv lrl) lrv (create lrr v r)
+          end
+  end else if hr > hl + 2 then begin
+    match r with
+        Empty -> invalid_arg "Set.bal"
+      | Node(rl, rv, rr, _) ->
+          if height rr >= height rl then
+            create (create l v rl) rv rr
+          else begin
+            match rl with
+                Empty -> invalid_arg "Set.bal"
+              | Node(rll, rlv, rlr, _) ->
+                  create (create l v rll) rlv (create rlr rv rr)
+          end
+  end else
+    Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+
+(* Insertion of one element *)
+
+let rec add x = function
+    Empty -> Node(Empty, x, Empty, 1)
+  | Node(l, v, r, _) as t ->
+      let c = Pervasives.compare x v in
+      if c = 0 then t else
+        if c < 0 then bal (add x l) v r else bal l v (add x r)
+
+(* Same as create and bal, but no assumptions are made on the
+   relative heights of l and r. *)
+
+let rec join l v r =
+  match (l, r) with
+      (Empty, _) -> add v r
+    | (_, Empty) -> add v l
+    | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
+        if lh > rh + 2 then bal ll lv (join lr v r) else
+          if rh > lh + 2 then bal (join l v rl) rv rr else
+            create l v r
+
+(* Smallest and greatest element of a set *)
+
+let rec min_elt = function
+    Empty -> raise Not_found
+  | Node(Empty, v, r, _) -> v
+  | Node(l, v, r, _) -> min_elt l
+
+let rec max_elt = function
+    Empty -> raise Not_found
+  | Node(l, v, Empty, _) -> v
+  | Node(l, v, r, _) -> max_elt r
+
+(* Remove the smallest element of the given set *)
+
+let rec remove_min_elt = function
+    Empty -> invalid_arg "Set.remove_min_elt"
+  | Node(Empty, v, r, _) -> r
+  | Node(l, v, r, _) -> bal (remove_min_elt l) v r
+
+(* Merge two trees l and r into one.
+   All elements of l must precede the elements of r.
+   Assume | height l - height r | <= 2. *)
+
+let merge t1 t2 =
+  match (t1, t2) with
+      (Empty, t) -> t
+    | (t, Empty) -> t
+    | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2)
+
+(* Merge two trees l and r into one.
+   All elements of l must precede the elements of r.
+   No assumption on the heights of l and r. *)
+
+let concat t1 t2 =
+  match (t1, t2) with
+      (Empty, t) -> t
+    | (t, Empty) -> t
+    | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2)
+
+(* Splitting.  split x s returns a triple (l, present, r) where
+   - l is the set of elements of s that are < x
+   - r is the set of elements of s that are > x
+   - present is false if s contains no element equal to x,
+   or true if s contains an element equal to x. *)
+
+let rec split x = function
+    Empty ->
+      (Empty, false, Empty)
+  | Node(l, v, r, _) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then (l, true, r)
+      else if c < 0 then
+        let (ll, pres, rl) = split x l in (ll, pres, join rl v r)
+      else
+        let (lr, pres, rr) = split x r in (join l v lr, pres, rr)
+
+(* Implementation of the set operations *)
+
+let empty = Empty
+
+let is_empty = function Empty -> true | _ -> false
+
+let rec mem x = function
+    Empty -> false
+  | Node(l, v, r, _) ->
+      let c = Pervasives.compare x v in
+      c = 0 || mem x (if c < 0 then l else r)
+
+let singleton x = Node(Empty, x, Empty, 1)
+
+let rec remove x = function
+    Empty -> Empty
+  | Node(l, v, r, _) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then merge l r else
+        if c < 0 then bal (remove x l) v r else bal l v (remove x r)
+
+let rec union s1 s2 =
+  match (s1, s2) with
+      (Empty, t2) -> t2
+    | (t1, Empty) -> t1
+    | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+        if h1 >= h2 then
+          if h2 = 1 then add v2 s1 else begin
+            let (l2, _, r2) = split v1 s2 in
+            join (union l1 l2) v1 (union r1 r2)
+          end
+        else
+          if h1 = 1 then add v1 s2 else begin
+            let (l1, _, r1) = split v2 s1 in
+            join (union l1 l2) v2 (union r1 r2)
+          end
+
+let rec inter s1 s2 =
+  match (s1, s2) with
+      (Empty, t2) -> Empty
+    | (t1, Empty) -> Empty
+    | (Node(l1, v1, r1, _), t2) ->
+        match split v1 t2 with
+            (l2, false, r2) ->
+              concat (inter l1 l2) (inter r1 r2)
+          | (l2, true, r2) ->
+              join (inter l1 l2) v1 (inter r1 r2)
+
+let rec diff s1 s2 =
+  match (s1, s2) with
+      (Empty, t2) -> Empty
+    | (t1, Empty) -> t1
+    | (Node(l1, v1, r1, _), t2) ->
+        match split v1 t2 with
+            (l2, false, r2) ->
+              join (diff l1 l2) v1 (diff r1 r2)
+          | (l2, true, r2) ->
+              concat (diff l1 l2) (diff r1 r2)
+
+type 'a enumeration = End | More of 'a * 'a set * 'a enumeration
+
+let rec cons_enum s e =
+  match s with
+      Empty -> e
+    | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
+
+let rec compare_aux e1 e2 =
+  match (e1, e2) with
+      (End, End) -> 0
+    | (End, _)  -> -1
+    | (_, End) -> 1
+    | (More(v1, r1, e1), More(v2, r2, e2)) ->
+        let c = Pervasives.compare v1 v2 in
+        if c <> 0
+        then c
+        else compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+
+let compare s1 s2 =
+  compare_aux (cons_enum s1 End) (cons_enum s2 End)
+
+let equal s1 s2 =
+  compare s1 s2 = 0
+
+let rec subset s1 s2 =
+  match (s1, s2) with
+      Empty, _ ->
+        true
+    | _, Empty ->
+        false
+    | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+        let c = Pervasives.compare v1 v2 in
+        if c = 0 then
+          subset l1 l2 && subset r1 r2
+        else if c < 0 then
+          subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+        else
+          subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, v, r, _) -> iter f l; f v; iter f r
+
+let rec fold f s accu =
+  match s with
+      Empty -> accu
+    | Node(l, v, r, _) -> fold f r (f v (fold f l accu))
+
+let rec for_all p = function
+    Empty -> true
+  | Node(l, v, r, _) -> p v && for_all p l && for_all p r
+
+let rec exists p = function
+    Empty -> false
+  | Node(l, v, r, _) -> p v || exists p l || exists p r
+
+let filter p s =
+  let rec filt accu = function
+    | Empty -> accu
+    | Node(l, v, r, _) ->
+        filt (filt (if p v then add v accu else accu) l) r in
+  filt Empty s
+
+let partition p s =
+  let rec part (t, f as accu) = function
+    | Empty -> accu
+    | Node(l, v, r, _) ->
+        part (part (if p v then (add v t, f) else (t, add v f)) l) r in
+  part (Empty, Empty) s
+
+let rec cardinal = function
+    Empty -> 0
+  | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
+let rec elements_aux accu = function
+    Empty -> accu
+  | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+let elements s =
+  elements_aux [] s
+
+let choose = min_elt
+
+type 'a t = 'a set Custom_value.t
+
+let make x =  Custom_value.make compare x
+let get x = Custom_value.get_value x
+
+let empty = make empty
+let is_empty s = is_empty (get s)
+let mem e s = mem e (get s)
+let add e s = make (add e (get s))
+let singleton e = make (singleton e)
+let remove e s = make (remove e (get s))
+let union s1 s2 = make (union (get s1) (get s2))
+let inter s1 s2 = make (inter (get s1) (get s2))
+let diff s1 s2 = make (diff (get s1) (get s2))
+let compare s1 s2 = compare (get s1) (get s2)
+let equal s1 s2 = equal (get s1) (get s2)
+let subset s1 s2 = subset (get s1) (get s2)
+let iter f s = iter f (get s)
+let fold f s x = fold f (get s) x
+let for_all f s = for_all f (get s)
+let exists f s = exists f (get s)
+let filter f s = make (filter f (get s))
+let partition f s = let s1, s2 = partition f (get s) in (make s1, make s2)
+let cardinal s = cardinal (get s)
+let elements s = elements (get s)
+let min_elt s = min_elt (get s)
+let max_elt s = max_elt (get s)
+let choose s = choose (get s)
+let split e s = let s1, b, s2 = split e (get s) in (make s1, b, make s2)
diff -ur ocaml-3.11.0.orig/stdlib/set.mli ocaml-3.11.0/stdlib/set.mli
--- ocaml-3.11.0.orig/stdlib/set.mli	2005-07-21 16:52:45.000000000 +0200
+++ ocaml-3.11.0/stdlib/set.mli	2009-04-22 00:23:42.000000000 +0200
@@ -151,3 +151,31 @@
 module Make (Ord : OrderedType) : S with type elt = Ord.t
 (** Functor building an implementation of the set structure
    given a totally ordered type. *)
+
+(** {6 Polymorphic sets} *)
+
+type +'a t
+val empty: 'a t
+val is_empty: 'a t -> bool
+val mem: 'a -> 'a t -> bool
+val add: 'a -> 'a t -> 'a t
+val singleton: 'a -> 'a t
+val remove: 'a -> 'a t -> 'a t
+val union: 'a t -> 'a t -> 'a t
+val inter: 'a t -> 'a t -> 'a t
+val diff: 'a t -> 'a t -> 'a t
+val compare: 'a t -> 'a t -> int
+val equal: 'a t -> 'a t -> bool
+val subset: 'a t -> 'a t -> bool
+val iter: ('a -> unit) -> 'a t -> unit
+val fold: ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+val for_all: ('a -> bool) -> 'a t -> bool
+val exists: ('a -> bool) -> 'a t -> bool
+val filter: ('a -> bool) -> 'a t -> 'a t
+val partition: ('a -> bool) -> 'a t -> 'a t * 'a t
+val cardinal: 'a t -> int
+val elements: 'a t -> 'a list
+val min_elt: 'a t -> 'a
+val max_elt: 'a t -> 'a
+val choose: 'a t -> 'a
+val split: 'a -> 'a t -> 'a t * bool * 'a t

commit ab64acaff998667f9d3806ceb190be6d4d517a8b
Author: Jérémie Dimino <jeremie@dimino.org>
Date:   Mon Apr 27 13:30:27 2009 +0200

    Added block with a custom comparison function

diff --git a/build/install.sh b/build/install.sh
index 164640d..5cbe825 100755
--- a/build/install.sh
+++ b/build/install.sh
@@ -172,6 +172,7 @@ installdir \
   stdlib/camlinternalOO.cmi stdlib/camlinternalOO.mli \
   stdlib/char.cmi stdlib/char.mli \
   stdlib/complex.cmi stdlib/complex.mli \
+  stdlib/custom_value.cmi stdlib/custom_value.mli \
   stdlib/digest.cmi stdlib/digest.mli \
   stdlib/filename.cmi stdlib/filename.mli \
   stdlib/format.cmi stdlib/format.mli \
@@ -216,6 +217,7 @@ installdir \
  stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx stdlib/camlinternalOO.$O stdlib/camlinternalOO.p.$O \
  stdlib/char.cmx stdlib/char.p.cmx stdlib/char.$O stdlib/char.p.$O \
  stdlib/complex.cmx stdlib/complex.p.cmx stdlib/complex.$O stdlib/complex.p.$O \
+ stdlib/custom_value.cmx stdlib/custom_value.p.cmx stdlib/custom_value.$O stdlib/custom_value.p.$O \
  stdlib/digest.cmx stdlib/digest.p.cmx stdlib/digest.$O stdlib/digest.p.$O \
  stdlib/filename.cmx stdlib/filename.p.cmx stdlib/filename.$O stdlib/filename.p.$O \
  stdlib/format.cmx stdlib/format.p.cmx stdlib/format.$O stdlib/format.p.$O \
diff --git a/byterun/compare.c b/byterun/compare.c
index 72a7b66..166b144 100644
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -20,64 +20,16 @@
 #include "memory.h"
 #include "misc.h"
 #include "mlvalues.h"
+#include "callback.h"
 
 /* Structural comparison on trees. */
 
 struct compare_item { value * v1, * v2; mlsize_t count; };
 
-#define COMPARE_STACK_INIT_SIZE 256
-#define COMPARE_STACK_MAX_SIZE (1024*1024)
-
-static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE];
-
-static struct compare_item * compare_stack = compare_stack_init;
-static struct compare_item * compare_stack_limit = compare_stack_init
-                                                   + COMPARE_STACK_INIT_SIZE;
+#define COMPARE_STACK_SIZE 256
 
 CAMLexport int caml_compare_unordered;
 
-/* Free the compare stack if needed */
-static void compare_free_stack(void)
-{
-  if (compare_stack != compare_stack_init) {
-    free(compare_stack);
-    /* Reinitialize the globals for next time around */
-    compare_stack = compare_stack_init;
-    compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE;
-  }
-}
-
-/* Same, then raise Out_of_memory */
-static void compare_stack_overflow(void)
-{
-  caml_gc_message (0x04, "Stack overflow in structural comparison\n", 0);
-  compare_free_stack();
-  caml_raise_out_of_memory();
-}
-
-/* Grow the compare stack */
-static struct compare_item * compare_resize_stack(struct compare_item * sp)
-{
-  asize_t newsize = 2 * (compare_stack_limit - compare_stack);
-  asize_t sp_offset = sp - compare_stack;
-  struct compare_item * newstack;
-
-  if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow();
-  if (compare_stack == compare_stack_init) {
-    newstack = malloc(sizeof(struct compare_item) * newsize);
-    if (newstack == NULL) compare_stack_overflow();
-    memcpy(newstack, compare_stack_init,
-           sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE);
-  } else {
-    newstack =
-      realloc(compare_stack, sizeof(struct compare_item) * newsize);
-    if (newstack == NULL) compare_stack_overflow();
-  }
-  compare_stack = newstack;
-  compare_stack_limit = newstack + newsize;
-  return newstack + sp_offset;
-}
-
 /* Structural comparison */
 
 #define LESS -1
@@ -93,10 +45,11 @@ static struct compare_item * compare_resize_stack(struct compare_item * sp)
 
 static intnat compare_val(value v1, value v2, int total)
 {
-  struct compare_item * sp;
+  struct compare_item compare_stack[COMPARE_STACK_SIZE];
+  struct compare_item * compare_stack_limit = compare_stack + COMPARE_STACK_SIZE - 1;
+  struct compare_item * sp = compare_stack - 1;
   tag_t t1, t2;
 
-  sp = compare_stack;
   while (1) {
     if (v1 == v2 && total) goto next_item;
     if (Is_long(v1)) {
@@ -183,11 +136,9 @@ static intnat compare_val(value v1, value v2, int total)
       break;
     }
     case Abstract_tag:
-      compare_free_stack();
       caml_invalid_argument("equal: abstract value");
     case Closure_tag:
     case Infix_tag:
-      compare_free_stack();
       caml_invalid_argument("equal: functional value");
     case Object_tag: {
       intnat oid1 = Oid_val(v1);
@@ -198,16 +149,19 @@ static intnat compare_val(value v1, value v2, int total)
     case Custom_tag: {
       int res;
       int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare;
-      if (compare == NULL) {
-        compare_free_stack();
+      if (compare == NULL)
         caml_invalid_argument("equal: abstract value");
-      }
       caml_compare_unordered = 0;
       res = Custom_ops_val(v1)->compare(v1, v2);
       if (caml_compare_unordered && !total) return UNORDERED;
       if (res != 0) return res;
       break;
     }
+    case User_tag: {
+      int res = Long_val(caml_callback2(Data_user_compare(v1), Data_user_val(v1), Data_user_val(v2)));
+      if (res != 0) return res;
+      break;
+    }
     default: {
       mlsize_t sz1 = Wosize_val(v1);
       mlsize_t sz2 = Wosize_val(v2);
@@ -216,11 +170,16 @@ static intnat compare_val(value v1, value v2, int total)
       if (sz1 == 0) break;
       /* Remember that we still have to compare fields 1 ... sz - 1 */
       if (sz1 > 1) {
-        sp++;
-        if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
-        sp->v1 = &Field(v1, 1);
-        sp->v2 = &Field(v2, 1);
-        sp->count = sz1 - 1;
+        if (sp == compare_stack_limit) {
+          int res = compare_val(v1, v2, total);
+          if (res != 0) return res;
+          break;
+        } else {
+          sp++;
+          sp->v1 = &Field(v1, 1);
+          sp->v2 = &Field(v2, 1);
+          sp->count = sz1 - 1;
+        }
       }
       /* Continue comparison with first field */
       v1 = Field(v1, 0);
@@ -230,7 +189,7 @@ static intnat compare_val(value v1, value v2, int total)
     }
   next_item:
     /* Pop one more item to compare, if any */
-    if (sp == compare_stack) return EQUAL; /* we're done */
+    if (sp < compare_stack) return EQUAL; /* we're done */
     v1 = *((sp->v1)++);
     v2 = *((sp->v2)++);
     if (--(sp->count) == 0) sp--;
@@ -240,8 +199,6 @@ static intnat compare_val(value v1, value v2, int total)
 CAMLprim value caml_compare(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 1);
-  /* Free stack if needed */
-  if (compare_stack != compare_stack_init) compare_free_stack();
   if (res < 0)
     return Val_int(LESS);
   else if (res > 0)
@@ -253,41 +210,35 @@ CAMLprim value caml_compare(value v1, value v2)
 CAMLprim value caml_equal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res == 0);
 }
 
 CAMLprim value caml_notequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res != 0);
 }
 
 CAMLprim value caml_lessthan(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res < 0 && res != UNORDERED);
 }
 
 CAMLprim value caml_lessequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res <= 0 && res != UNORDERED);
 }
 
 CAMLprim value caml_greaterthan(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res > 0);
 }
 
 CAMLprim value caml_greaterequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res >= 0);
 }
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index bd42c0b..7c3e5b0 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -255,6 +255,12 @@ CAMLextern void caml_Store_double_val (value,double);
 #define Data_custom_val(v) ((void *) &Field((v), 1))
 struct custom_operations;       /* defined in [custom.h] */
 
+/* User blocks. The first value of a user block is its content and the
+   second is a comparison function. */
+#define User_tag 245
+#define Data_user_val(v) (Field((v), 0))
+#define Data_user_compare(v) (Field((v), 1))
+
 /* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */
 
 #define Int32_val(v) (*((int32 *) Data_custom_val(v)))
diff --git a/stdlib/.depend b/stdlib/.depend
index faa3382..fbab2db 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -64,6 +64,8 @@ char.cmo: char.cmi
 char.cmx: char.cmi 
 complex.cmo: complex.cmi 
 complex.cmx: complex.cmi 
+custom_value.cmo: custom_value.cmi 
+custom_value.cmx: custom_value.cmi 
 digest.cmo: string.cmi printf.cmi digest.cmi 
 digest.cmx: string.cmx printf.cmx digest.cmi 
 filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared
index 629f49e..efb5997 100755
--- a/stdlib/Makefile.shared
+++ b/stdlib/Makefile.shared
@@ -35,7 +35,7 @@ OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
   digest.cmo random.cmo callback.cmo \
   camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
   genlex.cmo weak.cmo \
-  filename.cmo complex.cmo \
+  filename.cmo complex.cmo custom_value.cmo \
   arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo
 
 all: stdlib.cma std_exit.cmo camlheader camlheader_ur
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index 96f1c41..f927d57 100644
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -13,6 +13,7 @@ STDLIB_MODULES=\
   camlinternalOO \
   char \
   complex \
+  custom_value \
   digest \
   filename \
   format \
diff --git a/stdlib/custom_value.ml b/stdlib/custom_value.ml
new file mode 100644
index 0000000..f0eac04
--- /dev/null
+++ b/stdlib/custom_value.ml
@@ -0,0 +1,23 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*                   Jérémie Dimino, jeremid@dimino.org                *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+type +'a t
+
+let make compare v =
+  let x = Obj.new_block Obj.user_tag 2 in
+  Obj.set_field x 0 (Obj.repr v);
+  Obj.set_field x 1 (Obj.repr compare);
+  Obj.obj x
+
+external get_value : 'a t -> 'a = "%field0"
+external get_compare : 'a t -> 'a -> 'a -> int = "%field1"
diff --git a/stdlib/custom_value.mli b/stdlib/custom_value.mli
new file mode 100644
index 0000000..eda0d93
--- /dev/null
+++ b/stdlib/custom_value.mli
@@ -0,0 +1,29 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*                   Jérémie Dimino, jeremid@dimino.org                *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(** Value with custom comparison function *)
+
+type +'a t
+  (** Type of a value boxed with a comparison function *)
+
+val make : ('a -> 'a -> int) -> 'a -> 'a t
+  (** [make compare value] creates a custom value with the comparaison
+      function [compare]. With the resulting value will be compared to
+      another [compare] will be used. *)
+
+external get_value : 'a t -> 'a = "%field0"
+  (** [get_value x] returns the value of a custom value *)
+
+external get_compare : 'a t -> 'a -> 'a -> int = "%field1"
+  (** [get_compare x] returns the comparison function of a custom
+      value *)
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index 7073c3c..800d4f8 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -36,6 +36,7 @@ let marshal (obj : t) =
 let unmarshal str pos =
   (Marshal.from_string str pos, pos + Marshal.total_size str pos)
 
+let user_tag = 245
 let lazy_tag = 246
 let closure_tag = 247
 let object_tag = 248
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index f2fad04..9d9b796 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -34,6 +34,7 @@ external set_field : t -> int -> t -> unit = "%obj_set_field"
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 
+val user_tag : int
 val lazy_tag : int
 val closure_tag : int
 val object_tag : int
diff --git a/stdlib/stdlib.mllib b/stdlib/stdlib.mllib
index e4b57a1..3272112 100644
--- a/stdlib/stdlib.mllib
+++ b/stdlib/stdlib.mllib
@@ -13,6 +13,7 @@ CamlinternalMod
 CamlinternalOO
 Char
 Complex
+Custom_value
 Digest
 Filename
 Format
diff --git a/utils/config.mlp b/utils/config.mlp
index a30b456..e54f99b 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -52,7 +52,7 @@ let load_path = ref ([] : string list)
 
 let interface_suffix = ref ".mli"
 
-let max_tag = 245
+let max_tag = 244
 (* This is normally the same as in obj.ml, but we have to define it
    separately because it can differ when we're in the middle of a
    bootstrapping phase. *)

commit 4ce7aac1482221cebe3d6b6378ef00a99b2df886
Author: Jérémie Dimino <jeremie@dimino.org>
Date:   Mon Apr 27 14:56:56 2009 +0200

    Polymorphic maps and sets using blocks with custom compare

diff --git a/stdlib/map.ml b/stdlib/map.ml
index 84bcba6..87419d2 100644
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -13,38 +13,48 @@
 
 (* $Id: map.ml,v 1.17 2005-08-13 20:59:37 doligez Exp $ *)
 
-module type OrderedType =
+(* Common implementation *)
+
+type ('a, 'b) map =
+    Empty
+  | Node of ('a, 'b) map * 'a * 'b * ('a, 'b) map * int
+
+type ('a, 'b) enumeration = End | More of 'a * 'b * ('a, 'b) map * ('a, 'b) enumeration
+
+let rec cons_enum m e =
+  match m with
+      Empty -> e
+    | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+
+let compare_map compare_key compare_val m1 m2 =
+  let rec compare_aux e1 e2 =
+    match (e1, e2) with
+        (End, End) -> 0
+      | (End, _)  -> -1
+      | (_, End) -> 1
+      | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+          let c = compare_key v1 v2 in
+          if c <> 0 then c else
+            let c = compare_val d1 d2 in
+            if c <> 0 then c else
+              compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+  in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+module type WrapperType =
   sig
-    type t
-    val compare: t -> t -> int
+    type (+'a, +'b) t
+    val make : ('a, 'b) map -> ('a, 'b) t
+    val get : ('a, 'b) t -> ('a, 'b) map
   end
 
-module type S =
+module type PolyOrderedType =
   sig
-    type key
-    type +'a t
-    val empty: 'a t
-    val is_empty: 'a t -> bool
-    val add: key -> 'a -> 'a t -> 'a t
-    val find: key -> 'a t -> 'a
-    val remove: key -> 'a t -> 'a t
-    val mem:  key -> 'a t -> bool
-    val iter: (key -> 'a -> unit) -> 'a t -> unit
-    val map: ('a -> 'b) -> 'a t -> 'b t
-    val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
-    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
-    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
-    val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    type 'a key
+    val compare : 'a key -> 'a key -> int
   end
 
-module Make(Ord: OrderedType) = struct
-
-    type key = Ord.t
-
-    type 'a t =
-        Empty
-      | Node of 'a t * key * 'a * 'a t * int
-
+module PolyMake(Wrapper: WrapperType)(Ord: PolyOrderedType) =
+  struct
     let height = function
         Empty -> 0
       | Node(_,_,_,_,h) -> h
@@ -107,6 +117,14 @@ module Make(Ord: OrderedType) = struct
           if c = 0 then d
           else find x (if c < 0 then l else r)
 
+    let rec lookup x = function
+        Empty ->
+          None
+      | Node(l, v, d, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then Some d
+          else lookup x (if c < 0 then l else r)
+
     let rec mem x = function
         Empty ->
           false
@@ -163,26 +181,8 @@ module Make(Ord: OrderedType) = struct
       | Node(l, v, d, r, _) ->
           fold f r (f v d (fold f l accu))
 
-    type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
-
-    let rec cons_enum m e =
-      match m with
-        Empty -> e
-      | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
-
     let compare cmp m1 m2 =
-      let rec compare_aux e1 e2 =
-          match (e1, e2) with
-          (End, End) -> 0
-        | (End, _)  -> -1
-        | (_, End) -> 1
-        | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
-            let c = Ord.compare v1 v2 in
-            if c <> 0 then c else
-            let c = cmp d1 d2 in
-            if c <> 0 then c else
-            compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
-      in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+      compare_map Ord.compare cmp m1 m2
 
     let equal cmp m1 m2 =
       let rec equal_aux e1 e2 =
@@ -195,4 +195,78 @@ module Make(Ord: OrderedType) = struct
             equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
       in equal_aux (cons_enum m1 End) (cons_enum m2 End)
 
+    let empty = Wrapper.make empty
+    let is_empty m = is_empty (Wrapper.get m)
+    let add k v m = Wrapper.make (add k v (Wrapper.get m))
+    let find k m = find k (Wrapper.get m)
+    let lookup k m = lookup k (Wrapper.get m)
+    let remove k m = Wrapper.make (remove k (Wrapper.get m))
+    let mem k m = mem k (Wrapper.get m)
+    let iter f m = iter f (Wrapper.get m)
+    let map f m = Wrapper.make (map f (Wrapper.get m))
+    let mapi f m = Wrapper.make (mapi f (Wrapper.get m))
+    let fold f m x = fold f (Wrapper.get m) x
+    let compare cmp m1 m2 = compare cmp (Wrapper.get m1) (Wrapper.get m2)
+    let equal cmp m1 m2 = equal cmp (Wrapper.get m1) (Wrapper.get m2)
 end
+
+(* Functorized interface *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+module type S =
+  sig
+    type key
+    type +'a t
+    val empty: 'a t
+    val is_empty: 'a t -> bool
+    val add: key -> 'a -> 'a t -> 'a t
+    val find: key -> 'a t -> 'a
+    val lookup: key -> 'a t -> 'a option
+    val remove: key -> 'a t -> 'a t
+    val mem:  key -> 'a t -> bool
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+    val map: ('a -> 'b) -> 'a t -> 'b t
+    val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
+    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+  end
+
+module Make(Ord: OrderedType) =
+  struct
+    type key = Ord.t
+    type +'a t = (Ord.t, 'a) map
+    include PolyMake(struct
+                       type (+'a, +'b) t = (Ord.t, 'b) map
+                       external make : ('a, 'b) map -> ('a, 'b) t = "%identity"
+                       external get : ('a, 'b) t -> ('a, 'b) map = "%identity"
+                     end)
+                     (struct
+                        type 'a key = Ord.t
+                        let compare = Ord.compare
+                      end)
+  end
+
+(* De-functorized interface *)
+
+type ('a, 'b) t = ('a, 'b) map Custom_value.t
+
+let poly_compare m1 m2 = compare_map Pervasives.compare Pervasives.compare m1 m2
+
+include PolyMake(struct
+                   type (+'a, +'b) t = ('a, 'b) map Custom_value.t
+                   let make x = Custom_value.make poly_compare x
+                   let get x = Custom_value.get_value x
+                 end)
+                 (struct
+                    type 'a key = 'a
+                    let compare = Pervasives.compare
+                  end)
+
+let compare m1 m2 = compare Pervasives.compare m1 m2
+let equal m1 m2 = equal ( = ) m1 m2
diff --git a/stdlib/map.mli b/stdlib/map.mli
index 4e816e0..c51f296 100644
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -61,6 +61,10 @@ module type S =
     (** [find x m] returns the current binding of [x] in [m],
        or raises [Not_found] if no such binding exists. *)
 
+    val lookup: key -> 'a t -> 'a option
+    (** [find x m] returns the current binding of [x] in [m],
+       or [None] if no such binding exists. *)
+
     val remove: key -> 'a t -> 'a t
     (** [remove x m] returns a map containing the same bindings as
        [m], except for [x] which is unbound in the returned map. *)
@@ -109,3 +113,20 @@ module type S =
 module Make (Ord : OrderedType) : S with type key = Ord.t
 (** Functor building an implementation of the map structure
    given a totally ordered type. *)
+
+(** {6 Polymorphic maps} *)
+
+type (+'a, +'b) t
+val empty: ('a, 'b) t
+val is_empty: ('a, 'b) t -> bool
+val add: 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t
+val find: 'a -> ('a, 'b) t -> 'b
+val lookup: 'a -> ('a, 'b) t -> 'b option
+val remove: 'a -> ('a, 'b) t -> ('a, 'b) t
+val mem: 'a -> ('a, 'b) t -> bool
+val iter: ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+val map: ('a -> 'b) -> ('c, 'a) t -> ('c, 'b) t
+val mapi: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
+val fold: ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+val compare: ('a, 'b) t -> ('a, 'b) t -> int
+val equal: ('a, 'b) t -> ('a, 'b) t -> bool
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index 10c7464..5a5b7dd 100644
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -75,6 +75,7 @@ module Map : sig
       val is_empty: 'a t -> bool
       val add : key:key -> data:'a -> 'a t -> 'a t
       val find : key -> 'a t -> 'a
+      val lookup : key -> 'a t -> 'a option
       val remove : key -> 'a t -> 'a t
       val mem : key -> 'a t -> bool
       val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
diff --git a/stdlib/set.ml b/stdlib/set.ml
index a578d33..069dff6 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -13,48 +13,46 @@
 
 (* $Id: set.ml,v 1.19 2004-11-25 00:04:15 doligez Exp $ *)
 
-(* Sets over ordered types *)
+(* Common implementation *)
 
-module type OrderedType =
+type 'a set = Empty | Node of 'a set * 'a * 'a set * int
+
+type 'a enumeration = End | More of 'a * 'a set * 'a enumeration
+
+let rec cons_enum s e =
+  match s with
+      Empty -> e
+    | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
+
+let rec compare_aux compare e1 e2 =
+  match (e1, e2) with
+      (End, End) -> 0
+    | (End, _)  -> -1
+    | (_, End) -> 1
+    | (More(v1, r1, e1), More(v2, r2, e2)) ->
+        let c = compare v1 v2 in
+        if c <> 0
+        then c
+        else compare_aux compare (cons_enum r1 e1) (cons_enum r2 e2)
+
+let compare_set compare s1 s2 =
+  compare_aux compare (cons_enum s1 End) (cons_enum s2 End)
+
+module type WrapperType =
   sig
-    type t
-    val compare: t -> t -> int
+    type +'a t
+    val make : 'a set -> 'a t
+    val get : 'a t -> 'a set
   end
 
-module type S =
+module type PolyOrderedType =
   sig
-    type elt
-    type t
-    val empty: t
-    val is_empty: t -> bool
-    val mem: elt -> t -> bool
-    val add: elt -> t -> t
-    val singleton: elt -> t
-    val remove: elt -> t -> t
-    val union: t -> t -> t
-    val inter: t -> t -> t
-    val diff: t -> t -> t
-    val compare: t -> t -> int
-    val equal: t -> t -> bool
-    val subset: t -> t -> bool
-    val iter: (elt -> unit) -> t -> unit
-    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all: (elt -> bool) -> t -> bool
-    val exists: (elt -> bool) -> t -> bool
-    val filter: (elt -> bool) -> t -> t
-    val partition: (elt -> bool) -> t -> t * t
-    val cardinal: t -> int
-    val elements: t -> elt list
-    val min_elt: t -> elt
-    val max_elt: t -> elt
-    val choose: t -> elt
-    val split: elt -> t -> t * bool * t
+    type 'a elt
+    val compare : 'a elt -> 'a elt -> int
   end
 
-module Make(Ord: OrderedType) =
+module PolyMake(Wrapper: WrapperType)(Ord: PolyOrderedType) =
   struct
-    type elt = Ord.t
-    type t = Empty | Node of t * elt * t * int
 
     (* Sets are represented by balanced binary trees (the heights of the
        children differ by at most 2 *)
@@ -244,29 +242,11 @@ module Make(Ord: OrderedType) =
           | (l2, true, r2) ->
               concat (diff l1 l2) (diff r1 r2)
 
-    type enumeration = End | More of elt * t * enumeration
-
-    let rec cons_enum s e =
-      match s with
-        Empty -> e
-      | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
-
-    let rec compare_aux e1 e2 =
-        match (e1, e2) with
-        (End, End) -> 0
-      | (End, _)  -> -1
-      | (_, End) -> 1
-      | (More(v1, r1, e1), More(v2, r2, e2)) ->
-          let c = Ord.compare v1 v2 in
-          if c <> 0
-          then c
-          else compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
-
     let compare s1 s2 =
-      compare_aux (cons_enum s1 End) (cons_enum s2 End)
+      compare_set Ord.compare s1 s2
 
     let equal s1 s2 =
-      compare s1 s2 = 0
+      compare_set Ord.compare s1 s2 = 0
 
     let rec subset s1 s2 =
       match (s1, s2) with
@@ -327,4 +307,99 @@ module Make(Ord: OrderedType) =
 
     let choose = min_elt
 
+    (* Wrappers *)
+
+    let empty = Wrapper.make empty
+    let is_empty s = is_empty (Wrapper.get s)
+    let mem e s = mem e (Wrapper.get s)
+    let add e s = Wrapper.make (add e (Wrapper.get s))
+    let singleton e = Wrapper.make (singleton e)
+    let remove e s = Wrapper.make (remove e (Wrapper.get s))
+    let union s1 s2 = Wrapper.make (union (Wrapper.get s1) (Wrapper.get s2))
+    let inter s1 s2 = Wrapper.make (inter (Wrapper.get s1) (Wrapper.get s2))
+    let diff s1 s2 = Wrapper.make (diff (Wrapper.get s1) (Wrapper.get s2))
+    let compare s1 s2 = compare (Wrapper.get s1) (Wrapper.get s2)
+    let equal s1 s2 = equal (Wrapper.get s1) (Wrapper.get s2)
+    let subset s1 s2 = subset (Wrapper.get s1) (Wrapper.get s2)
+    let iter f s = iter f (Wrapper.get s)
+    let fold f s x = fold f (Wrapper.get s) x
+    let for_all f s = for_all f (Wrapper.get s)
+    let exists f s = exists f (Wrapper.get s)
+    let filter f s = Wrapper.make (filter f (Wrapper.get s))
+    let partition f s = let s1, s2 = partition f (Wrapper.get s) in (Wrapper.make s1, Wrapper.make s2)
+    let cardinal s = cardinal (Wrapper.get s)
+    let elements s = elements (Wrapper.get s)
+    let min_elt s = min_elt (Wrapper.get s)
+    let max_elt s = max_elt (Wrapper.get s)
+    let choose s = choose (Wrapper.get s)
+    let split e s = let s1, b, s2 = split e (Wrapper.get s) in (Wrapper.make s1, b, Wrapper.make s2)
   end
+
+(* Functorized interface *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+module type S =
+  sig
+    type elt
+    type t
+    val empty: t
+    val is_empty: t -> bool
+    val mem: elt -> t -> bool
+    val add: elt -> t -> t
+    val singleton: elt -> t
+    val remove: elt -> t -> t
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val compare: t -> t -> int
+    val equal: t -> t -> bool
+    val subset: t -> t -> bool
+    val iter: (elt -> unit) -> t -> unit
+    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all: (elt -> bool) -> t -> bool
+    val exists: (elt -> bool) -> t -> bool
+    val filter: (elt -> bool) -> t -> t
+    val partition: (elt -> bool) -> t -> t * t
+    val cardinal: t -> int
+    val elements: t -> elt list
+    val min_elt: t -> elt
+    val max_elt: t -> elt
+    val choose: t -> elt
+    val split: elt -> t -> t * bool * t
+  end
+
+module Make(Ord: OrderedType) =
+  struct
+    type elt = Ord.t
+    type t = Ord.t set
+    include PolyMake(struct
+                       type +'a t = Ord.t set
+                       external make : 'a set -> 'a t = "%identity"
+                       external get : 'a t -> 'a set = "%identity"
+                     end)
+                     (struct
+                        type 'a elt = Ord.t
+                        let compare = Ord.compare
+                      end)
+  end
+
+(* De-functorized interface *)
+
+type 'a t = 'a set Custom_value.t
+
+let poly_compare s1 s2 = compare_set Pervasives.compare s1 s2
+
+include PolyMake(struct
+                   type +'a t = 'a set Custom_value.t
+                   let make x = Custom_value.make poly_compare x
+                   let get x = Custom_value.get_value x
+                 end)
+                 (struct
+                    type 'a elt = 'a
+                    let compare = Pervasives.compare
+                  end)
diff --git a/stdlib/set.mli b/stdlib/set.mli
index c96e5bf..180d152 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -151,3 +151,31 @@ module type S =
 module Make (Ord : OrderedType) : S with type elt = Ord.t
 (** Functor building an implementation of the set structure
    given a totally ordered type. *)
+
+(** {6 Polymorphic sets} *)
+
+type +'a t
+val empty: 'a t
+val is_empty: 'a t -> bool
+val mem: 'a -> 'a t -> bool
+val add: 'a -> 'a t -> 'a t
+val singleton: 'a -> 'a t
+val remove: 'a -> 'a t -> 'a t
+val union: 'a t -> 'a t -> 'a t
+val inter: 'a t -> 'a t -> 'a t
+val diff: 'a t -> 'a t -> 'a t
+val compare: 'a t -> 'a t -> int
+val equal: 'a t -> 'a t -> bool
+val subset: 'a t -> 'a t -> bool
+val iter: ('a -> unit) -> 'a t -> unit
+val fold: ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+val for_all: ('a -> bool) -> 'a t -> bool
+val exists: ('a -> bool) -> 'a t -> bool
+val filter: ('a -> bool) -> 'a t -> 'a t
+val partition: ('a -> bool) -> 'a t -> 'a t * 'a t
+val cardinal: 'a t -> int
+val elements: 'a t -> 'a list
+val min_elt: 'a t -> 'a
+val max_elt: 'a t -> 'a
+val choose: 'a t -> 'a
+val split: 'a -> 'a t -> 'a t * bool * 'a t