remove dead code

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

6 files changed, 43 insertions, 326 deletions

diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index d7eea1231b..b6001f5fe4 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -467,16 +467,19 @@ let rec close fenv cenv = function
         {prim_name = "oo_"^kind^"_public_method"; prim_arity = arity;
          prim_alloc = false; prim_native_name = ""; prim_native_float = false}
       in
-      let imet = Ident.create "met" and imeths = Ident.create "meths" in
       let met, args =
         match args with
-          (Lprim(Pfield n, [cache]) as key) :: args ->
+          Lprim(Pfield n, [cache]) :: args ->
+            let imeths = Ident.create "meths"
+            and icache = Ident.create "cache" in
             (Llet(Alias, imeths, Lprim(Pfield 0, [Lvar self]),
+             Llet(Alias, icache, cache,
+                  let cache = Lvar icache and meths = Lvar imeths in
                   Lifthenelse(
-                  Lprim(Pintcomp Cneq, [key; Lvar imeths]),
+                  Lprim(Pintcomp Cneq, [Lprim(Pfield n, [cache]); meths]),
                   Lprim(Pccall (prim "cache" 4),
-                        [Lvar imeths; met; cache; Lconst(Const_pointer n)]),
-                  Lprim(Pfield (n+1), [cache]))),
+                        [meths; met; cache; Lconst(Const_pointer n)]),
+                  Lprim(Pfield (n+1), [cache])))),
              args)
         | _ ->
             (Lprim (Pccall (prim "get" 2), [Lvar self; met]), args)
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 2e82db7861..2b21ef09b1 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -312,81 +312,8 @@ let string_length exp =
 
 (* Message sending *)
 
