fast and compact classes

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

4 files changed, 254 insertions, 12 deletions

diff --git a/stdlib/Makefile b/stdlib/Makefile
index 9984a71fe..56b04b969 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -31,8 +31,8 @@ BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
   set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \
   printf.cmo format.cmo scanf.cmo \
   arg.cmo printexc.cmo gc.cmo \
-  digest.cmo random.cmo camlinternalOO.cmo oo.cmo \
-  genlex.cmo callback.cmo weak.cmo \
+  digest.cmo random.cmo callback.cmo camlinternalOO.cmo oo.cmo \
+  genlex.cmo weak.cmo \
   lazy.cmo filename.cmo complex.cmo
 LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
 
@@ -119,6 +119,9 @@ pervasives.p.cmx: pervasives.ml
 camlinternalOO.cmi: camlinternalOO.mli
 	$(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli
 
+camlinternalOO.cmx: camlinternalOO.ml
+	$(CAMLOPT) $(OPTCOMPFLAGS) -inline 0 camlinternalOO.ml
+
 # labelled modules require the -nolabels flag
 labelled.cmo:
 	$(MAKE) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) \
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 8d5c3cb6a..29e81dc8c 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -327,7 +327,13 @@ let get_method table label =
   let (buck, elem) = decode label in
   table.buckets.(buck).(elem)
 
+let to_list arr =
+  if arr == magic 0 then [] else Array.to_list arr
+
 let narrow table vars virt_meths concr_meths =
+  let vars = to_list vars
+  and virt_meths = to_list virt_meths
+  and concr_meths = to_list concr_meths in
   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 <-
@@ -387,6 +393,13 @@ let new_variable table name =
   table.vars <- Vars.add name index table.vars;
   index
 
+let new_variables table names =
+  let index = new_variable table names.(0) in
+  for i = 1 to Array.length names - 1 do
+    ignore (new_variable table names.(i))
+  done;
+  index
+
 let get_variable table name =
   Vars.find name table.vars
 
@@ -395,12 +408,13 @@ let add_initializer table f =
 
 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;
+  if public_methods != magic 0 then
+    Array.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 =
@@ -409,6 +423,28 @@ let init_class table =
     compact_buckets table.buckets;
   table.initializers <- List.rev table.initializers
 
+let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
+  narrow cla vals virt_meths concr_meths;
+  let init =
+    if top then super cla env else Obj.repr (super cla) in
+  widen cla;
+  init
+
+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 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;
+  init_table.env_init <- env_init
+
 (**** Objects ****)
 
 let create_object table =
@@ -453,9 +489,148 @@ let create_object_and_run_initializers obj_0 table =
     obj
   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
