Decoupage de stdlib/oo en stdlib/camlinternalOO et stdlib/oo. Petites modifs dans la compilation des classes pour reduire la taille du code genere

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4736 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

13 files changed, 607 insertions, 535 deletions

diff --git a/Makefile b/Makefile
index 93b0288da..10208f380 100644
--- a/Makefile
+++ b/Makefile
@@ -107,7 +107,8 @@ EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \
 
 PERVASIVES=arg array buffer callback char digest filename format gc hashtbl \
   lexing list map obj parsing pervasives printexc printf queue random \
-  set sort stack string stream sys oo genlex topdirs toploop weak lazy \
+  set sort stack string stream sys oo camlinternalOO \
+  genlex topdirs toploop weak lazy \
   marshal int32 int64 nativeint complex outcometree \
   arrayLabels listLabels stringLabels stdLabels moreLabels
 
diff --git a/boot/ocamlc b/boot/ocamlc
index 2ad1f5f4e..4436fee8b 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 8baed4885..69200dfcd 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 56b3af249..81e593950 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -91,14 +91,18 @@ let transl_super tbl meths inh_methods rem =
 let create_object cl obj init =
   let obj' = Ident.create "self" in
   let (inh_init, obj_init) = init obj' in
-  (inh_init,
-   Llet(Strict, obj', Lifthenelse(Lvar obj, Lvar obj,
-                                  Lapply (oo_prim "create_object", [Lvar cl])),
-        Lsequence(obj_init,
-        Lsequence(Lifthenelse(Lvar obj, lambda_unit,
-                              Lapply (oo_prim "run_initializers",
-                                      [Lvar obj'; Lvar cl])),
-                  Lvar obj'))))
+  if obj_init = lambda_unit then
+   (inh_init,
+    Lapply (oo_prim "create_object_and_run_initializers",
+            [Lvar obj; Lvar cl]))
+  else begin
+   (inh_init,
+    Llet(Strict, obj',
+            Lapply (oo_prim "create_object_opt", [Lvar obj; Lvar cl]),
+         Lsequence(obj_init,
+                  Lapply (oo_prim "run_initializers_opt",
+                          [Lvar obj; Lvar obj'; Lvar cl]))))
+  end
 
 let rec build_object_init cl_table obj params inh_init cl =
   match cl.cl_desc with
@@ -213,13 +217,18 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
             | Cf_val (name, id, exp) ->
                 (inh_init, transl_val cla true name id cl_init)
             | Cf_meth (name, exp) ->
-                let met = Ident.create ("method_" ^ name) in
+                let met_code =
+                  if !Clflags.native_code then begin
+                    (* Force correct naming of method for profiles *)
+                    let met = Ident.create ("method_" ^ name) in
+                    Llet(Strict, met, transl_exp exp, Lvar met)
+                  end else
+                    transl_exp exp in
                 (inh_init,
                  Lsequence(Lapply (oo_prim "set_method",
                                    [Lvar cla;
                                     Lvar (Meths.find name str.cl_meths);
-                                    Llet(Strict, met, transl_exp exp,
-                                         Lvar met)]),
+                                    met_code]),
                            cl_init))
             | Cf_let (rec_flag, defs, vals) ->
                 let vals =
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index a9a3f76ef..20794b1f4 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -22,7 +22,7 @@ open Lambda
 let oo_prim name =
   try
     transl_path
-      (fst (Env.lookup_value (Ldot (Lident "Oo", name)) Env.empty))
+      (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty))
   with Not_found ->
     fatal_error ("Primitive " ^ name ^ " not found.")
 
diff --git a/stdlib/.depend b/stdlib/.depend
index 4e9fe9cf9..a527b1a60 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -6,22 +6,26 @@ printf.cmi: buffer.cmi
 weak.cmi: hashtbl.cmi 
 arg.cmo: array.cmi list.cmi printf.cmi string.cmi sys.cmi arg.cmi 
 arg.cmx: array.cmx list.cmx printf.cmx string.cmx sys.cmx arg.cmi 
-array.cmo: array.cmi 
-array.cmx: array.cmi 
 arrayLabels.cmo: array.cmi arrayLabels.cmi 
 arrayLabels.cmx: array.cmx arrayLabels.cmi 
+array.cmo: array.cmi 
+array.cmx: array.cmi 
 buffer.cmo: string.cmi sys.cmi buffer.cmi 
 buffer.cmx: string.cmx sys.cmx buffer.cmi 
 callback.cmo: obj.cmi callback.cmi 
 callback.cmx: obj.cmx callback.cmi 
+camlinternalOO.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi \
+    sort.cmi sys.cmi camlinternalOO.cmi 
+camlinternalOO.cmx: array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx \
+    sort.cmx sys.cmx camlinternalOO.cmi 
 char.cmo: char.cmi 
 char.cmx: char.cmi 
 complex.cmo: complex.cmi 
 complex.cmx: complex.cmi 
 digest.cmo: printf.cmi string.cmi digest.cmi 
 digest.cmx: printf.cmx string.cmx digest.cmi 
-filename.cmo: buffer.cmi string.cmi sys.cmi filename.cmi 
-filename.cmx: buffer.cmx string.cmx sys.cmx filename.cmi 
+filename.cmo: buffer.cmi printf.cmi string.cmi sys.cmi filename.cmi 
+filename.cmx: buffer.cmx printf.cmx string.cmx sys.cmx filename.cmi 
 format.cmo: buffer.cmi list.cmi obj.cmi printf.cmi string.cmi format.cmi 
 format.cmx: buffer.cmx list.cmx obj.cmx printf.cmx string.cmx format.cmi 
 gc.cmo: printf.cmi sys.cmi gc.cmi 
@@ -36,12 +40,12 @@ int64.cmo: int32.cmi obj.cmi int64.cmi
 int64.cmx: int32.cmx obj.cmx int64.cmi 
 lazy.cmo: obj.cmi lazy.cmi 
 lazy.cmx: obj.cmx lazy.cmi 
-lexing.cmo: string.cmi lexing.cmi 
-lexing.cmx: string.cmx lexing.cmi 
-list.cmo: array.cmi list.cmi 
-list.cmx: array.cmx list.cmi 
+lexing.cmo: string.cmi sys.cmi lexing.cmi 
+lexing.cmx: string.cmx sys.cmx lexing.cmi 
 listLabels.cmo: list.cmi listLabels.cmi 
 listLabels.cmx: list.cmx listLabels.cmi 
+list.cmo: array.cmi list.cmi 
+list.cmx: array.cmx list.cmi 
 map.cmo: map.cmi 
 map.cmx: map.cmi 
 marshal.cmo: string.cmi marshal.cmi 
@@ -52,10 +56,8 @@ nativeint.cmo: sys.cmi nativeint.cmi
 nativeint.cmx: sys.cmx nativeint.cmi 
 obj.cmo: marshal.cmi obj.cmi 
 obj.cmx: marshal.cmx obj.cmi 
-oo.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi sort.cmi \
-    sys.cmi oo.cmi 
-oo.cmx: array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx sort.cmx \
-    sys.cmx oo.cmi 
+oo.cmo: camlinternalOO.cmi oo.cmi 
+oo.cmx: camlinternalOO.cmx oo.cmi 
 parsing.cmo: array.cmi lexing.cmi obj.cmi parsing.cmi 
 parsing.cmx: array.cmx lexing.cmx obj.cmx parsing.cmi 
 pervasives.cmo: pervasives.cmi 
@@ -78,10 +80,10 @@ stdLabels.cmo: arrayLabels.cmi listLabels.cmi stringLabels.cmi stdLabels.cmi
 stdLabels.cmx: arrayLabels.cmx listLabels.cmx stringLabels.cmx stdLabels.cmi 
 stream.cmo: list.cmi obj.cmi string.cmi stream.cmi 
 stream.cmx: list.cmx obj.cmx string.cmx stream.cmi 
-string.cmo: char.cmi list.cmi string.cmi 
-string.cmx: char.cmx list.cmx string.cmi 
 stringLabels.cmo: string.cmi stringLabels.cmi 
 stringLabels.cmx: string.cmx stringLabels.cmi 
+string.cmo: char.cmi list.cmi string.cmi 
+string.cmx: char.cmx list.cmx string.cmi 
 sys.cmo: sys.cmi 
 sys.cmx: sys.cmi 
 weak.cmo: array.cmi hashtbl.cmi obj.cmi sys.cmi weak.cmi 
diff --git a/stdlib/Makefile b/stdlib/Makefile
index bc26ada1b..b8d0f1bb1 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -29,7 +29,8 @@ BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
   lexing.cmo parsing.cmo \
   set.cmo map.cmo stack.cmo queue.cmo stream.cmo \
   buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo \
-  digest.cmo random.cmo oo.cmo genlex.cmo callback.cmo weak.cmo \
+  digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
+  genlex.cmo callback.cmo weak.cmo \
   lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo complex.cmo
 LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
 
@@ -104,9 +105,9 @@ pervasives.p.cmx: pervasives.ml
 	@if test -f pervasives.n.cmx; then mv pervasives.n.cmx pervasives.cmx; else :; fi
 	@if test -f pervasives.n.o; then mv pervasives.n.o pervasives.o; else :; fi
 
-# oo.cmi must be compiled with -nopervasives for applets
-oo.cmi: oo.mli
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c oo.mli
+# camlinternalOO.cmi must be compiled with -nopervasives for applets
+camlinternalOO.cmi: camlinternalOO.mli
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
 
 # labelled modules require the -nolabels flag
 labelled.cmo:
diff --git a/stdlib/Makefile.Mac b/stdlib/Makefile.Mac
index 45bd2326c..8b4e4ee0c 100644
--- a/stdlib/Makefile.Mac
+++ b/stdlib/Makefile.Mac
@@ -23,7 +23,8 @@ OBJS = pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo ¶
   lexing.cmo parsing.cmo ¶
   set.cmo map.cmo stack.cmo queue.cmo stream.cmo ¶
   buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo ¶
-  digest.cmo random.cmo oo.cmo genlex.cmo callback.cmo weak.cmo ¶
+  digest.cmo random.cmo oo.cmo camlInternal.cmo ¶
+  genlex.cmo callback.cmo weak.cmo ¶
   lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo complex.cmo
 
 all Ä stdlib.cma std_exit.cmo camlheader camlheader_ur
@@ -54,9 +55,9 @@ pervasives.cmi Ä pervasives.mli
 pervasives.cmo Ä pervasives.ml
     {CAMLC} {COMPFLAGS} -nopervasives -c pervasives.ml
 
-# oo.cmi must be compiled with -nopervasives for applets
-oo.cmi Ä oo.mli
-    {CAMLC} {COMPFLAGS} -nopervasives -c oo.mli
+# camlinternalOO.cmi must be compiled with -nopervasives for applets
+camlinternalOO.cmi Ä camlinternalOO.mli
+    {CAMLC} {COMPFLAGS} -nopervasives -c camlinternalOO.mli
 
 .cmi Ä .mli
     {CAMLC} {COMPFLAGS} -c {default}.mli
diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
index c16e0657f..ad9c4821e 100644
--- a/stdlib/Makefile.nt
+++ b/stdlib/Makefile.nt
@@ -27,7 +27,8 @@ BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
   lexing.cmo parsing.cmo \
   set.cmo map.cmo stack.cmo queue.cmo stream.cmo \
   buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo \
-  digest.cmo random.cmo oo.cmo genlex.cmo callback.cmo weak.cmo \
+  digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
+  genlex.cmo callback.cmo weak.cmo \
   lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo complex.cmo
 LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
 
@@ -66,9 +67,9 @@ pervasives.cmo: pervasives.ml
 pervasives.cmx: pervasives.ml
 	$(CAMLOPT) $(COMPFLAGS) -nopervasives -c pervasives.ml
 
-# oo.cmi must be compiled with -nopervasives for applets
-oo.cmi: oo.mli
-	$(CAMLC) $(COMPFLAGS) -nopervasives -c oo.mli
+# camlinternalOO.cmi must be compiled with -nopervasives for applets
+camlinternalOO.cmi: camlinternalOO.mli
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
 
 # labelled modules require the -nolabels flag
 labelled.cmo:
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
new file mode 100644
index 000000000..a87769ac7
--- /dev/null
+++ b/stdlib/camlinternalOO.ml
@@ -0,0 +1,476 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 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.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Obj
+
+(**** Object representation ****)
+
+let last_id = ref 0
+let new_id () =
+  let id = !last_id in incr last_id; id
+
+let set_id o id =
+  let id0 = !id in
+  Array.unsafe_set (Obj.magic o : int array) 1 id0;
+  id := id0 + 1
+
+(**** Object copy ****)
+
+let copy o =
+  let o = (Obj.obj (Obj.dup (Obj.repr o))) in
+  set_id o last_id;
+  o
+
+(**** Compression options ****)
+(* Parameters *)
+type params = {
+    mutable compact_table : bool;
+    mutable copy_parent : bool;
+    mutable clean_when_copying : bool;
+    mutable retry_count : int;
+    mutable bucket_small_size : int
+  } 
+
+let params = {
+  compact_table = true;
+  copy_parent = true;
+  clean_when_copying = true;
+  retry_count = 3;
+  bucket_small_size = 16
+} 
+
+(**** Parameters ****)
+
+let step = Sys.word_size / 16
+let first_bucket = 0
+let bucket_size = 32                    (* Must be 256 or less *)
+let initial_object_size = 2
+
+(**** Index ****)
+
+type label = int
+
+let label_count = ref 0
+
+let next label =
+  incr label_count;
+  let label = label + step in
+  if label mod (step * bucket_size) = 0 then
+    label + step * (65536 - bucket_size)
+  else
+    label
+
+let decode label =
+  (label / 65536 / step, (label mod (step * bucket_size)) / step)
+
+(**** Items ****)
+
+type item
+
+let dummy_item = (magic () : item)
+
+(**** Buckets ****)
+
+type bucket = item array
+
+let version = ref 0
+
+let set_bucket_version (bucket : bucket) =
+  bucket.(bucket_size) <- (magic !version : item)
+
+let bucket_version bucket =
+  (magic bucket.(bucket_size) : int)
+
+let bucket_list = ref []
+
+let empty_bucket = [| |]
+
+let new_bucket () =
+  let bucket = Array.create (bucket_size + 1) dummy_item in
+  set_bucket_version bucket;
+  bucket_list := bucket :: !bucket_list;
+  bucket
+
+let copy_bucket bucket =
+  let bucket = Array.copy bucket in
+  set_bucket_version bucket;
+  bucket.(bucket_size) <- (magic !version : item);
+  bucket_list := bucket :: !bucket_list;
+  bucket
+
+(**** Make a clean bucket ****)
+
+let new_filled_bucket pos methods =
+  let bucket = new_bucket () in
+  List.iter
+    (fun (lab, met) ->
+       let (buck, elem) = decode lab in
+       if buck = pos then
+         bucket.(elem) <- (magic met : item))
+    (List.rev methods);
+  bucket
+
+(**** Bucket merging ****)
+
+let small_buckets = ref (Array.create 10 [| |])
+let small_bucket_count = ref 0
+
+let insert_bucket bucket =
+  let length = Array.length !small_buckets in
+  if !small_bucket_count >= length then begin
+    let new_array = Array.create (2 * length) [| |] in
+    Array.blit !small_buckets 0 new_array 0 length;
+    small_buckets := new_array
+  end;
+  !small_buckets.(!small_bucket_count) <- bucket;
+  incr small_bucket_count
+
+let remove_bucket n =
+  !small_buckets.(n) <- !small_buckets.(!small_bucket_count - 1);
+  decr small_bucket_count
+
+let bucket_used b =
+  let n = ref 0 in
+  for i = 0 to bucket_size - 1 do
+    if b.(i) != dummy_item then incr n
+  done;
+  !n
+
+let small_bucket b = bucket_used b <= params.bucket_small_size
+
+exception Failed
+
+let rec except e =
+  function
+    [] -> []
+  | e'::l -> if e == e' then l else e'::(except e l)
+
+let merge_buckets b1 b2 =
+  for i = 0 to bucket_size - 1 do
+    if
+      (b2.(i) != dummy_item) && (b1.(i) != dummy_item) && (b2.(i) != b1.(i))
+    then
+      raise Failed
+  done;
+  for i = 0 to bucket_size - 1 do
+    if b2.(i) != dummy_item then
+      b1.(i) <- b2.(i)
+  done;
+  bucket_list := except b2 !bucket_list;
+  b1
+
+let rec choose bucket i =
+  if (i > 0) && (!small_bucket_count > 0) then begin
+    let n = Random.int !small_bucket_count in
+    if not (small_bucket !small_buckets.(n)) then begin
+      remove_bucket n; choose bucket i
+    end else
+      try
+        merge_buckets !small_buckets.(n) bucket
+      with Failed ->
+        choose bucket (i - 1)
+  end else begin
+    insert_bucket bucket;
+    bucket
+  end
+
+let compact b =
+  if
+    (b != empty_bucket) && (bucket_version b = !version) && (small_bucket b)
+  then
+    choose b params.retry_count
+  else
+    b
+
+let compact_buckets buckets =
+  for i = first_bucket to Array.length buckets - 1 do
+    buckets.(i) <- compact buckets.(i)
+  done
+
+(**** Labels ****)
+
+let first_label = first_bucket * 65536 * step
+
+let last_label = ref first_label
+let methods = Hashtbl.create 101
+
+let new_label () =
+  let label = !last_label in
+  last_label := next !last_label;
+  label
+
+let new_method met =
+  try
+    Hashtbl.find methods met
+  with Not_found ->
+    let label = new_label () in
+    Hashtbl.add methods met label;
+    label
+
+let new_anonymous_method =
+  new_label
+
+(**** Types ****)
+
+type obj = t array
+
+(**** Sparse array ****)
+
+module Vars = Map.Make(struct type t = string let compare = compare end)
+type vars = int Vars.t
+
+module Meths = Map.Make(struct type t = string let compare = compare end)
+type meths = label Meths.t
+module Labs = Map.Make(struct type t = label let compare = compare end)
+type labs = bool Labs.t
+
+(* The compiler assumes that the first field of this structure is [size]. *)
+type table =
+ { mutable size: int;
+   mutable buckets: bucket array;
+   mutable methods_by_name: meths;
+   mutable methods_by_label: labs;
+   mutable previous_states:
+     (meths * labs * (label * item) list * vars *
+      label list * string list) list;
+   mutable hidden_meths: (label * item) list;
+   mutable vars: vars;
+   mutable initializers: (obj -> unit) list }
+
+let table_count = ref 0
+
+let new_table () =
+  incr table_count;
+  { buckets = [| |];
+    methods_by_name = Meths.empty;
+    methods_by_label = Labs.empty;
+    previous_states = [];
+    hidden_meths = [];
+    vars = Vars.empty;
+    initializers = [];
+    size = initial_object_size }
+
+let resize array new_size =
+  let old_size = Array.length array.buckets in
+  if new_size > old_size then begin
+    let new_buck = Array.create new_size empty_bucket in
+    Array.blit array.buckets 0 new_buck 0 old_size;
+    array.buckets <- new_buck
+ end
+
+let put array label element =
+  let (buck, elem) = decode label in
+  resize array (buck + 1);
+  let bucket = ref (array.buckets.(buck)) in
+  if !bucket == empty_bucket then begin
+    bucket := new_bucket ();
+    array.buckets.(buck) <- !bucket
+  end;
+  !bucket.(elem) <- element
+
+(**** Classes ****)
+
+let method_count = ref 0
+let inst_var_count = ref 0
+
+type t
+type meth = item
+
+let get_method_label table name =
+  try
+    Meths.find name table.methods_by_name
+  with Not_found ->
+    let label = new_anonymous_method () in
+    table.methods_by_name <- Meths.add name label table.methods_by_name;
+    table.methods_by_label <- Labs.add label true table.methods_by_label;
+    label
+
+let set_method table label element =
+  incr method_count;
+  if Labs.find label table.methods_by_label then
+    put table label element
+  else
+    table.hidden_meths <- (label, element) :: table.hidden_meths
+
+let get_method table label =
+  try List.assoc label table.hidden_meths with Not_found ->
+  let (buck, elem) = decode label in
+  table.buckets.(buck).(elem)
+
+let narrow table vars virt_meths concr_meths =
+  let virt_meth_labs = List.map (get_method_label table) virt_meths in
+  let concr_meth_labs = List.map (get_method_label table) concr_meths in
+  table.previous_states <-
+     (table.methods_by_name, table.methods_by_label, table.hidden_meths,
+      table.vars, virt_meth_labs, vars)
+     :: table.previous_states;
+  table.vars <- Vars.empty;
+  let by_name = ref Meths.empty in
+  let by_label = ref Labs.empty in
+  List.iter2
+    (fun met label ->
+       by_name := Meths.add met label !by_name;
+       by_label :=
+          Labs.add label
+            (try Labs.find label table.methods_by_label with Not_found -> true)
+            !by_label)
+    concr_meths concr_meth_labs;
+  List.iter2
+    (fun met label ->
+       by_name := Meths.add met label !by_name;
+       by_label := Labs.add label false !by_label)
+    virt_meths virt_meth_labs;
+  table.methods_by_name <- !by_name;
+  table.methods_by_label <- !by_label;
+  table.hidden_meths <-
+     List.fold_right
+       (fun ((lab, _) as met) hm ->
+          if List.mem lab virt_meth_labs then hm else met::hm)
+       table.hidden_meths
+       []
+
+let widen table =
+  let (by_name, by_label, saved_hidden_meths, saved_vars, virt_meths, vars) =
+    List.hd table.previous_states
+  in
+  table.previous_states <- List.tl table.previous_states;
+  table.vars <-
+     List.fold_left
+       (fun s v -> Vars.add v (Vars.find v table.vars) s)
+       saved_vars vars;
+  table.methods_by_name <- by_name;
+  table.methods_by_label <- by_label;
+  table.hidden_meths <-
+     List.fold_right
+       (fun ((lab, _) as met) hm ->
+          if List.mem lab virt_meths then hm else met::hm)
+       table.hidden_meths
+       saved_hidden_meths
+
+let new_slot table =
+  let index = table.size in
+  table.size <- index + 1;
+  index
+
+let new_variable table name =
+  let index = new_slot table in
+  table.vars <- Vars.add name index table.vars;
+  index
+
+let get_variable table name =
+  Vars.find name table.vars
+
+let add_initializer table f =
+  table.initializers <- f::table.initializers
+
+let create_table public_methods =
+  let table = new_table () in
+  List.iter
+    (function met ->
+       let lab = new_method met in
+       table.methods_by_name  <- Meths.add met lab table.methods_by_name;
+       table.methods_by_label <- Labs.add lab true table.methods_by_label)
+    public_methods;
+  table
+
+let init_class table =
+  inst_var_count := !inst_var_count + table.size - 1;
+  if params.compact_table then
+    compact_buckets table.buckets;
+  table.initializers <- List.rev table.initializers
+
+(**** Objects ****)
+
+let create_object table =
+  (* XXX Appel de [obj_block] *)
+  let obj = Obj.new_block Obj.object_tag table.size in
+  (* XXX Appel de [modify] *)
+  Obj.set_field obj 0 (Obj.repr table.buckets);
+  set_id obj last_id;
+  (Obj.obj obj)
+
+let create_object_opt obj_0 table =
+  if (Obj.magic obj_0 : bool) then obj_0 else begin
+    (* XXX Appel de [obj_block] *)
+    let obj = Obj.new_block Obj.object_tag table.size in
+    (* XXX Appel de [modify] *)
+    Obj.set_field obj 0 (Obj.repr table.buckets);
+    set_id obj last_id;
+    (Obj.obj obj)
+  end
+
+let rec iter_f obj =
+  function
+    []   -> ()
+  | f::l -> f obj; iter_f obj l
+
+let run_initializers obj table =
+  let inits = table.initializers in
+  if inits <> [] then
+    iter_f obj inits
+
+let run_initializers_opt obj_0 obj table =
+  if (Obj.magic obj_0 : bool) then obj else begin
+    let inits = table.initializers in
+    if inits <> [] then iter_f obj inits;
+    obj
+  end
+
+let create_object_and_run_initializers obj_0 table =
+  if (Obj.magic obj_0 : bool) then obj_0 else begin
+    let obj = create_object table in
+    run_initializers obj table;
+    obj
+  end
+
+let send obj lab =
+  let (buck, elem) = decode lab in
+  (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
+
+(**** Statistics ****)
+
+type stats =
+  { classes: int; labels: int; methods: int; inst_vars: int; buckets: int;
+    distrib : int array; small_bucket_count: int; small_bucket_max: int }
+
+let distrib () =
+  let d = Array.create 32 0 in
+  List.iter
+    (function b ->
+       let n = bucket_used b in
+       d.(n - 1) <- d.(n - 1) + 1)
+    !bucket_list;
+  d
+
+let stats () =
+  { classes = !table_count; labels = !label_count;
+    methods = !method_count; inst_vars = !inst_var_count;
+    buckets = List.length !bucket_list; distrib = distrib ();
+    small_bucket_count = !small_bucket_count;
+    small_bucket_max = Array.length !small_buckets  }
+
+let sort_buck lst =
+  List.map snd
+    (Sort.list (fun (n, _) (n', _) -> n <= n')
+       (List.map (function b -> (bucket_used b, b)) lst))
+
+let show_buckets () =
+  List.iter
+    (function b ->
+       for i = 0 to bucket_size - 1 do
+         print_char (if b.(i) == dummy_item then '.' else '*')
+       done;
+       print_newline ())
+    (sort_buck !bucket_list)
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
new file mode 100644
index 000000000..5ab7280ae
--- /dev/null
+++ b/stdlib/camlinternalOO.mli
@@ -0,0 +1,75 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  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.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Run-time support for objects and classes.
+    All functions in this module are for system use only, not for the
+    casual user. *)
+
+(** {6 Methods} *)
+
+type label
+val new_method : string -> label
+
+(** {6 Classes} *)
+
+type table
+type meth
+type t
+type obj
+val new_variable : table -> string -> int
+val get_variable : table -> string -> int
+val get_method_label : table -> string -> label
+val get_method : table -> label -> meth
+val set_method : table -> label -> meth -> unit
+val narrow : table -> string list -> string list -> string list -> unit
+val widen : table -> unit
+val add_initializer : table -> (obj -> unit) -> unit
+val create_table : string list -> table
+val init_class : table -> unit
+
+(** {6 Objects} *)
+
+val copy : (< .. > as 'a) -> 'a
+val create_object : table -> obj
+val create_object_opt : obj -> table -> obj
+val run_initializers : obj -> table -> unit
+val run_initializers_opt : obj -> obj -> table -> obj
+val create_object_and_run_initializers : obj -> table -> obj
+val send : obj -> label -> t
+
+(** {6 Parameters} *)
+
+type params =
+  { mutable compact_table : bool;
+    mutable copy_parent : bool;
+    mutable clean_when_copying : bool;
+    mutable retry_count : int;
+    mutable bucket_small_size : int }
+
+val params : params
+
+(** {6 Statistics} *)
+
+type stats =
+  { classes : int; 
+    labels : int; 
+    methods : int; 
+    inst_vars : int; 
+    buckets : int;
+    distrib : int array; 
+    small_bucket_count : int; 
+    small_bucket_max : int }
+val stats : unit -> stats
+val show_buckets : unit -> unit
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index d5f4f96b9..c660019b1 100644
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -13,440 +13,4 @@
 
 (* $Id$ *)
 
-open Obj
-
-(**** Object representation ****)
-
-let last_id = ref 0
-let new_id () =
-  let id = !last_id in incr last_id; id
-
-let set_id o id =
-  let id0 = !id in
-  Array.unsafe_set (Obj.magic o : int array) 1 id0;
-  id := id0 + 1
-
-(**** Object copy ****)
-
-let copy o =
-  let o = (Obj.obj (Obj.dup (Obj.repr o))) in
-  set_id o last_id;
-  o
-
-(**** Compression options ****)
-(* Parameters *)
-type params = {
-    mutable compact_table : bool;
-    mutable copy_parent : bool;
-    mutable clean_when_copying : bool;
-    mutable retry_count : int;
-    mutable bucket_small_size : int
-  } 
-
-let params = {
-  compact_table = true;
-  copy_parent = true;
-  clean_when_copying = true;
-  retry_count = 3;
-  bucket_small_size = 16
-} 
-
-(**** Parameters ****)
-
-let step = Sys.word_size / 16
-let first_bucket = 0
-let bucket_size = 32                    (* Must be 256 or less *)
-let initial_object_size = 2
-
-(**** Index ****)
-
-type label = int
-
-let label_count = ref 0
-
-let next label =
-  incr label_count;
-  let label = label + step in
-  if label mod (step * bucket_size) = 0 then
-    label + step * (65536 - bucket_size)
-  else
-    label
-
-let decode label =
-  (label / 65536 / step, (label mod (step * bucket_size)) / step)
-
-(**** Items ****)
-
-type item
-
-let dummy_item = (magic () : item)
-
-(**** Buckets ****)
-
-type bucket = item array
-
-let version = ref 0
-
-let set_bucket_version (bucket : bucket) =
-  bucket.(bucket_size) <- (magic !version : item)
-
-let bucket_version bucket =
-  (magic bucket.(bucket_size) : int)
-
-let bucket_list = ref []
-
-let empty_bucket = [| |]
-
-let new_bucket () =
-  let bucket = Array.create (bucket_size + 1) dummy_item in
-  set_bucket_version bucket;
-  bucket_list := bucket :: !bucket_list;
-  bucket
-
-let copy_bucket bucket =
-  let bucket = Array.copy bucket in
-  set_bucket_version bucket;
-  bucket.(bucket_size) <- (magic !version : item);
-  bucket_list := bucket :: !bucket_list;
-  bucket
-
-(**** Make a clean bucket ****)
-
-let new_filled_bucket pos methods =
-  let bucket = new_bucket () in
-  List.iter
-    (fun (lab, met) ->
-       let (buck, elem) = decode lab in
-       if buck = pos then
-         bucket.(elem) <- (magic met : item))
-    (List.rev methods);
-  bucket
-
-(**** Bucket merging ****)
-
-let small_buckets = ref (Array.create 10 [| |])
-let small_bucket_count = ref 0
-
-let insert_bucket bucket =
-  let length = Array.length !small_buckets in
-  if !small_bucket_count >= length then begin
-    let new_array = Array.create (2 * length) [| |] in
-    Array.blit !small_buckets 0 new_array 0 length;
-    small_buckets := new_array
-  end;
-  !small_buckets.(!small_bucket_count) <- bucket;
-  incr small_bucket_count
-
-let remove_bucket n =
-  !small_buckets.(n) <- !small_buckets.(!small_bucket_count - 1);
-  decr small_bucket_count
-
-let bucket_used b =
-  let n = ref 0 in
-  for i = 0 to bucket_size - 1 do
-    if b.(i) != dummy_item then incr n
-  done;
-  !n
-
-let small_bucket b = bucket_used b <= params.bucket_small_size
-
-exception Failed
-
-let rec except e =
-  function
-    [] -> []
-  | e'::l -> if e == e' then l else e'::(except e l)
-
-let merge_buckets b1 b2 =
-  for i = 0 to bucket_size - 1 do
-    if
-      (b2.(i) != dummy_item) && (b1.(i) != dummy_item) && (b2.(i) != b1.(i))
-    then
-      raise Failed
-  done;
-  for i = 0 to bucket_size - 1 do
-    if b2.(i) != dummy_item then
-      b1.(i) <- b2.(i)
-  done;
-  bucket_list := except b2 !bucket_list;
-  b1
-
-let rec choose bucket i =
-  if (i > 0) && (!small_bucket_count > 0) then begin
-    let n = Random.int !small_bucket_count in
-    if not (small_bucket !small_buckets.(n)) then begin
-      remove_bucket n; choose bucket i
-    end else
-      try
-        merge_buckets !small_buckets.(n) bucket
-      with Failed ->
-        choose bucket (i - 1)
-  end else begin
-    insert_bucket bucket;
-    bucket
-  end
-
-let compact b =
-  if
-    (b != empty_bucket) && (bucket_version b = !version) && (small_bucket b)
-  then
-    choose b params.retry_count
-  else
-    b
-
-let compact_buckets buckets =
-  for i = first_bucket to Array.length buckets - 1 do
-    buckets.(i) <- compact buckets.(i)
-  done
-
-(**** Labels ****)
-
-let first_label = first_bucket * 65536 * step
-
-let last_label = ref first_label
-let methods = Hashtbl.create 101
-
-let new_label () =
-  let label = !last_label in
-  last_label := next !last_label;
-  label
-
-let new_method met =
-  try
-    Hashtbl.find methods met
-  with Not_found ->
-    let label = new_label () in
-    Hashtbl.add methods met label;
-    label
-
-let new_anonymous_method =
-  new_label
-
-(**** Types ****)
-
-type obj = t array
-
-(**** Sparse array ****)
-
-module Vars = Map.Make(struct type t = string let compare = compare end)
-type vars = int Vars.t
-
-module Meths = Map.Make(struct type t = string let compare = compare end)
-type meths = label Meths.t
-module Labs = Map.Make(struct type t = label let compare = compare end)
-type labs = bool Labs.t
-
-(* The compiler assumes that the first field of this structure is [size]. *)
-type table =
- { mutable size: int;
-   mutable buckets: bucket array;
-   mutable methods_by_name: meths;
-   mutable methods_by_label: labs;
-   mutable previous_states:
-     (meths * labs * (label * item) list * vars *
-      label list * string list) list;
-   mutable hidden_meths: (label * item) list;
-   mutable vars: vars;
-   mutable initializers: (obj -> unit) list }
-
-let table_count = ref 0
-
-let new_table () =
-  incr table_count;
-  { buckets = [| |];
-    methods_by_name = Meths.empty;
-    methods_by_label = Labs.empty;
-    previous_states = [];
-    hidden_meths = [];
-    vars = Vars.empty;
-    initializers = [];
-    size = initial_object_size }
-
-let resize array new_size =
-  let old_size = Array.length array.buckets in
-  if new_size > old_size then begin
-    let new_buck = Array.create new_size empty_bucket in
-    Array.blit array.buckets 0 new_buck 0 old_size;
-    array.buckets <- new_buck
- end
-
-let put array label element =
-  let (buck, elem) = decode label in
-  resize array (buck + 1);
-  let bucket = ref (array.buckets.(buck)) in
-  if !bucket == empty_bucket then begin
-    bucket := new_bucket ();
-    array.buckets.(buck) <- !bucket
-  end;
-  !bucket.(elem) <- element
-
-(**** Classes ****)
-
-let method_count = ref 0
-let inst_var_count = ref 0
-
-type t
-type meth = item
-
-let get_method_label table name =
-  try
-    Meths.find name table.methods_by_name
-  with Not_found ->
-    let label = new_anonymous_method () in
-    table.methods_by_name <- Meths.add name label table.methods_by_name;
-    table.methods_by_label <- Labs.add label true table.methods_by_label;
-    label
-
-let set_method table label element =
-  incr method_count;
-  if Labs.find label table.methods_by_label then
-    put table label element
-  else
-    table.hidden_meths <- (label, element) :: table.hidden_meths
-
-let get_method table label =
-  try List.assoc label table.hidden_meths with Not_found ->
-  let (buck, elem) = decode label in
-  table.buckets.(buck).(elem)
-
-let narrow table vars virt_meths concr_meths =
-  let virt_meth_labs = List.map (get_method_label table) virt_meths in
-  let concr_meth_labs = List.map (get_method_label table) concr_meths in
-  table.previous_states <-
-     (table.methods_by_name, table.methods_by_label, table.hidden_meths,
-      table.vars, virt_meth_labs, vars)
-     :: table.previous_states;
-  table.vars <- Vars.empty;
-  let by_name = ref Meths.empty in
-  let by_label = ref Labs.empty in
-  List.iter2
-    (fun met label ->
-       by_name := Meths.add met label !by_name;
-       by_label :=
-          Labs.add label
-            (try Labs.find label table.methods_by_label with Not_found -> true)
-            !by_label)
-    concr_meths concr_meth_labs;
-  List.iter2
-    (fun met label ->
-       by_name := Meths.add met label !by_name;
-       by_label := Labs.add label false !by_label)
-    virt_meths virt_meth_labs;
-  table.methods_by_name <- !by_name;
-  table.methods_by_label <- !by_label;
-  table.hidden_meths <-
-     List.fold_right
-       (fun ((lab, _) as met) hm ->
-          if List.mem lab virt_meth_labs then hm else met::hm)
-       table.hidden_meths
-       []
-
-let widen table =
-  let (by_name, by_label, saved_hidden_meths, saved_vars, virt_meths, vars) =
-    List.hd table.previous_states
-  in
-  table.previous_states <- List.tl table.previous_states;
-  table.vars <-
-     List.fold_left
-       (fun s v -> Vars.add v (Vars.find v table.vars) s)
-       saved_vars vars;
-  table.methods_by_name <- by_name;
-  table.methods_by_label <- by_label;
-  table.hidden_meths <-
-     List.fold_right
-       (fun ((lab, _) as met) hm ->
-          if List.mem lab virt_meths then hm else met::hm)
-       table.hidden_meths
-       saved_hidden_meths
-
-let new_slot table =
-  let index = table.size in
-  table.size <- index + 1;
-  index
-
-let new_variable table name =
-  let index = new_slot table in
-  table.vars <- Vars.add name index table.vars;
-  index
-
-let get_variable table name =
-  Vars.find name table.vars
-
-let add_initializer table f =
-  table.initializers <- f::table.initializers
-
-let create_table public_methods =
-  let table = new_table () in
-  List.iter
-    (function met ->
-       let lab = new_method met in
-       table.methods_by_name  <- Meths.add met lab table.methods_by_name;
-       table.methods_by_label <- Labs.add lab true table.methods_by_label)
-    public_methods;
-  table
-
-let init_class table =
-  inst_var_count := !inst_var_count + table.size - 1;
-  if params.compact_table then
-    compact_buckets table.buckets;
-  table.initializers <- List.rev table.initializers
-
-(**** Objects ****)
-
-let create_object table =
-  (* XXX Appel de [obj_block] *)
-  let obj = Obj.new_block Obj.object_tag table.size in
-  (* XXX Appel de [modify] *)
-  Obj.set_field obj 0 (Obj.repr table.buckets);
-  set_id obj last_id;
-  (Obj.obj obj)
-
-let rec iter_f obj =
-  function
-    []   -> ()
-  | f::l -> f obj; iter_f obj l
-
-let run_initializers obj table =
-  let inits = table.initializers in
-  if inits <> [] then
-    iter_f obj inits
-
-let send obj lab =
-  let (buck, elem) = decode lab in
-  (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
-
-(**** Statistics ****)
-
-type stats =
-  { classes: int; labels: int; methods: int; inst_vars: int; buckets: int;
-    distrib : int array; small_bucket_count: int; small_bucket_max: int }
-
-let distrib () =
-  let d = Array.create 32 0 in
-  List.iter
-    (function b ->
-       let n = bucket_used b in
-       d.(n - 1) <- d.(n - 1) + 1)
-    !bucket_list;
-  d
-
-let stats () =
-  { classes = !table_count; labels = !label_count;
-    methods = !method_count; inst_vars = !inst_var_count;
-    buckets = List.length !bucket_list; distrib = distrib ();
-    small_bucket_count = !small_bucket_count;
-    small_bucket_max = Array.length !small_buckets  }
-
-let sort_buck lst =
-  List.map snd
-    (Sort.list (fun (n, _) (n', _) -> n <= n')
-       (List.map (function b -> (bucket_used b, b)) lst))
-
-let show_buckets () =
-  List.iter
-    (function b ->
-       for i = 0 to bucket_size - 1 do
-         print_char (if b.(i) == dummy_item then '.' else '*')
-       done;
-       print_newline ())
-    (sort_buck !bucket_list)
+let copy = CamlinternalOO.copy
diff --git a/stdlib/oo.mli b/stdlib/oo.mli
index d3f2c3ed4..f4a781773 100644
--- a/stdlib/oo.mli
+++ b/stdlib/oo.mli
@@ -13,66 +13,8 @@
 
 (* $Id$ *)
 
-(** Object-oriented extension *)
+(** Operations on objects *)
 
 val copy : (< .. > as 'a) -> 'a
 (** [Oo.copy o] returns a copy of object [o], that is a fresh
    object with the same methods and instance variables as [o]  *)
-        
-
-(**/**)
-
-(** {6 For system use only, not for the casual user} *)
-
-(** {6 Methods} *)
-
-type label
-val new_method : string -> label
-
-(** {6 Classes} *)
-
-type table
-type meth
-type t
-type obj
-val new_variable : table -> string -> int
-val get_variable : table -> string -> int
-val get_method_label : table -> string -> label
-val get_method : table -> label -> meth
-val set_method : table -> label -> meth -> unit
-val narrow : table -> string list -> string list -> string list -> unit
-val widen : table -> unit
-val add_initializer : table -> (obj -> unit) -> unit
-val create_table : string list -> table
-val init_class : table -> unit
-
-(** {6 Objects} *)
-
-val create_object : table -> obj
-val run_initializers : obj -> table -> unit
-val send : obj -> label -> t
-
-(** {6 Parameters} *)
-
-type params =
-  { mutable compact_table : bool;
-    mutable copy_parent : bool;
-    mutable clean_when_copying : bool;
-    mutable retry_count : int;
-    mutable bucket_small_size : int }
-
-val params : params
-
-(** {6 Statistics} *)
-
-type stats =
-  { classes : int; 
-    labels : int; 
-    methods : int; 
-    inst_vars : int; 
-    buckets : int;
-    distrib : int array; 
-    small_bucket_count : int; 
-    small_bucket_max : int }
-val stats : unit -> stats
-val show_buckets : unit -> unit