-(*
-let lookup_tag obj tag =
-  bind "tag" tag (fun tag ->
-    let table = Ident.create "table" in
-    let n = untag_int (Cop(Cload Word, [Cvar table])) in
-    let tag =
-      match tag with
-        Cconst_int tag ->
-          Cconst_natint
-            (Nativeint.logand (Nativeint.of_int (tag lsr 1)) 0x7fffffffn)
-      | Cconst_natint tag ->
-          Cconst_natint
-            (Nativeint.logand (Nativeint.shift_right tag 1) 0x7fffffffn)
-      | _ ->
-          let tag = Cop(Clsr, [tag; Cconst_int 1]) in
-          if log2_size_addr = 4 then tag else
-          Cop(Cand, [tag; Cconst_natint 0x7fffffffn])
-    in
-    let lab = Cop(Caddi, [Cop(Cmodi, [tag; n]); Cconst_int 1]) in
-    Clet(table, Cop (Cload Word, [obj]),
-         Cop(Cload Word,
-             [Cop (Cadda, [Cvar table; lsl_const lab log2_size_addr])])))
-
-let lookup_tag obj tag =
-  bind "tag" tag (fun tag ->
-    let table = Ident.create "table" in
-    let index = Cop (Cload Word, [Cop (Cload Word, [Cvar table])]) in
-    let lab = Cop(Capply typ_addr, [index; tag; Cconst_pointer 0]) in
-    Clet(table, Cop (Cload Word, [obj]),
-         addr_array_ref (Cvar table) lab))
-*)
-
-let decode_tag tag =
-  let n = Nativeint.logand (Nativeint.shift_right tag 1) 0x7fffffffn in
-  let lab3 = Nativeint.to_int (Nativeint.rem n 1291n)
-  and n' = Nativeint.to_int (Nativeint.div n 1291n) in
-  let lab2 = n' mod 1291 and lab1 = n' / 1291 in
-  (* Printf.eprintf "%nd = (%d, %d, %d)\n" n lab1 lab2 lab3; flush stderr; *)
-  let shift ofs = ofs lsl log2_size_addr in
-  (Cconst_int (shift lab1), Cconst_int (shift lab2), Cconst_int (shift lab3))
-
-let id x = x
-
-let get_var_field ofs ptr =
-  match ofs with
-    Cconst_int 0 -> Cop (Cload Word, [ptr])
-  | _ -> Cop (Cload Word, [Cop (Cadda, [ptr; ofs])])
-
-let lookup_tag obj tag =
-  bind "tag" tag (fun tag ->
-    let table = Ident.create "table" in
-    let (wrap, (lab1, lab2, lab3)) =
-      match tag with
-        Cconst_int tag -> id, decode_tag (Nativeint.of_int tag)
-      | Cconst_natint tag -> id, decode_tag tag
-      | _ ->
-          let itag = Ident.create "tag" in
-          let tag' = Cop(Clsr, [tag; Cconst_int 1]) in
-          let tag' =
-            if log2_size_addr = 4 then tag else
-            Cop(Cand, [tag; Cconst_natint 0x7fffffffn]) in
-          let shift ofs = lsl_const ofs log2_size_addr in
-          (fun cmm -> Clet(itag, tag', cmm)),
-          (shift (Cop (Cdivi, [Cvar itag; Cconst_int 1666681])),
-           shift (Cop (Cmodi, [Cop (Cdivi, [Cvar itag; Cconst_int 1291]);
-                               Cconst_int 1291])),
-           shift (Cop (Cmodi, [Cvar itag; Cconst_int 1291])))
-    in
-    wrap
-      (get_var_field lab3
-         (get_var_field lab2
-            (get_var_field lab1 (Cop (Cload Word, [obj]))))))
-
 let lookup_label kind obj lab =
-  if kind = Public then lookup_tag obj lab else
+  if kind = Public then assert false else
   bind "lab" lab (fun lab ->
     let table = Cop (Cload Word, [obj]) in
     addr_array_ref table lab)
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 105999c0e1..e1a86da54a 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -22,7 +22,7 @@ open Translcore
 
 (* XXX Rajouter des evenements... *)
 
-type error = Illegal_class_expr
+type error = Illegal_class_expr | Tags of label * label
 
 exception Error of Location.t * error
 
@@ -529,28 +529,6 @@ module M = struct
 end
 open M
 
-(*
-let rec hash_size n tags =
-  let arr = String.make n ' ' in
-  let base = -(1 lsl 30) in
-  let ofs = n - base mod n in
-  let umod x = ((x lxor base) mod n + ofs) mod n in
-  try
-    List.iter
-      (fun x ->
-        let y = umod x in
-        if String.unsafe_get arr y = ' ' then String.unsafe_set arr y '1'
-        else raise Not_found)
-      tags;
-    Printf.eprintf "[%d%t]\n" n
-      (fun _ -> List.iter (fun x -> Printf.eprintf " %d" (umod x)) tags);
-    flush stderr;
-    n
-  with Not_found -> hash_size (n+1) tags
-
-let perfect_hash_size tags =
-  hash_size (List.length tags) tags
-*)
 
 (*
    Traduction d'une classe.
@@ -650,32 +628,11 @@ let transl_class ids cl_id arity pub_meths cl =
   List.iter2
     (fun tag name ->
       let name' = List.assoc tag rev_map in
-      if name' <> name then
-	fatal_error ("conflicting labels "^name^" and "^name'))
+      if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
     tags pub_meths;
-  (*
-  let hash_size () =
-    if not !Clflags.native_code then lambda_unit else
-    let size = perfect_hash_size tags in
-    Lconst(Const_base(Const_int size))
-  in
-  let public_map () =
-    if not !Clflags.native_code then lambda_unit else
-    let meth = Ident.create "meth" in
-    let i = ref 0 in
-    let index m = incr i;
-      (Const_int (Btype.hash_variant m), Lconst(Const_base(Const_int !i))) in
-    Lfunction(Curried, [meth],
-              Matching.make_test_sequence None (Pintcomp Cneq) (Pintcomp Clt)
-                (Lvar meth) (List.map index pub_meths))
-  in
-  *)
-  let create_arg =
-   if true || not !Clflags.native_code then lambda_unit else Lconst(Const_pointer 1) in
   let ltable table lam =
     Llet(Strict, table,
-         Lapply (oo_prim "create_table",
-                 [create_arg; transl_meth_list pub_meths]), lam)
+         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
   and ldirect obj_init =
     Llet(Strict, obj_init, cl_init,
          Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
@@ -691,8 +648,7 @@ let transl_class ids cl_id arity pub_meths cl =
     Llet(Strict, class_init, Lfunction(Curried, [cla], cl_init),
          lam class_init)
   and lbody class_init =
-    Lapply (oo_prim "make_class",
-            [create_arg; transl_meth_list pub_meths; Lvar class_init])
+    Lapply (oo_prim "make_class",[transl_meth_list pub_meths; Lvar class_init])
   and lbody_virt lenvs =
     Lprim(Pmakeblock(0, Immutable),
           [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
@@ -763,7 +719,7 @@ let transl_class ids cl_id arity pub_meths cl =
               if not concrete then lclass_virt () else
               lclass (
               Lapply (oo_prim "make_class_store",
-                      [create_arg; transl_meth_list pub_meths;
+                      [transl_meth_list pub_meths;
                        Lvar class_init; Lvar cached]))),
   make_envs (
   if ids = [] then Lapply(lfield cached 0, [lenvs]) else
@@ -796,3 +752,6 @@ open Format
 let report_error ppf = function
   | Illegal_class_expr ->
       fprintf ppf "This kind of class expression is not allowed"
+  | Tags (lab1, lab2) ->
+      fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
+        lab1 lab2 "Change one of them."
diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index a17a0b1178..85d5f74bcd 100644
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -19,7 +19,7 @@ val dummy_class : lambda -> lambda
 val transl_class :
   Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
 
-type error = Illegal_class_expr
+type error = Illegal_class_expr | Tags of string * string
 
 exception Error of Location.t * error
 
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 2df1ada263..a08ffead7e 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -94,127 +94,12 @@ type meths = label Meths.t
 module Labs = Map.Make(struct type t = label let compare = compare end)
 type labs = bool Labs.t
 
-module Labset = Set.Make(struct type t = label let compare = compare end)
-
-let bucket_count = ref 0
-
-type span =
-    { mutable labels: Labset.t;
-      mutable children: (label * slot) list;
-      mutable array: closure array;
-      mutable link: span option }
-and slot = Method of tag | Span of span
-
-let rec (!!) span =
-  match span.link with
-    None -> span
-  | Some x -> !!x
-
-let mergeable sp1 sp2 =
-  let common = Labset.inter sp1.labels sp2.labels in
-  Labset.for_all
-    (fun lab ->
-      match List.assoc lab sp1.children, List.assoc lab sp2.children with
-	Span sp1', Span sp2' -> !!sp1' == !!sp2'
-      | _ -> Printf.eprintf "conflict on label %d\n" lab; flush stderr; false)
-    common
-
-let rec merge spans = function
-    [] -> spans
-  | span :: rem ->
-      let rec try_merge = function
-          [] -> false
-        | span' :: rem' ->
-            if mergeable !!span !!span' then
-              let span'' =
-                { labels = Labset.union !!span.labels !!span'.labels;
-                  children = !!span.children @ !!span'.children;
-                  array = [||]; link = None } in
-              !!span.link <- Some span'';
-              !!span'.link <- Some span'';
-              true
-            else try_merge rem'
-      in
-      merge (if try_merge spans then spans else span :: spans) rem
-
-let decode (tag : tag) =
-  let n = Nativeint.logand (Nativeint.of_int (magic tag)) 0x7fffffffn in
-  let lab3 = Nativeint.to_int (Nativeint.rem n 1291n)
-  and n' = Nativeint.to_int (Nativeint.div n 1291n) in
-  let lab2 = n' mod 1291 and lab1 = n' / 1291 in
-  (* Printf.eprintf "%nd = (%d, %d, %d)\n" n lab1 lab2 lab3; flush stderr; *)
-  (lab1, lab2, lab3)
-
-let empty_span () =
-  {labels = Labset.empty; children = []; array = [||]; link = None}
-
-let add_child span lab data =
-    !!span.labels <- Labset.add lab !!span.labels;
-    !!span.children <- (lab, data) :: !!span.children
-
-let insert_span lab span =
-  if Labset.mem lab !!span.labels then
-    match List.assoc lab !!span.children with
-      Method _ -> assert false
-    | Span span -> span
-  else
-    let span' = empty_span () in
-    add_child span lab (Span span');
-    span'
-
-let make_span tags =
-  let span = empty_span () in
-  Array.iter
-    (fun tag ->
-      let (lab1, lab2, lab3) = decode tag in
-      let span1 = insert_span lab1 span in
-      let span2 = insert_span lab2 span1 in
-      assert (not (Labset.mem lab3 !!span2.labels));
-      add_child span2 lab3 (Method tag))
-    tags;
-  span
-
-let rec span_list = function
-    (_, Span sp) :: rem ->
-      sp :: span_list !!sp.children @ span_list rem
-  | _ :: rem ->
-      span_list rem
-  | [] -> []
-
-let connect_slots span =
-  List.iter
-    (fun (lab, slot) ->
-      match slot with
-        Span sp -> !!span.array.(lab) <- magic (!!sp.array : _ array)
-      | Method tag -> !!span.array.(lab) <- magic 1)
-    !!span.children
-
-let truncate_size arr =
-  let n = ref (Array.length arr - 1) in
-  while !n > 1 && arr.(!n) == dummy_item do decr n done;
-  let len = !n + 1 in
-  if len <> Array.length arr then Obj.truncate (Obj.repr arr) len
-
-let build_access_table tags =
-  let span = make_span tags in
-  let spans = merge [] (List.rev (span :: span_list !!span.children)) in
-  let len = List.length spans in
-  Printf.eprintf "%d bucket%s\n" len (if len > 1 then "s" else "");
-  flush stderr;
-  bucket_count := !bucket_count + len;
-  List.iter (fun span -> !!span.array <- Array.create 1291 dummy_item) spans;
-  List.iter connect_slots spans;
-  List.iter (fun sp -> truncate_size !!sp.array) (List.tl spans);
-  (!!span.array, len = 1)
-
 (* The compiler assumes that the first field of this structure is [size]. *)
 type table =
  { mutable size: int;
    mutable methods: closure array;
-   mutable next_label: int;
    mutable methods_by_name: meths;
    mutable methods_by_label: labs;
-   mutable public_methods: (label * label * label) Labs.t;
    mutable previous_states:
      (meths * labs * (label * item) list * vars *
       label list * string list) list;
@@ -224,10 +109,8 @@ type table =
 
 let dummy_table =
   { methods = [| |];
-    next_label = 0;
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
-    public_methods = Labs.empty;
     previous_states = [];
     hidden_meths = [];
     vars = Vars.empty;
@@ -236,13 +119,11 @@ let dummy_table =
 
 let table_count = ref 0
 
-let new_table meths next =
+let new_table pub_labels =
   incr table_count;
-  { methods = meths;
-    next_label = next;
+  { methods = [| magic (pub_labels : tag array) |];
     methods_by_name = Meths.empty;
     methods_by_label = Labs.empty;
-    public_methods = Labs.empty;
     previous_states = [];
     hidden_meths = [];
     vars = Vars.empty;
@@ -250,7 +131,6 @@ let new_table meths next =
     size = initial_object_size }
 
 let resize array new_size =
-  if new_size > 1291 then prerr_endline "CamlinternalOO: huge class";
   let old_size = Array.length array.methods in
   if new_size > old_size then begin
     let new_buck = Array.create new_size dummy_item in
@@ -260,13 +140,7 @@ let resize array new_size =
 
 let put array label element =
   resize array (label + 1);
-  array.methods.(label) <- element;
-  if Labs.mem label array.public_methods then begin
-    let (lab1, lab2, lab3) = Labs.find label array.public_methods in
-    let arr1 = array.methods.(lab1) in
-    let arr2 = (magic arr1).(lab2) in
-    arr2.(lab3) <- element;
-  end
+  array.methods.(label) <- element
 
 (**** Classes ****)
 
@@ -277,13 +151,8 @@ type t
 type meth = item
 
 let new_method table =
-  let len = Array.length table.methods in
-  while table.next_label < len &&
-    table.methods.(table.next_label) <> dummy_item
-  do table.next_label <- table.next_label + 1 done;
-  let index = table.next_label in
-  table.next_label <- index + 1;
-  resize table (index+1);
+  let index = Array.length table.methods in
+  resize table (index + 1);
   index
 
 let get_method_label table name =
@@ -391,59 +260,22 @@ let get_variables table names =
 let add_initializer table f =
   table.initializers <- f::table.initializers
 
-(*
-let compute_labels n tags =
-  if n = 0 then Array.mapi (fun i _ -> i+1) tags else
-  let umod (x : tag) =
-    1 + Nativeint.to_int
-      (Nativeint.rem
-	 (Nativeint.logand (Nativeint.of_int (magic x)) 0x7fffffffn)
-         (Nativeint.of_int n))
-  in
-  Array.map umod tags
-
-let init_hash n labels =
-  let arr = Array.create (n+1) 0 and last = ref 0 in
-  arr.(0) <- n;
-  Array.iter
-    (fun lab ->
-      last := max !last lab;
-      Array.unsafe_set arr lab 1)
-    labels;
-  if !last = n then arr else Array.sub arr 0 (!last+1)
-*)
-
-let create_table n public_methods =
-  if public_methods == magic 0 then new_table [||] 0 else
+let create_table public_methods =
+  if public_methods == magic 0 then new_table [||] else
   (* [public_methods] must be in ascending order for bytecode *)
   let tags = Array.map public_method_label public_methods in
-  (* let labels = compute_labels n tags in *)
-  let (arg, flat), next =
-    if n = 0 then ([|magic tags|], true), 1 else
-    build_access_table tags, 0
-  in
-  let table = new_table arg next
-    (* new_table (magic (init_hash n labels : int array)) 1 *)
-  in
-  Array.iteri
-    (fun i met ->
-      let lab =
-	if n = 0 || not flat then new_method table else
-	let (_,_,lab) = decode tags.(i) in lab
-      in
+  let table = new_table tags in
+  Array.iter
+    (function met ->
+      let lab = new_method table 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;
-      if not flat then
-        table.public_methods <-
-          Labs.add lab (decode tags.(i)) table.public_methods)
+      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;
-  table.initializers <- List.rev table.initializers;
-  if table.public_methods <> Labs.empty then
-    truncate_size table.methods
+  table.initializers <- List.rev table.initializers
 
 let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
   narrow cla vals virt_meths concr_meths;
@@ -452,16 +284,16 @@ let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
   widen cla;
   init
 
-let make_class hash_size pub_meths class_init =
-  let table = create_table hash_size pub_meths in
+let make_class pub_meths class_init =
+  let table = create_table pub_meths in
   let env_init = class_init table in
   init_class table;
   (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
 
 type init_table = { mutable env_init: t; mutable class_init: table -> t }
 
-let make_class_store hash_size pub_meths class_init init_table =
-  let table = create_table hash_size pub_meths in
+let make_class_store pub_meths class_init init_table =
+  let table = create_table pub_meths in
   let env_init = class_init table in
   init_class table;
   init_table.class_init <- class_init;
@@ -512,9 +344,8 @@ let create_object_and_run_initializers obj_0 table =
   end
 
 (* Equivalent primitive below
-let send obj lab =
-  let (buck, elem) = decode lab in
-  (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
+let sendself obj lab =
+  (magic obj : (obj -> t) array array).(0).(lab) obj
 *)
 external send : obj -> tag -> 'a = "%send"
 external sendself : obj -> label -> 'a = "%sendself"
@@ -657,10 +488,8 @@ let set_methods table methods =
 (**** Statistics ****)
 
 type stats =
-  { classes: int; methods: int; inst_vars: int; buckets: int }
+  { classes: int; methods: int; inst_vars: int; }
 
 let stats () =
   { classes = !table_count;
-    methods = !method_count;
-    inst_vars = !inst_var_count;
-    buckets = !bucket_count; }
+    methods = !method_count; inst_vars = !inst_var_count; }
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index b0891ee0ff..666fee567c 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -41,17 +41,17 @@ val narrow : table -> string array -> string array -> string array -> unit
 val widen : table -> unit
 val add_initializer : table -> (obj -> unit) -> unit
 val dummy_table : table
-val create_table : int -> string array -> table
+val create_table : string array -> table
 val init_class : table -> unit
 val inherits :
     table -> string array -> string array -> string array ->
     (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t
 val make_class :
-    int -> string array -> (table -> Obj.t -> t) ->
+    string array -> (table -> Obj.t -> t) ->
     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
 type init_table
 val make_class_store :
-    int -> string array -> (table -> t) -> init_table -> unit
+    string array -> (table -> t) -> init_table -> unit
 
 (** {6 Objects} *)
 
@@ -135,6 +135,5 @@ val params : params
 type stats =
   { classes : int; 
     methods : int; 
-    inst_vars : int;
-    buckets : int }
+    inst_vars : int }
 val stats : unit -> stats