fast class creation

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

16 files changed, 146 insertions, 29 deletions

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 4edcfbe337..e752fb8a4b 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -183,6 +183,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env i0 =
       let (inh_init, obj_init) =
         build_object_init cl_table obj params [] (copy_env env) cl in
       let obj_init = subst_lambda (subst_env env) obj_init in
+      let obj_init = lfunction [obj] obj_init in
       let obj_init =
 	if i0 < 0 then obj_init else
 	let i = ref (i0-1) in
@@ -194,7 +195,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env i0 =
                         [Lprim(Pfield 3, [Lprim(Pfield !i, [Lvar env])])]),
 		 init))
 	  obj_init inh_init in
-      let obj_init = lfunction [env; obj] obj_init in
+      let obj_init = lfunction [env] obj_init in
       (inh_init, obj_init)
 
 let bind_method tbl public_methods lab id cl_init =
@@ -317,9 +318,9 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
 
 let transl_class ids cl_id arity pub_meths cl =
   let tables = Ident.create (Ident.name cl_id ^ "_tables") in
-  let top_env = oo_add_class tables in
+  let (top_env, req) = oo_add_class tables in
   let new_ids = Env.diff top_env cl.cl_env in
-  let top = (new_ids = []) in
+  let top = (new_ids = []) && not req in
   let replicate id = Ident.create (Ident.name id) in
   let new_ids2 = List.map replicate new_ids in
   let subst self =
@@ -404,30 +405,39 @@ let transl_class ids cl_id arity pub_meths cl =
   let obj_init2 = Ident.create "obj_init"
   and env_init = Ident.create "env_init"
   and env2 = Ident.create "env"