+*)
+external send : obj -> label -> 'a = "%send"
+
+(**** table collection access ****)
+
+type tables = Empty | Cons of table * tables * tables
+type mut_tables =
+    {key: table; mutable data: tables; mutable next: tables}
+external mut : tables -> mut_tables = "%identity"
+
+let build_path n keys tables =
+  let res = Cons (Obj.magic 0, Empty, Empty) in
+  let r = ref res in
+  for i = 0 to n do
+    r := Cons (keys.(i), !r, Empty)
+  done;
+  tables.data <- !r;
+  res
+
+let rec lookup_keys i keys tables =
+  if i < 0 then tables else
+  let key = keys.(i) in
+  let rec lookup_key tables =
+    if tables.key == key then lookup_keys (i-1) keys tables.data else
+    if tables.next <> Empty then lookup_key (mut tables.next) else
+    let next = Cons (key, Empty, Empty) in
+    tables.next <- next;
+    build_path (i-1) keys (mut next)
+  in
+  lookup_key (mut tables)
+
+let lookup_tables root keys =
+  let root = mut root in
+  if root.data <> Empty then
+    lookup_keys (Array.length keys - 1) keys root.data
+  else
+    build_path (Array.length keys - 1) keys root
+
+(**** builtin methods ****)
+
+type closure = item
+external ret : (obj -> 'a) -> closure = "%identity"
+
+let get_const x = ret (fun obj -> x)
+let get_var n   = ret (fun obj -> Array.unsafe_get obj n)
+let get_env e n = ret (fun obj -> Obj.field (Array.unsafe_get obj e) n)
+let get_meth n  = ret (fun obj -> send obj n)
+let set_var n   = ret (fun obj x -> Array.unsafe_set obj n x)
+let app_const f x = ret (fun obj -> f x)
+let app_var f n   = ret (fun obj -> f (Array.unsafe_get obj n))
+let app_env f e n = ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n))
+let app_meth f n  = ret (fun obj -> f (send obj n))
+let app_const_const f x y = ret (fun obj -> f x y)
+let app_const_var f x n   = ret (fun obj -> f x (Array.unsafe_get obj n))
+let app_const_meth f x n = ret (fun obj -> f x (send obj n))
+let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
+let app_meth_const f n x = ret (fun obj -> f (send obj n) x)
+let app_const_env f x e n =
+  ret (fun obj -> f x (Obj.field (Array.unsafe_get obj e) n))
+let app_env_const f e n x =
+  ret (fun obj -> f (Obj.field (Array.unsafe_get obj e) n) x)
+let meth_app_const n x = ret (fun obj -> (send obj n) x)
+let meth_app_var n m =
+  ret (fun obj -> (send obj n) (Array.unsafe_get obj m))
+let meth_app_env n e m =
+  ret (fun obj -> (send obj n) (Obj.field (Array.unsafe_get obj e) m))
+let meth_app_meth n m =
+  ret (fun obj -> (send obj n) (send obj m))
+
+type impl =
+    GetConst
+  | GetVar
+  | GetEnv
+  | GetMeth
+  | SetVar
+  | AppConst
+  | AppVar
+  | AppEnv
+  | AppMeth
+  | AppConstConst
+  | AppConstVar
+  | AppConstEnv
+  | AppConstMeth
+  | AppVarConst
+  | AppEnvConst
+  | AppMethConst
+  | MethAppConst
+  | MethAppVar
+  | MethAppEnv
+  | MethAppMeth
+  | Closure of Obj.t
+
+let method_impl i arr =
+  let next () = incr i; magic arr.(!i) in
+  match next() with
+    GetConst -> let x : t = next() in ret (fun obj -> x)
+  | GetVar   -> let n = next() in get_var n
+  | GetEnv   -> let e = next() and n = next() in get_env e n
+  | GetMeth  -> let n = next() in get_meth n
+  | SetVar   -> let n = next() in set_var n
+  | AppConst -> let f = next() and x = next() in ret (fun obj -> f x)
+  | AppVar   -> let f = next() and n = next () in app_var f n
+  | AppEnv   ->
+      let f = next() and e = next() and n = next() in app_env f e n
+  | AppMeth  -> let f = next() and n = next () in app_meth f n
+  | AppConstConst ->
+      let f = next() and x = next() and y = next() in ret (fun obj -> f x y)
+  | AppConstVar ->
+      let f = next() and x = next() and n = next() in app_const_var f x n
+  | AppConstEnv ->
+      let f = next() and x = next() and e = next () and n = next() in
+      app_const_env f x e n
+  | AppConstMeth ->
+      let f = next() and x = next() and n = next() in app_const_meth f x n
+  | AppVarConst ->
+      let f = next() and n = next() and x = next() in app_var_const f n x
+  | AppEnvConst ->
+      let f = next() and e = next () and n = next() and x = next() in
+      app_env_const f e n x
+  | AppMethConst ->
+      let f = next() and n = next() and x = next() in app_meth_const f n x
+  | MethAppConst ->
+      let n = next() and x = next() in meth_app_const n x
+  | MethAppVar ->
+      let n = next() and m = next() in meth_app_var n m
+  | MethAppEnv ->
+      let n = next() and e = next() and m = next() in meth_app_env n e m
+  | MethAppMeth ->
+      let n = next() and m = next() in meth_app_meth n m
+  | Closure _ as clo -> magic clo
+
+let set_methods table methods =
+  let len = Array.length methods and i = ref 0 in
+  while !i < len do
+    let label = methods.(!i) and clo = method_impl i methods in
+    set_method table label clo;
+    incr i
+  done
 
 (**** Statistics ****)
 
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 5e945f931..0195d465f 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -30,16 +30,27 @@ type meth
 type t
 type obj
 val new_variable : table -> string -> int
+val new_variables : table -> string array -> 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 set_methods : table -> label array -> unit
+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 : string list -> 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 :
+    string array -> (table -> Obj.t -> t) ->
+    (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
+type init_table
+val make_class_store :
+    string array -> (table -> t) -> init_table -> unit
 
 (** {6 Objects} *)
 
@@ -49,7 +60,60 @@ 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
+external send : obj -> label -> t = "%send"
+
+(** {6 Table cache} *)
+
+type tables
+val lookup_tables : tables -> table array -> tables
+
+(** {6 Builtins to reduce code size} *)
+
+open Obj
+type closure
+val get_const : t -> closure
+val get_var : int -> closure
+val get_env : int -> int -> closure
+val get_meth : label -> closure
+val set_var : int -> closure
+val app_const : (t -> t) -> t -> closure
+val app_var : (t -> t) -> int -> closure
+val app_env : (t -> t) -> int -> int -> closure
+val app_meth : (t -> t) -> label -> closure
+val app_const_const : (t -> t -> t) -> t -> t -> closure
+val app_const_var : (t -> t -> t) -> t -> int -> closure
+val app_const_env : (t -> t -> t) -> t -> int -> int -> closure
+val app_const_meth : (t -> t -> t) -> t -> label -> closure
+val app_var_const : (t -> t -> t) -> int -> t -> closure
+val app_env_const : (t -> t -> t) -> int -> int -> t -> closure
+val app_meth_const : (t -> t -> t) -> label -> t -> closure
+val meth_app_const : label -> t -> closure
+val meth_app_var : label -> int -> closure
+val meth_app_env : label -> int -> int -> closure
+val meth_app_meth : label -> label -> closure
+
+type impl =
+    GetConst
+  | GetVar
+  | GetEnv
+  | GetMeth
+  | SetVar
+  | AppConst
+  | AppVar
+  | AppEnv
+  | AppMeth
+  | AppConstConst
+  | AppConstVar
+  | AppConstEnv
+  | AppConstMeth
+  | AppVarConst
+  | AppEnvConst
+  | AppMethConst
+  | MethAppConst
+  | MethAppVar
+  | MethAppEnv
+  | MethAppMeth
+  | Closure of t
 
 (** {6 Parameters} *)
 
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index 930acecf1..c011554d0 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -78,4 +78,4 @@ let catch_break on =
 
 (* OCaml version string, must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.07+5 (2003-11-19)";;
+let ocaml_version = "3.07+6 (2003-11-25)";;