-  and self = Ident.create "self" in
+  and cached = Ident.create "cached" in
+  let inh_keys =
+    List.map (fun (_,_,lpath) -> Lprim(Pfield 2, [lpath])) inh_init in
   let lclass lam =
     Llet(Strict, class_init,
-         Lfunction(Curried, [cla], def_ids cla cl_init),
+         Lfunction(Curried, [cla], def_ids cla cl_init), lam)
+  and lcache lam =
+    if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
+    Llet(Strict, cached,
+         Lapply(oo_prim "lookup_tables",
+                [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
          lam)
   in
-  lclass (
+  lcache (
   Lsequence(
-  Lifthenelse(Lprim(Pfield 0, [Lvar tables]), Lconst (Const_pointer 0),
+  Lifthenelse(Lprim(Pfield 0, [Lvar cached]), lambda_unit,
               ltable (
+              lclass (
               Llet (Strict, env_init,
                     Lapply(Lvar class_init, [Lvar table]),
                     Lsequence(
                     Lapply (oo_prim "init_class", [Lvar table]),
-                    Lprim(
-                    Psetfield(0, true),
-                    [Lvar tables;
-                     Lprim(Pmakeblock(0,Immutable),
-                           [Lvar table; Lvar env_init])]))))),
+                    Lsequence(
+                    Lprim(Psetfield(0, true), [Lvar cached; Lvar env_init]),
+                    Lsequence(
+                    Lprim(Psetfield(1, true), [Lvar cached; Lvar class_init]),
+                    Lprim(Psetfield(2, true), [Lvar cached; Lvar table])
+                   ))))))),
   make_env (
   Lprim(Pmakeblock(0, Immutable),
-        [Lapply(Lprim(Pfield 1, [Lprim(Pfield 0, [Lvar tables])]), [Lvar env]);
-         Lvar class_init;
-         Lprim(Pfield 0, [Lprim(Pfield 0, [Lvar tables])]);
+        [Lapply(Lprim(Pfield 0, [Lvar cached]), [Lvar env]);
+         Lprim(Pfield 1, [Lvar cached]);
+         Lprim(Pfield 2, [Lvar cached]);
          Lvar env]))))
 
 (* example:
@@ -438,6 +448,10 @@ module M1 = M (struct let x = 3 end);;
 let o = new M1.c;;
 let f (x : int) =
   let module M = struct class c = object method m = x end end in new M.c;;
+module F(X : sig class c : object method x : int end end) =
+  struct class c = object inherit X.c as super method x = super#x + 1 end end;;
+module M0 = struct class c = object method x = 0 end end;;
+module M2 = struct class c = object method x = 2 end end;;
 *)
 
 let class_stub =
@@ -446,10 +460,13 @@ let class_stub =
 let dummy_class undef_fn =
   Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"])
 
+let () =
+  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
+
 (* Wrapper for class compilation *)
 
 let transl_class ids cl_id arity pub_meths cl =
-  oo_wrap cl.cl_env (transl_class ids cl_id arity pub_meths) cl
+  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
 
 (* Error report *)
 
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 34a042eb41..a1e368ebfc 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -36,6 +36,10 @@ let transl_module =
   ref((fun cc rootpath modl -> assert false) :
       module_coercion -> Path.t option -> module_expr -> lambda)
 
+let transl_object =
+  ref (fun id s cl -> assert false :
+       Ident.t -> string list -> class_expr -> lambda)
+
 (* Translation of primitives *)
 
 let comparisons_table = create_hashtable 11 [
@@ -665,6 +669,16 @@ let rec transl_exp e =
   | Texp_lazy e ->
       let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
       Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
+  | Texp_object (cs, cty, meths) ->
+      let cl = Ident.create "class" in
+      let lam =
+        !transl_object cl meths
+          { cl_desc = Tclass_structure cs;
+            cl_loc = e.exp_loc;
+            cl_type = Tcty_signature cty;
+            cl_env = e.exp_env }
+      in
+      Lapply(Lprim(Pfield 0, [lam]), [lambda_unit])
 
 and transl_list expr_list =
   List.map transl_exp expr_list
@@ -880,13 +894,13 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
 (* Wrapper for class compilation *)
 
 let transl_exp e =
-  Translobj.oo_wrap e.exp_env transl_exp e
+  Translobj.oo_wrap e.exp_env true transl_exp e
 
 let transl_let rec_flag pat_expr_list body =
   match pat_expr_list with
     [] -> body
   | (_, expr) :: _ ->
-      Translobj.oo_wrap expr.exp_env
+      Translobj.oo_wrap expr.exp_env true
         (transl_let rec_flag pat_expr_list) body
 
 (* Compile an exception definition *)
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 3ad655b229..8148f9b8a6 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -46,3 +46,5 @@ val report_error: formatter -> error -> unit
 (* Forward declaration -- to be filled in by Translmod.transl_module *)
 val transl_module :
       (module_coercion -> Path.t option -> module_expr -> lambda) ref
+val transl_object :
+      (Ident.t -> string list -> class_expr -> lambda) ref
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 3a1cbcbd22..da9e5d892a 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -248,7 +248,7 @@ let rec transl_module cc rootpath mexp =
       transl_structure [] cc rootpath str
   | Tmod_functor(param, mty, body) ->
       let bodypath = functor_path rootpath param in
-      oo_wrap mexp.mod_env
+      oo_wrap mexp.mod_env true
         (function
         | Tcoerce_none ->
             Lfunction(Curried, [param],
@@ -262,7 +262,7 @@ let rec transl_module cc rootpath mexp =
             fatal_error "Translmod.transl_module")
         cc
   | Tmod_apply(funct, arg, ccarg) ->
-      oo_wrap mexp.mod_env
+      oo_wrap mexp.mod_env true
         (apply_coercion cc)
         (Lapply(transl_module Tcoerce_none None funct,
                 [transl_module ccarg None arg]))
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 60a419bd45..41a242e617 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -65,25 +65,32 @@ let transl_label_init expr =
 (* Share classes *)
 
 let wrapping = ref false
+let required = ref true
 let top_env = ref Env.empty
 let classes = ref []
 
 let oo_add_class id =
   classes := id :: !classes;
-  !top_env
-
-let oo_wrap env f x =
-  if !wrapping then f x else
-  try
+  (!top_env, !required)
+
+let oo_wrap env req f x =
+  if !wrapping then
+    if !required || not req then f x else
+    let old = !required in
+    try let lam = f x in required := old; lam
+    with exn -> required := old; raise exn
+  else try
     wrapping := true;
+    required := req;
     top_env := env;
     classes := [];
     let lambda = f x in
     let lambda =
       List.fold_left
         (fun lambda id ->
-          Llet(StrictOpt, id, Lprim(Pmakeblock(0, Mutable),
-                                    [Lconst(Const_pointer 0)]),
+          Llet(StrictOpt, id,
+               Lprim(Pmakeblock(0, Mutable),
+                     [lambda_unit; lambda_unit; lambda_unit]),
                lambda))
         lambda !classes
     in
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index 5cc821bde9..dcdf0c1ad1 100644
--- a/bytecomp/translobj.mli
+++ b/bytecomp/translobj.mli
@@ -19,5 +19,5 @@ val meth: string -> Ident.t
 val reset_labels: unit -> unit
 val transl_label_init: Lambda.lambda -> Lambda.lambda
 
-val oo_wrap: Env.t -> ('a -> Lambda.lambda) -> 'a -> Lambda.lambda
-val oo_add_class: Ident.t -> Env.t
+val oo_wrap: Env.t -> bool -> ('a -> Lambda.lambda) -> 'a -> Lambda.lambda
+val oo_add_class: Ident.t -> Env.t * bool
diff --git a/parsing/parser.mly b/parsing/parser.mly
index f95e70a132..25797a3fef 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -879,6 +879,8 @@ expr:
       { mkassert $2 }
   | LAZY simple_expr %prec below_SHARP
       { mkexp (Pexp_lazy ($2)) }
+  | OBJECT class_structure END
+      { mkexp (Pexp_object ($2)) }
 ;
 simple_expr:
     val_longident
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index f0da277bfb..d0db6b8483 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -110,6 +110,7 @@ and expression_desc =
   | Pexp_assertfalse
   | Pexp_lazy of expression
   | Pexp_poly of expression * core_type option
+  | Pexp_object of class_structure
 
 (* Value descriptions *)
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index be819a7d46..340917155f 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -292,6 +292,9 @@ and expression i ppf x =
       line i ppf "Pexp_poly\n";
       expression i ppf e;
       option i core_type ppf cto;
+  | Pexp_object s ->
+      line i ppf "Pexp_object";
+      class_structure i ppf s
 
 and value_description i ppf x =
   line i ppf "value_description\n";
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 8d5c3cb6a7..79d8505602 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -457,6 +457,41 @@ let send obj lab =
   let (buck, elem) = decode lab in
   (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
 
+(**** 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
+
 (**** Statistics ****)
 
 type stats =
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 5e945f931c..51441b2c2f 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -51,6 +51,11 @@ val run_initializers_opt : obj -> obj -> table -> obj
 val create_object_and_run_initializers : obj -> table -> obj
 val send : obj -> label -> t
 
+(** {6 Table cache} *)
+
+type tables
+val lookup_tables : tables -> table array -> tables
+
 (** {6 Parameters} *)
 
 type params =
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index d5f10ccf38..d53895099e 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1244,6 +1244,11 @@ let class_type_declarations env cls =
      decl,
    env)
 
+let () =
+  Typecore.type_object :=
+    (fun env s ->
+      incr class_num; class_structure (string_of_int !class_num) env env s)
+
 (*******************************)
 
 (* Approximate the class declaration as class ['params] id = object end *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 774469305f..150a806b96 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -67,6 +67,10 @@ let type_module =
   ref ((fun env md -> assert false) :
        Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
 
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+let type_object =
+  ref (fun env s -> assert false :
+       Env.t -> Parsetree.class_structure -> class_structure * class_signature)
 
 (*
   Saving and outputting type information.
@@ -1318,6 +1322,22 @@ let rec type_exp env sexp =
          exp_type = instance (Predef.type_lazy_t arg.exp_type);
          exp_env = env;
        }
+  | Pexp_object s ->
+      let desc, ({cty_self = sty} as cty) = !type_object env s in
+      hide_private_methods sty;
+      close_object sty;
+      let meths =
+        List.fold_right
+          (fun (s,k,_) l ->
+            if field_kind_repr k = Fpresent then s :: l else l)
+          (fst (flatten_fields (object_fields sty))) []
+      in
+      re {
+        exp_desc = Texp_object (desc, cty, meths);
+        exp_loc = sexp.pexp_loc;
+        exp_type = sty;
+        exp_env = env;
+      }
   | Pexp_poly _ ->
       assert false
 
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 06c479ea62..34c96b32e5 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -102,3 +102,7 @@ val report_error: formatter -> error -> unit
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
+(* Forward declaration, to be filled in by Typeclass.class_structure *)
+val type_object:
+  (Env.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * class_signature) ref
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 4b664b73fa..ab05b564dd 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -77,6 +77,7 @@ and expression_desc =
   | Texp_assert of expression
   | Texp_assertfalse
   | Texp_lazy of expression
+  | Texp_object of class_structure * class_signature * string list
 
 and meth =
     Tmeth_name of string
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 3f29b14346..587b088741 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -76,6 +76,7 @@ and expression_desc =
   | Texp_assert of expression
   | Texp_assertfalse
   | Texp_lazy of expression
+  | Texp_object of class_structure * class_signature * string list
 
 and meth =
     Tmeth_name of string