fast and compact classes

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

32 files changed, 1184 insertions, 286 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index a1c64eef2..8b739e39d 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 4916697c5..b62a2b463 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index e379a87af..dd1f57256 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -27,6 +27,7 @@ type error = Illegal_class_expr
 exception Error of Location.t * error
 
 let lfunction params body =
+  if params = [] then body else
   match body with
     Lfunction (Curried, params', body') ->
       Lfunction (Curried, params @ params', body')
@@ -43,13 +44,14 @@ let lapply func args =
 let lsequence l1 l2 =
   if l2 = lambda_unit then l1 else Lsequence(l1, l2)
 
-let transl_label l = Lconst (Const_base (Const_string l))
+let lfield v i = Lprim(Pfield i, [Lvar v])
+
+let transl_label l = share (Const_base (Const_string l))
 
 let rec transl_meth_list lst =
-  Lconst
-    (List.fold_right
-       (fun lab rem -> Const_block (0, [Const_base (Const_string lab); rem]))
-       lst (Const_pointer 0))
+  if lst = [] then Lconst (Const_pointer 0) else
+  share (Const_block
+            (0, List.map (fun lab -> Const_base (Const_string lab)) lst))
 
 let set_inst_var obj id expr =
   let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
@@ -65,15 +67,26 @@ let copy_inst_var obj id expr templ offset =
                                                    [Lvar id';
                                                     Lvar offset])])]))
 
-let transl_val tbl create name id rem =
-  Llet(StrictOpt, id, Lapply (oo_prim (if create then "new_variable"
-                                       else           "get_variable"),
-                              [Lvar tbl; transl_label name]),
-       rem)
+let transl_val tbl create name =
+  Lapply (oo_prim (if create then "new_variable" else "get_variable"),
+          [Lvar tbl; transl_label name])
 
-let transl_vals tbl create vals rem =
+let transl_vals tbl create sure vals rem =
+  if create && sure && List.length vals > 1 then
+    let (_,id0) = List.hd vals in
+    let call =
+      Lapply(oo_prim "new_variables",
+	     [Lvar tbl; transl_meth_list (List.map fst vals)]) in
+    let i = ref (List.length vals) in
+    Llet(Strict, id0, call,
+	 List.fold_right
+	   (fun (name,id) rem ->
+	     decr i; Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
+	   (List.tl vals) rem)
+  else
   List.fold_right
-    (fun (name, id) rem -> transl_val tbl create name id rem)
+    (fun (name, id) rem ->
+      Llet(StrictOpt, id, transl_val tbl create name, rem))
     vals rem
 
 let transl_super tbl meths inh_methods rem =
@@ -93,22 +106,27 @@ let create_object cl obj init =
   let (inh_init, obj_init) = init obj' in
   if obj_init = lambda_unit then
    (inh_init,
-    Lapply (oo_prim "create_object_and_run_initializers",
-            [Lvar obj; Lvar cl]))
+    Lapply (oo_prim "create_object_and_run_initializers", [obj; Lvar cl]))
   else begin
    (inh_init,
     Llet(Strict, obj',
-            Lapply (oo_prim "create_object_opt", [Lvar obj; Lvar cl]),
+            Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
          Lsequence(obj_init,
-                  Lapply (oo_prim "run_initializers_opt",
-                          [Lvar obj; Lvar obj'; Lvar cl]))))
+                   Lapply (oo_prim "run_initializers_opt",
+			   [obj; Lvar obj'; Lvar cl]))))
   end
 
-let rec build_object_init cl_table obj params inh_init cl =
+let rec build_object_init cl_table obj params inh_init obj_init cl =
   match cl.cl_desc with
     Tclass_ident path ->
       let obj_init = Ident.create "obj_init" in
-      (obj_init::inh_init, Lapply(Lvar obj_init, [Lvar obj]))
+      let envs, inh_init = inh_init in
+      let env =
+        match envs with None -> []
+        | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
+      in
+      ((envs, (obj_init, path)::inh_init),
+       Lapply(Lvar obj_init, env @ [obj]))
   | Tclass_structure str ->
       create_object cl_table obj (fun obj ->
         let (inh_init, obj_init) =
@@ -117,7 +135,8 @@ let rec build_object_init cl_table obj params inh_init cl =
                match field with
                  Cf_inher (cl, _, _) ->
                    let (inh_init, obj_init') =
-                     build_object_init cl_table obj [] inh_init cl
+                     build_object_init cl_table (Lvar obj) [] inh_init
+                       (fun _ -> lambda_unit) cl
                    in
                    (inh_init, lsequence obj_init' obj_init)
                | Cf_val (_, id, exp) ->
@@ -133,7 +152,7 @@ let rec build_object_init cl_table obj params inh_init cl =
                                       rem)
                          vals obj_init)))
             str.cl_field
-            (inh_init, lambda_unit)
+            (inh_init, obj_init obj)
         in
         (inh_init,
          List.fold_right
@@ -142,7 +161,7 @@ let rec build_object_init cl_table obj params inh_init cl =
            params obj_init))
   | Tclass_fun (pat, vals, cl, partial) ->
       let (inh_init, obj_init) =
-        build_object_init cl_table obj (vals @ params) inh_init cl
+        build_object_init cl_table obj (vals @ params) inh_init obj_init cl
       in
       (inh_init,
        let build params rem =
@@ -157,29 +176,32 @@ let rec build_object_init cl_table obj params inh_init cl =
        end)
   | Tclass_apply (cl, oexprs) ->
       let (inh_init, obj_init) =
-        build_object_init cl_table obj params inh_init cl
+        build_object_init cl_table obj params inh_init obj_init cl
       in
       (inh_init, transl_apply obj_init oexprs)
   | Tclass_let (rec_flag, defs, vals, cl) ->
       let (inh_init, obj_init) =
-        build_object_init cl_table obj (vals @ params) inh_init cl
+        build_object_init cl_table obj (vals @ params) inh_init obj_init cl
       in
       (inh_init, Translcore.transl_let rec_flag defs obj_init)
   | Tclass_constraint (cl, vals, pub_meths, concr_meths) ->
-      build_object_init cl_table obj params inh_init cl
+      build_object_init cl_table obj params inh_init obj_init cl
 
-let rec build_object_init_0 cl_table params cl =
+let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
   match cl.cl_desc with
     Tclass_let (rec_flag, defs, vals, cl) ->
-      let (inh_init, obj_init) =
-        build_object_init_0 cl_table (vals @ params) cl
-      in
-      (inh_init, Translcore.transl_let rec_flag defs obj_init)
+      build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
   | _ ->
-      let obj = Ident.create "self" in
-      let (inh_init, obj_init) = build_object_init cl_table obj params [] cl in
-      let obj_init = lfunction [obj] obj_init in
-      (inh_init, obj_init)
+      let self = Ident.create "self" in
+      let env = Ident.create "env" in
+      let obj = if ids = [] then lambda_unit else Lvar self in
+      let envs = if top then None else Some env in
+      let ((_,inh_init), obj_init) =
+        build_object_init cl_table obj params (envs,[]) (copy_env env) cl in
+      let obj_init =
+	if ids = [] then obj_init else lfunction [self] obj_init in
+      (inh_init, lfunction [env] (subst_env env obj_init))
+
 
 let bind_method tbl public_methods lab id cl_init =
   if List.mem lab public_methods then
@@ -192,138 +214,504 @@ let bind_method tbl public_methods lab id cl_init =
 let bind_methods tbl public_methods meths cl_init =
   Meths.fold (bind_method tbl public_methods) meths cl_init
 
-let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
+let output_methods tbl vals methods lam =
+  let lam =
+    match methods with
+      [] -> lam
+    | [lab; code] ->
+        lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+    | _ ->
+        lsequence (Lapply(oo_prim "set_methods",
+                         [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+          lam
+  in
+  transl_vals tbl true true vals lam
+
+let rec ignore_cstrs cl =
+  match cl.cl_desc with
+    Tclass_constraint (cl, _, _, _) -> ignore_cstrs cl
+  | Tclass_apply (cl, _) -> ignore_cstrs cl
+  | _ -> cl
+
+let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl =
   match cl.cl_desc with
     Tclass_ident path ->
       begin match inh_init with
-        obj_init::inh_init ->
+        (obj_init, path')::inh_init ->
+	  let lpath = transl_path path in
           (inh_init,
            Llet (Strict, obj_init, 
-                 Lapply(Lprim(Pfield 1, [transl_path path]), [Lvar cla]),
+                 Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
+			if top then [Lprim(Pfield 3, [lpath])] else []),
                  cl_init))
       | _ ->
           assert false
       end
   | Tclass_structure str ->
-      let (inh_init, cl_init) =
+      let (inh_init, cl_init, methods, values) =
         List.fold_right
-          (fun field (inh_init, cl_init) ->
+          (fun field (inh_init, cl_init, methods, values) ->
             match field with
               Cf_inher (cl, vals, meths) ->
-                build_class_init cla pub_meths false inh_init
-                  (transl_vals cla false vals
-                     (transl_super cla str.cl_meths meths cl_init))
-                  cl
+                let cl_init = output_methods cla values methods cl_init in
+                let inh_init, cl_init =
+                  build_class_init cla pub_meths false inh_init
+                    (transl_vals cla false false vals
+                       (transl_super cla str.cl_meths meths cl_init))
+                    msubst top cl in
+                (inh_init, cl_init, [], [])
             | Cf_val (name, id, exp) ->
-                (inh_init, transl_val cla true name id cl_init)
+                (inh_init, cl_init, methods, (name, id)::values)
             | Cf_meth (name, exp) ->
+                let met_code = msubst true (transl_exp exp) in
                 let met_code =
-                  if !Clflags.native_code then begin
+                  if !Clflags.native_code && List.length met_code = 1 then
                     (* 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);
-                                    met_code]),
+                    [Llet(Strict, met, List.hd met_code, Lvar met)]
+                  else met_code
+                in
+                (inh_init, cl_init,
+                 Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
+                 values)
+                 (*
+                 Lsequence(Lapply (oo_prim ("set_method" ^ builtin),
+                                   Lvar cla ::
+                                   Lvar (Meths.find name str.cl_meths) ::
+                                   met_code),
                            cl_init))
+                  *)
             | Cf_let (rec_flag, defs, vals) ->
                 let vals =
                   List.map (function (id, _) -> (Ident.name id, id)) vals
                 in
-                (inh_init, transl_vals cla true vals cl_init)
+                (inh_init, cl_init, methods, vals @ values)
             | Cf_init exp ->
                 (inh_init,
                  Lsequence(Lapply (oo_prim "add_initializer",
-                                   [Lvar cla; transl_exp exp]),
-                           cl_init)))
+                                   Lvar cla :: msubst false (transl_exp exp)),
+                           cl_init),
+                 methods, values))
           str.cl_field
-          (inh_init, cl_init)
+          (inh_init, cl_init, [], [])
       in
+      let cl_init = output_methods cla values methods cl_init in
       (inh_init, bind_methods cla pub_meths str.cl_meths cl_init)
   | Tclass_fun (pat, vals, cl, _) ->
       let (inh_init, cl_init) =
-        build_class_init cla pub_meths cstr inh_init cl_init cl
+        build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
       in
       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
-      (inh_init, transl_vals cla true vals cl_init)
+      (inh_init, transl_vals cla true false vals cl_init)
   | Tclass_apply (cl, exprs) ->
-      build_class_init cla pub_meths cstr inh_init cl_init cl
+      build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
   | Tclass_let (rec_flag, defs, vals, cl) ->
       let (inh_init, cl_init) =
-        build_class_init cla pub_meths cstr inh_init cl_init cl
+        build_class_init cla pub_meths cstr inh_init cl_init msubst top cl
       in
       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
-      (inh_init, transl_vals cla true vals cl_init)
+      (inh_init, transl_vals cla true false vals cl_init)
   | Tclass_constraint (cl, vals, meths, concr_meths) ->
-      let core cl_init =
-        build_class_init cla pub_meths true inh_init cl_init cl
-      in
-      if cstr then
-        core cl_init
-      else
-        let virt_meths =
-          List.fold_right
-            (fun lab rem ->
-               if Concr.mem lab concr_meths then rem else lab::rem)
-            meths
-            []
-        in
-        let (inh_init, cl_init) =
-          core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]),
-                           cl_init))
-        in
-        (inh_init,
-         Lsequence(Lapply (oo_prim "narrow",
-                           [Lvar cla;
-                             transl_meth_list vals;
-                             transl_meth_list virt_meths;
-                             transl_meth_list (Concr.elements concr_meths)]),
-                   cl_init))
+      let virt_meths =
+        List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
+      let narrow_args =
+	[Lvar cla;
+         transl_meth_list vals;
+         transl_meth_list virt_meths;
+         transl_meth_list (Concr.elements concr_meths)] in
+      let cl = ignore_cstrs cl in
+      begin match cl.cl_desc, inh_init with
+	Tclass_ident path, (obj_init, path')::inh_init ->
+	  assert (Path.same path path');
+	  let lpath = transl_path path in
+          (inh_init,
+           Llet (Strict, obj_init, 
+		 Lapply(oo_prim "inherits", narrow_args @
+			[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+                 cl_init))
+      | _ ->
+	  let core cl_init =
+            build_class_init cla pub_meths true inh_init cl_init msubst top cl
+	  in
+	  if cstr then core cl_init else
+          let (inh_init, cl_init) =
+            core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
+          in
+          (inh_init,
+           Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
+      end
 
+let rec build_class_lets cl =
+  match cl.cl_desc with
+    Tclass_let (rec_flag, defs, vals, cl) ->
+      let env, wrap = build_class_lets cl in
+      (env, fun x -> Translcore.transl_let rec_flag defs (wrap x))
+  | _ ->
+      (cl.cl_env, fun x -> x)
 
 (*
    XXX Il devrait etre peu couteux d'ecrire des classes :
      class c x y = d e f
 *)
+let rec transl_class_rebind obj_init cl =
+  match cl.cl_desc with
+    Tclass_ident path ->
+      (path, obj_init)
+  | Tclass_fun (pat, _, cl, partial) ->
+      let path, obj_init = transl_class_rebind obj_init cl in
+      let build params rem =
+        let param = name_pattern "param" [pat, ()] in
+        Lfunction (Curried, param::params,
+                   Matching.for_function
+                     pat.pat_loc None (Lvar param) [pat, rem] partial)
+      in
+      (path,
+       match obj_init with
+         Lfunction (Curried, params, rem) -> build params rem
+       | rem                              -> build [] rem)
+  | Tclass_apply (cl, oexprs) ->
+      let path, obj_init = transl_class_rebind obj_init cl in
+      (path, transl_apply obj_init oexprs)
+  | Tclass_let (rec_flag, defs, vals, cl) ->
+      let path, obj_init = transl_class_rebind obj_init cl in
+      (path, Translcore.transl_let rec_flag defs obj_init)
+  | Tclass_structure {cl_field = [Cf_inher(cl, _, _)]} ->
+      let path, obj_init = transl_class_rebind obj_init cl in
+      (path, obj_init)
+  | Tclass_structure _ -> raise Exit
+  | Tclass_constraint (cl', _, _, _) ->
+      let path, obj_init = transl_class_rebind obj_init cl' in
+      let rec check_constraint = function
+          Tcty_constr(path', _, _) when Path.same path path' -> ()
+        | Tcty_fun (_, _, cty) -> check_constraint cty
+        | _ -> raise Exit
+      in
+      check_constraint cl.cl_type;
+      (path, obj_init)
+
+let rec transl_class_rebind_0 self obj_init cl =
+  match cl.cl_desc with
+    Tclass_let (rec_flag, defs, vals, cl) ->
+      let path, obj_init = transl_class_rebind_0 self obj_init cl in
+      (path, Translcore.transl_let rec_flag defs obj_init)
+  | _ ->
+      let path, obj_init = transl_class_rebind obj_init cl in
+      (path, lfunction [self] obj_init)
+
+let transl_class_rebind ids cl =
+  try
+    let obj_init = Ident.create "obj_init"
+    and self = Ident.create "self" in
+    let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
+    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
+    if not (Translcore.check_recursive_lambda ids obj_init') then
+      raise(Error(cl.cl_loc, Illegal_class_expr));
+    let id = (obj_init' = lfunction [self] obj_init0) in
+    if id then transl_path path else
+
+    let cla = Ident.create "class"
+    and new_init = Ident.create "new_init"
+    and arg = Ident.create "arg"
+    and env_init = Ident.create "env_init"
+    and table = Ident.create "table"
+    and envs = Ident.create "envs" in
+    Llet(
+    Strict, new_init, lfunction [obj_init] obj_init',
+    Llet(
+    Alias, cla, transl_path path,
+    Lprim(Pmakeblock(0, Immutable),
+          [Lapply(Lvar new_init, [lfield cla 0]);
+           lfunction [table]
+             (Llet(Strict, env_init,
+                   Lapply(lfield cla 1, [Lvar table]),
+                   lfunction [envs]
+                     (Lapply(Lvar new_init,
+                             [Lapply(Lvar env_init, [Lvar envs])]))));
+           lfield cla 2;
+           lfield cla 3])))
+  with Exit ->
+    lambda_unit
+
+(* Rewrite a closure using builtins. Improves native code size. *)
+
+let rec module_path = function
+    Lvar id ->
+      let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
+  | Lprim(Pfield _, [p])    -> module_path p
+  | Lprim(Pgetglobal _, []) -> true
+  | _                       -> false
+
+let const_path local = function
+    Lvar id -> not (List.mem id local)
+  | Lconst _ -> true
+  | Lfunction (Curried, _, body) ->
+      let fv = free_variables body in
+      List.for_all (fun x -> not (IdentSet.mem x fv)) local
+  | p -> module_path p
+
+let rec builtin_meths self env env2 body =
+  let const_path = const_path (env::self) in
+  let conv = function
+    (* Lvar s when List.mem s self ->  "_self", [] *)
+    | p when const_path p -> "const", [p]
+    | Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self ->
+        "var", [Lvar n]
+    | Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
+        "env", [Lvar env2; Lconst(Const_pointer n)]
+    | Lsend(Lvar n, Lvar s, []) when List.mem s self ->
+        "meth", [Lvar n]
+    | _ -> raise Not_found
+  in
+  match body with
+  | Llet(Alias, s', Lvar s, body) when List.mem s self ->
+      builtin_meths self env env2 body
+  | Lapply(f, [arg]) when const_path f ->
+      let s, args = conv arg in ("app_"^s, f :: args)
+  | Lapply(f, [arg; p]) when const_path f && const_path p ->
+      let s, args = conv arg in
+      ("app_"^s^"_const", f :: args @ [p])
+  | Lapply(f, [p; arg]) when const_path f && const_path p ->
+      let s, args = conv arg in
+      ("app_const_"^s, f :: p :: args)
+  | Lsend(Lvar n, Lvar s, [arg]) when List.mem s self ->
+      let s, args = conv arg in
+      ("meth_app_"^s, Lvar n :: args)
+  | Lfunction (Curried, [x], body) ->
+      let rec enter self = function
+        | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
+          when Ident.same x x' && List.mem s self ->
+            ("set_var", [Lvar n])
+        | Llet(Alias, s', Lvar s, body) when List.mem s self ->
+            enter (s'::self) body
+        | _ -> raise Not_found
+      in enter self body
+  | Lfunction _ -> raise Not_found
+  | _ ->
+      let s, args = conv body in ("get_"^s, args)
+
+module M = struct
+  open CamlinternalOO
+  let builtin_meths arr self env env2 body =
+    let builtin, args = builtin_meths self env env2 body in
+    if not arr then [Lapply(oo_prim builtin, args)] else
+    let tag = match builtin with
+      "get_const" -> GetConst
+    | "get_var"   -> GetVar
+    | "get_env"   -> GetEnv
+    | "get_meth"  -> GetMeth
+    | "set_var"   -> SetVar
+    | "app_const" -> AppConst
+    | "app_var"   -> AppVar
+    | "app_env"   -> AppEnv
+    | "app_meth"  -> AppMeth
+    | "app_const_const" -> AppConstConst
+    | "app_const_var"   -> AppConstVar
+    | "app_const_env"   -> AppConstEnv
+    | "app_const_meth"  -> AppConstMeth
+    | "app_var_const"   -> AppVarConst
+    | "app_env_const"   -> AppEnvConst
+    | "app_meth_const"  -> AppMethConst
+    | "meth_app_const"  -> MethAppConst
+    | "meth_app_var"    -> MethAppVar
+    | "meth_app_env"    -> MethAppEnv
+    | "meth_app_meth"   -> MethAppMeth
+    | _ -> assert false
+    in Lconst(Const_pointer(Obj.magic tag)) :: args
+end
+open M
+
+
 (*
-   XXX
-   Exploiter le fait que les methodes sont definies dans l'ordre pour
-   l'initialisation des classes (et les variables liees par un
-   let ???) ?
+   Traduction d'une classe.
+   Plusieurs cas:
+    * reapplication d'une classe connue -> transl_class_rebind
+    * classe sans dependances locales -> traduction directe
+    * avec dependances locale -> creation d'un arbre de stubs,
+      avec un noeud pour chaque classe locale heritee
+   Une classe est un 4-uplet:
+    (obj_init, class_init, env_init, env)
+    obj_init: fonction de creation d'objet (unit -> obj)
+    class_init: fonction d'heritage (table -> env_init)
+      (une seule par code source)
+    env_init: parametrage par l'environnement local (env -> params -> obj_init)
+      (une par combinaison d'env_init herites)
+    env: environnement local
+   Si ids=0 (objet immediat), alors on ne conserve que env_init.
 *)
 
+
 let transl_class ids cl_id arity pub_meths cl =
+  (* First check if it is not only a rebind *)
+  let rebind = transl_class_rebind ids cl in
+  if rebind <> lambda_unit then rebind else
+
+  (* Prepare for heavy environment handling *)
+  let tables = Ident.create (Ident.name cl_id ^ "_tables") in
+  let (top_env, req) = oo_add_class tables in
+  let top = not req in
+  let cl_env, llets = build_class_lets cl in
+  let new_ids = if top then [] else Env.diff top_env cl_env in
+  let env2 = Ident.create "env" in
+  let subst env lam i0 new_ids' =
+    let fv = free_variables lam in
+    let fv = List.fold_right IdentSet.remove !new_ids' fv in
+    let fv =
+      IdentSet.filter (fun id -> List.mem id new_ids) fv in
+    new_ids' := !new_ids' @ IdentSet.elements fv;
+    let i = ref (i0-1) in
+    List.fold_left
+      (fun subst id ->
+        incr i; Ident.add id (lfield env !i)  subst)
+      Ident.empty !new_ids'
+  in
+  let new_ids_meths = ref [] in
+  let msubst arr = function
+      Lfunction (Curried, self :: args, body) ->
+        let env = Ident.create "env" in
+        let body' =
+          if new_ids = [] then body else
+          subst_lambda (subst env body 0 new_ids_meths) body in
+        begin try
+          (* Doesn't seem to improve size for bytecode *)
+          (* if not !Clflags.native_code then raise Not_found; *)
+          builtin_meths arr [self] env env2 (lfunction args body')
+        with Not_found ->
+          [lfunction (self :: args)
+             (if not (IdentSet.mem env (free_variables body')) then body' else
+              Llet(Alias, env,
+                   Lprim(Parrayrefu Paddrarray,
+                         [Lvar self; Lvar env2]), body'))]
+        end
+      | _ -> assert false
+  in
+  let new_ids_init = ref [] in
+  let env1 = Ident.create "env" in
+  let copy_env envs self =
+    if top then lambda_unit else
+    Lifused(env2, Lprim(Parraysetu Paddrarray,
+                        [Lvar self; Lvar env2; lfield env1 0]))
+  and subst_env envs lam =
+    if top then lam else
+    Llet(Alias, env1, lfield envs 0,
+	 subst_lambda (subst env1 lam 1 new_ids_init) lam)
+  in
+
+  (* Now we start compiling the class *)
   let cla = Ident.create "class" in
-  let (inh_init, obj_init) = build_object_init_0 cla [] cl in
+  let (inh_init, obj_init) =
+    build_object_init_0 cla [] cl copy_env subst_env top ids in
   if not (Translcore.check_recursive_lambda ids obj_init) then
     raise(Error(cl.cl_loc, Illegal_class_expr));
-  let (inh_init, cl_init) =
-    build_class_init cla pub_meths true (List.rev inh_init) obj_init cl
+  let (inh_init', cl_init) =
+    build_class_init cla pub_meths true (List.rev inh_init)
+      obj_init msubst top cl
+  in
+  assert (inh_init' = []);
+  let table = Ident.create "table"
+  and class_init = Ident.create "class_init"
+  and env_init = Ident.create "env_init"
+  and obj_init = Ident.create "obj_init" in
+  let ltable table lam =
+    Llet(Strict, table,
+         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]),
+                   Lapply(Lvar obj_init, [lambda_unit])))
   in
-  assert (inh_init = []);
-  let table = Ident.create "table" in
-  let class_init = Ident.create "class_init" in
-  let obj_init = Ident.create "obj_init" in
-  Llet(Strict, table,
-       Lapply (oo_prim "create_table", [transl_meth_list pub_meths]),
-  Llet(Strict, class_init,
-       Lfunction(Curried, [cla], cl_init),
-  Llet(Strict, obj_init, Lapply(Lvar class_init, [Lvar table]),
-  Lsequence(Lapply (oo_prim "init_class", [Lvar table]),
-            Lprim(Pmakeblock(0, Immutable),
-                  [Lvar obj_init;
-                   Lvar class_init;
-                   Lvar table])))))
-
-let class_stub =
-  Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit])
+  (* Simplest case: an object defined at toplevel (ids=[]) *)
+  if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
+
+  let lclass lam =
+    Llet(Strict, class_init, Lfunction(Curried, [cla], cl_init), lam)
+  and lbody =
+    Lapply (oo_prim "make_class",
+            [transl_meth_list pub_meths; Lvar class_init])
+  in
+  (* Still easy: a class defined at toplevel *)
+  if top then llets (lclass lbody) else
+
+  (* Now for the hard stuff: prepare for table cacheing *)
+  let env_index = Ident.create "env_index"
+  and envs = Ident.create "envs" in
+  let lenvs =
+    if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
+    then lambda_unit
+    else Lvar envs in
+  let lenv =
+    if !new_ids_meths = [] && !new_ids_init = [] then lambda_unit else
+    Lprim(Pmakeblock(0, Immutable),
+          (if !new_ids_meths = [] then lambda_unit else
+           Lprim(Pmakeblock(0, Immutable),
+                 List.map (fun id -> Lvar id) !new_ids_meths)) ::
+          List.map (fun id -> Lvar id) !new_ids_init)
+  and linh_envs =
+    List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
+      (List.rev inh_init)
+  in
+  let make_envs lam =
+    Llet(StrictOpt, envs,
+         Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs),
+         lam)
+  and def_ids cla lam =
+    Llet(StrictOpt, env2,
+         Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
+         lam)
+  in
+  let obj_init2 = Ident.create "obj_init"
+  and cached = Ident.create "cached" in
+  let inh_paths =
+    List.filter
+      (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
+  let inh_keys =
+    List.map (fun (_,p) -> Lprim(Pfield 2, [transl_path p])) inh_paths in
+  let lclass lam =
+    Llet(Strict, class_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)
+  and lset cached i lam =
+    Lprim(Psetfield(i, true), [Lvar cached; lam])
+  in
+  let ldirect () =
+    ltable cla
+      (Llet(Strict, env_init, def_ids cla cl_init,
+            Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
+                      lset cached 0 (Lvar env_init))))
+  in
+  llets (
+  lcache (
+  Lsequence(
+  Lifthenelse(lfield cached 0, lambda_unit,
+              if ids = [] then ldirect () else
+              lclass (
+              Lapply (oo_prim "make_class_store",
+                      [transl_meth_list pub_meths;
+                       Lvar class_init; Lvar cached]))),
+  make_envs (
+  if ids = [] then Lapply(lfield cached 0, [lenvs]) else
+  Lprim(Pmakeblock(0, Immutable),
+        [Lapply(lfield cached 0, [lenvs]);
+         lfield cached 1;
+         lfield cached 0;
+         lenvs])))))
+
+(* Dummy for recursive modules *)
 
 let dummy_class undef_fn =
-  Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"])
+  Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; undef_fn; lambda_unit])
+
+(* Wrapper for class compilation *)
+
+let transl_class ids cl_id arity pub_meths cl =
+  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
+
+let () =
+  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
 
 (* Error report *)
 
diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index a546b8afc..a17a0b117 100644
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -15,7 +15,6 @@
 open Typedtree
 open Lambda
 
-val class_stub : lambda
 val dummy_class : lambda -> lambda
 val transl_class :
   Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index a47a0c915..49f4bd8ae 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 [
@@ -500,9 +504,23 @@ let assert_failed loc =
 (* Translation of expressions *)
 
 let rec transl_exp e =
+  let eval_once =
+    (* Whether classes for immediate objects must be cached *)
+    match e.exp_desc with
+      Texp_function _ | Texp_for _ | Texp_while _ -> false
+    | _ -> true
+  in
+  if eval_once then transl_exp0 e else
+  Translobj.oo_wrap e.exp_env true transl_exp0 e
+
+and transl_exp0 e =
   match e.exp_desc with
     Texp_ident(path, {val_kind = Val_prim p}) ->
-      transl_primitive p
+      if p.prim_name = "%send" then
+	let obj = Ident.create "obj" and meth = Ident.create "meth" in
+	Lfunction(Curried, [obj; meth], Lsend(Lvar meth, Lvar obj, []))
+      else
+	transl_primitive p
   | Texp_ident(path, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
@@ -524,7 +542,10 @@ let rec transl_exp e =
     when List.length args = p.prim_arity
     && List.for_all (fun (arg,_) -> arg <> None) args ->
       let args = List.map (function Some x, _ -> x | _ -> assert false) args in
-      let prim = transl_prim p args in
+      if p.prim_name = "%send" then
+	let obj = transl_exp (List.hd args) in
+	event_after e (Lsend (transl_exp (List.nth args 1), obj, []))
+      else let prim = transl_prim p args in
       begin match (prim, args) with
         (Praise, [arg1]) ->
           Lprim(Praise, [event_after arg1 (transl_exp arg1)])
@@ -665,6 +686,13 @@ 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
+      !transl_object cl meths
+        { cl_desc = Tclass_structure cs;
+          cl_loc = e.exp_loc;
+          cl_type = Tcty_signature cty;
+          cl_env = e.exp_env }
 
 and transl_list expr_list =
   List.map transl_exp expr_list
@@ -735,33 +763,6 @@ and transl_function loc untuplify_fn repr partial pat_expr_list =
         transl_function exp.exp_loc false repr partial' pl in
       ((Curried, param :: params),
        Matching.for_function loc None (Lvar param) [pat, body] partial)
-(*
-  | [({pat_desc = Tpat_var id} as pat),
-     ({exp_desc = Texp_let(Nonrecursive, cases,
-                          ({exp_desc = Texp_function _} as e2))} as e1)]
-    when Ident.name id = "*opt*" ->
-      transl_function loc untuplify_fn repr (cases::bindings) partial [pat, e2]
-  | [pat, exp] when bindings <> [] ->
-      let exp =
-        List.fold_left
-          (fun exp cases ->
-            {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
-          exp bindings
-      in
-      transl_function loc untuplify_fn repr [] partial [pat, exp]
-  | (pat, exp)::_ when bindings <> [] ->
-      let param = name_pattern "param" pat_expr_list in
-      let exp =
-        { exp with exp_loc = loc; exp_desc =
-          Texp_match
-            ({exp with exp_type = pat.pat_type; exp_desc =
-              Texp_ident (Path.Pident param,
-                          {val_type = pat.pat_type; val_kind = Val_reg})},
-             pat_expr_list, partial) }
-      in
-      transl_function loc untuplify_fn repr bindings Total
-        [{pat with pat_desc = Tpat_var param}, exp]
-*)
   | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
       begin try
         let size = List.length pl in
@@ -877,6 +878,19 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
     end
   end
 
+(* Wrapper for class compilation *)
+
+(*
+let transl_exp = transl_exp_wrap
+
+let transl_let rec_flag pat_expr_list body =
+  match pat_expr_list with
+    [] -> body
+  | (_, expr) :: _ ->
+      Translobj.oo_wrap expr.exp_env false
+        (transl_let rec_flag pat_expr_list) body
+*)
+
 (* Compile an exception definition *)
 
 let transl_exception id path decl =
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 3ad655b22..8148f9b8a 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 55b256b35..da9e5d892 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -248,19 +248,22 @@ let rec transl_module cc rootpath mexp =
       transl_structure [] cc rootpath str
   | Tmod_functor(param, mty, body) ->
       let bodypath = functor_path rootpath param in
-      begin match cc with
-        Tcoerce_none ->
-          Lfunction(Curried, [param], transl_module Tcoerce_none bodypath body)
-      | Tcoerce_functor(ccarg, ccres) ->
-          let param' = Ident.create "funarg" in
-          Lfunction(Curried, [param'],
-            Llet(Alias, param, apply_coercion ccarg (Lvar param'),
-              transl_module ccres bodypath body))
-      | _ ->
-          fatal_error "Translmod.transl_module"
-      end
+      oo_wrap mexp.mod_env true
+        (function
+        | Tcoerce_none ->
+            Lfunction(Curried, [param],
+                      transl_module Tcoerce_none bodypath body)
+        | Tcoerce_functor(ccarg, ccres) ->
+            let param' = Ident.create "funarg" in
+            Lfunction(Curried, [param'],
+                      Llet(Alias, param, apply_coercion ccarg (Lvar param'),
+                           transl_module ccres bodypath body))
+        | _ ->
+            fatal_error "Translmod.transl_module")
+        cc
   | Tmod_apply(funct, arg, ccarg) ->
-      apply_coercion cc
+      oo_wrap mexp.mod_env true
+        (apply_coercion cc)
         (Lapply(transl_module Tcoerce_none None funct,
                 [transl_module ccarg None arg]))
   | Tmod_constraint(arg, mty, ccarg) ->
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 20794b1f4..ea449202e 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -26,6 +26,22 @@ let oo_prim name =
   with Not_found ->
     fatal_error ("Primitive " ^ name ^ " not found.")
 
+(* Share blocks *)
+
+let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17
+
+let share c =
+  match c with
+    Const_block (n, l) when l <> [] ->
+      begin try
+        Lvar (Hashtbl.find consts c)
+      with Not_found ->
+        let id = Ident.create "shared" in
+        Hashtbl.add consts c id;
+        Lvar id
+      end
+  | _ -> Lconst c
+
 (* Collect labels *)
 
 let used_methods = ref ([] : (string * Ident.t) list);;
@@ -39,6 +55,7 @@ let meth lab =
     id
 
 let reset_labels () =
+  Hashtbl.clear consts;
   used_methods := []
 
 (* Insert labels *)
@@ -46,17 +63,61 @@ let reset_labels () =
 let string s = Lconst (Const_base (Const_string s))
 
 let transl_label_init expr =
-  if !used_methods = [] then
-    expr
-  else
+  let expr =
+    Hashtbl.fold
+      (fun c id expr -> Llet(Alias, id, Lconst c, expr))
+      consts expr
+  in
+  let expr =
+    if !used_methods = [] then expr else
     let init = Ident.create "new_method" in
-    let expr' =
-      Llet(StrictOpt, init, oo_prim "new_method",
-      List.fold_right
-        (fun (lab, id) expr ->
-           Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr))
-        !used_methods
-        expr)
+    Llet(StrictOpt, init, oo_prim "new_method",
+         List.fold_right
+           (fun (lab, id) expr ->
+             Llet(StrictOpt, id, Lapply(Lvar init, [string lab]), expr))
+           !used_methods
+           expr)
+  in
+  reset_labels ();
+  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, !required)
+
+let oo_wrap env req f x =
+  if !wrapping then
+    if !required then f x else
+    try required := true; let lam = f x in required := false; lam
+    with exn -> required := false; 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),
+                     [lambda_unit; lambda_unit; lambda_unit]),
+               lambda))
+        lambda !classes
     in
-    reset_labels ();
-    expr'
+    wrapping := false;
+    top_env := Env.empty;
+    lambda
+  with exn ->
+    wrapping := false;
+    top_env := Env.empty;
+    raise exn
+    
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index ccff9ade6..f0a92b332 100644
--- a/bytecomp/translobj.mli
+++ b/bytecomp/translobj.mli
@@ -12,9 +12,15 @@
 
 (* $Id$ *)
 
-val oo_prim: string -> Lambda.lambda
+open Lambda
 
+val oo_prim: string -> lambda
+
+val share: structured_constant -> lambda
 val meth: string -> Ident.t
 
 val reset_labels: unit -> unit
-val transl_label_init: Lambda.lambda -> Lambda.lambda
+val transl_label_init: lambda -> lambda
+
+val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
+val oo_add_class: Ident.t -> Env.t * bool
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 78316c77e..430d52040 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -674,6 +674,23 @@ let rec search_pos_structure ~pos str =
   | Tstr_include (m, _) -> search_pos_module_expr m ~pos
   end
 
+and search_pos_class_structure ~pos cls =
+  List.iter cls.cl_field ~f:
+    begin function
+        Cf_inher (cl, _, _) ->
+          search_pos_class_expr cl ~pos
+      | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
+      | Cf_meth (_, exp) -> search_pos_expr exp ~pos
+      | Cf_let (_, pel, iel) ->
+          List.iter pel ~f:
+            begin fun (pat, exp) ->
+              search_pos_pat pat ~pos ~env:exp.exp_env;
+              search_pos_expr exp ~pos
+            end;
+          List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
+      | Cf_init exp -> search_pos_expr exp ~pos
+    end
+
 and search_pos_class_expr ~pos cl =
   if in_loc cl.cl_loc ~pos then begin
     begin match cl.cl_desc with
@@ -681,21 +698,7 @@ and search_pos_class_expr ~pos cl =
         add_found_str (`Class (path, cl.cl_type))
           ~env:!start_env ~loc:cl.cl_loc
     | Tclass_structure cls ->
-        List.iter cls.cl_field ~f:
-          begin function
-              Cf_inher (cl, _, _) ->
-                search_pos_class_expr cl ~pos
-            | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
-            | Cf_meth (_, exp) -> search_pos_expr exp ~pos
-            | Cf_let (_, pel, iel) ->
-                List.iter pel ~f:
-                  begin fun (pat, exp) ->
-                    search_pos_pat pat ~pos ~env:exp.exp_env;
-                    search_pos_expr exp ~pos
-                  end;
-                List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
-            | Cf_init exp -> search_pos_expr exp ~pos
-          end
+	search_pos_class_structure ~pos cls
     | Tclass_fun (pat, iel, cl, _) ->
         search_pos_pat pat ~pos ~env:pat.pat_env;
         List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
@@ -802,6 +805,9 @@ and search_pos_expr ~pos exp =
       search_pos_expr exp ~pos
   | Texp_lazy exp ->
       search_pos_expr exp ~pos
+  | Texp_object (cls, _, _) ->
+      	search_pos_class_structure ~pos cls
+
   end;
   add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
   end
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)";;
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
index b34726aef..5a98e161e 100644
--- a/tools/addlabels.ml
+++ b/tools/addlabels.ml
@@ -276,7 +276,7 @@ let rec add_labels_expr ~text ~values ~classes expr =
   | Pexp_override lst ->
       List.iter lst ~f:(fun (_,e) -> add_labels_rec e)
   | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _
-  | Pexp_new _ | Pexp_assertfalse ->
+  | Pexp_new _ | Pexp_assertfalse | Pexp_object _ ->
       ()
 
 let rec add_labels_class ~text ~classes ~values ~methods cl =
diff --git a/tools/depend.ml b/tools/depend.ml
index 46be7b355..8871d908d 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -154,7 +154,8 @@ let rec add_expr bv exp =
   | Pexp_assertfalse -> ()
   | Pexp_lazy (e) -> add_expr bv e
   | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
-
+  | Pexp_object (pat, fieldl) ->
+      add_pattern bv pat; List.iter (add_class_field bv) fieldl
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
 
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 0a0d71906..f1b637baf 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -282,6 +282,9 @@ and rw_exp iflag sexp =
 
   | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp
 
+  | Pexp_object (_, fieldl) ->
+      List.iter (rewrite_class_field iflag) fieldl
+
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
     insert_profile rw_exp sifbody
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 682151dd5..17be1316a 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -177,6 +177,8 @@ module TypePairs =
 
 (**** Object field manipulation. ****)
 
+let dummy_method = "*dummy method*"
+
 let object_fields ty =
   match (repr ty).desc with
     Tobject (fields, _) -> fields
@@ -452,7 +454,7 @@ let closed_class params sign =
   List.iter mark_type params;
   mark_type rest;
   List.iter
-    (fun (lab, _, ty) -> if lab = "*dummy method*" then mark_type ty)
+    (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty)
     fields;
   try
     mark_type_node (repr sign.cty_self);
@@ -603,13 +605,8 @@ let rec update_level env level ty =
         end;
         set_level ty level;
         iter_type_expr (update_level env level) ty
-    | Tfield(_, k, _, _) ->
-        begin match field_kind_repr k with
-          Fvar _ (* {contents = None} *) -> raise (Unify [(ty, newvar2 level)])
-        | _                              -> ()
-        end;
-        set_level ty level;
-        iter_type_expr (update_level env level) ty
+    | Tfield(lab, _, _, _) when lab = dummy_method ->
+        raise (Unify [(ty, newvar2 level)])
     | _ ->
         set_level ty level;
         (* XXX what about abbreviations in Tconstr ? *)
@@ -1448,7 +1445,7 @@ and unify3 env t1 t1' t2 t2' =
         (* XXX One should do some kind of unification... *)
         begin match (repr t2').desc with
           Tobject (_, {contents = Some (_, va::_)})
-          when let va = repr va in va.desc = Tvar || va.desc = Tunivar ->
+          when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
             ()
         | Tobject (_, nm2) ->
             set_name nm2 !nm1
@@ -1459,6 +1456,11 @@ and unify3 env t1 t1' t2 t2' =
         unify_row env row1 row2
     | (Tfield _, Tfield _) ->           (* Actually unused *)
         unify_fields env t1' t2'
+    | (Tfield(_,kind,_,rem), Tnil) | (Tnil, Tfield(_,kind,_,rem)) ->
+        begin match field_kind_repr kind with
+          Fvar r -> r := Some Fabsent
+        | _      -> raise (Unify [])
+        end
     | (Tnil, Tnil) ->
         ()
     | (Tpoly (t1, []), Tpoly (t2, [])) ->
@@ -2569,6 +2571,24 @@ let rec filter_visited = function
 let memq_warn t visited =
   if List.memq t visited then (warn := true; true) else false
 
+let rec lid_of_path sharp = function
+    Path.Pident id ->
+      Longident.Lident (sharp ^ Ident.name id)
+  | Path.Pdot (p1, s, _) ->
+      Longident.Ldot (lid_of_path "" p1, sharp ^ s)
+  | Path.Papply (p1, p2) ->
+      Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
+
+let find_cltype_for_path env p =
+  let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
+  match cl_abbr.type_manifest with
+    Some ty ->
+      begin match (repr ty).desc with
+        Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty
+      | _ -> raise Not_found
+      end
+  | None -> assert false
+
 let rec build_subtype env visited loops posi level t =
   let t = repr t in
   match t.desc with
@@ -2604,22 +2624,7 @@ let rec build_subtype env visited loops posi level t =
       let level' = pred_expand level in
       begin try match t'.desc with
         Tobject _ when posi && not (opened_object t') ->
-          let rec lid_of_path sharp = function
-              Path.Pident id ->
-                Longident.Lident (sharp ^ Ident.name id)
-            | Path.Pdot (p1, s, _) ->
-                Longident.Ldot (lid_of_path "" p1, sharp ^ s)
-            | Path.Papply (p1, p2) ->
-                Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
-          in
-          let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
-          let body =
-            match cl_abbr.type_manifest with Some ty ->
-              begin match (repr ty).desc with
-                Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> ty
-              | _ -> raise Not_found
-              end
-            | None -> assert false in
+          let cl_abbr, body = find_cltype_for_path env p in
           let ty =
             subst env !current_level abbrev None cl_abbr.type_params tl body in
           let ty = repr ty in
diff --git a/typing/ctype.mli b/typing/ctype.mli
index ae4f15dd9..bc0ce50cc 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -53,6 +53,7 @@ val none: type_expr
 val repr: type_expr -> type_expr
         (* Return the canonical representative of a type. *)
 
+val dummy_method: label
 val object_fields: type_expr -> type_expr
 val flatten_fields:
         type_expr -> (string * field_kind * type_expr) list * type_expr
@@ -72,6 +73,7 @@ val set_object_name:
         Ident.t -> type_expr -> type_expr list -> type_expr -> unit
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
+val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
 
 val sort_row_fields: (label * row_field) list -> (label * row_field) list
 val merge_row_fields:
@@ -189,7 +191,7 @@ val match_class_declarations:
 
 val enlarge_type: Env.t -> type_expr -> type_expr * bool
         (* Make a type larger, flag is true if some pruning had to be done *)
-val subtype : Env.t -> type_expr -> type_expr -> unit -> unit
+val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
         (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
            It accumulates the constraints the type variables must
            enforce and returns a function that inforce this
diff --git a/typing/env.ml b/typing/env.ml
index 807d345e0..4ccb7f7e2 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -88,6 +88,20 @@ let empty = {
   cltypes = Ident.empty;
   summary = Env_empty }
 
+let diff_keys tbl1 tbl2 =
+  let keys2 = Ident.keys tbl2 in
+  List.filter
+    (fun id ->
+      match Ident.find_same id tbl2 with Pident _, _ ->
+        (try ignore (Ident.find_same id tbl1); false with Not_found -> true)
+      | _ -> false)
+    keys2
+
+let diff env1 env2 =
+  diff_keys env1.values env2.values @
+  diff_keys env1.modules env2.modules @
+  diff_keys env1.classes env2.classes
+
 (* Forward declarations *)
 
 let components_of_module' =
diff --git a/typing/env.mli b/typing/env.mli
index 4f247e6ae..aec0c29da 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -20,6 +20,7 @@ type t
 
 val empty: t
 val initial: t
+val diff: t -> t -> Ident.t list
 
 (* Lookup by paths *)
 
diff --git a/typing/ident.ml b/typing/ident.ml
index 8997600d5..ccc132f09 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -159,3 +159,14 @@ let rec find_name name = function
         k.data
       else
         find_name name (if c < 0 then l else r)
+
+let rec keys_aux stack accu = function
+    Empty ->
+      begin match stack with
+        [] -> accu
+      | a :: l -> keys_aux l accu a
+      end
+  | Node(l, k, r, _) ->
+      keys_aux (l :: stack) (k.ident :: accu) r
+
+let keys tbl = keys_aux [] [] tbl
diff --git a/typing/ident.mli b/typing/ident.mli
index 1bec7fb7a..ccb0ca46f 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -54,3 +54,4 @@ val empty: 'a tbl
 val add: t -> 'a -> 'a tbl -> 'a tbl
 val find_same: t -> 'a tbl -> 'a
 val find_name: string -> 'a tbl -> 'a
+val keys: 'a tbl -> t list
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index c17e1fd89..232a32abb 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -615,7 +615,7 @@ let class_var sch ppf l (m, t) =
     "@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
 
 let metho sch concrete ppf (lab, kind, ty) =
-  if lab <> "*dummy method*" then begin
+  if lab <> dummy_method then begin
     let priv =
       match field_kind_repr kind with
       | Fvar _ (* {contents = None} *) -> "private "
@@ -632,7 +632,7 @@ let method_type ty =
   | _            -> ty
 
 let tree_of_metho sch concrete csil (lab, kind, ty) =
-  if lab <> "*dummy method*" then begin
+  if lab <> dummy_method then begin
     let priv =
       match field_kind_repr kind with
       | Fvar _ (* {contents = None} *) -> true
@@ -765,7 +765,7 @@ let tree_of_cltype_declaration id cl =
       Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
     List.exists
       (fun (lab, _, ty) ->
-         not (lab = "*dummy method*" || Concr.mem lab sign.cty_concr))
+         not (lab = dummy_method || Concr.mem lab sign.cty_concr))
       fields in
 
   Osig_class_type
@@ -918,8 +918,8 @@ let explanation unif t3 t4 ppf =
   | Tvar, Tunivar | Tunivar, Tvar ->
       fprintf ppf "@,The universal variable %a would escape its scope"
         type_expr (if t3.desc = Tunivar then t3 else t4)
-  | Tfield ("*dummy method*", _, _, _), _
-  | _, Tfield ("*dummy method*", _, _, _) ->
+  | Tfield (lab, _, _, _), _
+  | _, Tfield (lab, _, _, _) when lab = dummy_method ->
       fprintf ppf
         "@,Self type cannot be unified with a closed object type"
   | Tfield (l, _, _, _), _ ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c2a318bd8..eecc265d3 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -48,6 +48,7 @@ type error =
   | Cannot_coerce_self of type_expr
   | Non_collapsable_conjunction of
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
+  | Final_self_clash of (type_expr * type_expr) list
 
 exception Error of Location.t * error
 
@@ -61,7 +62,7 @@ exception Error of Location.t * error
    Self type have a dummy private method, thus preventing it to become
    closed.
 *)
-let dummy_method = "*dummy method*"
+let dummy_method = Ctype.dummy_method
 
 (*
    Path associated to the temporary class type of a class being typed
@@ -95,8 +96,7 @@ let rec generalize_class_type =
       generalize_class_type cty
 
 (* Return the virtual methods of a class type *)
-let virtual_methods cty =
-  let sign = Ctype.signature_of_class_type cty in
+let virtual_methods sign =
   let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
   List.fold_left
     (fun virt (lab, _, _) ->
@@ -469,6 +469,7 @@ let rec class_field cl_num self_type meths vars
         raise(Error(loc, Method_type_mismatch (lab, trace)))
       end;
       let meth_expr = make_method cl_num expr in
+      (* backup variables for Pexp_override *)
       let vars_local = !vars in
 
       let field =
@@ -535,28 +536,45 @@ let rec class_field cl_num self_type meths vars
       (val_env, met_env, par_env, field::fields,
        concr_meths, warn_meths, inh_vals)
 
-and class_structure cl_num val_env met_env (spat, str) =
+and class_structure cl_num final val_env met_env loc (spat, str) =
   (* Environment for substructures *)
   let par_env = met_env in
 
+  (* Private self type more method access, with a dummy method preventing
+     it from being closed/escaped. *)
+  let self_type = Ctype.newvar () in
+  Ctype.unify val_env
+    (Ctype.filter_method val_env dummy_method Private self_type)
+    (Ctype.newty (Ttuple []));
+
   (* Self binder *)
   let (pat, meths, vars, val_env, meth_env, par_env) =
-    type_self_pattern cl_num val_env met_env par_env spat
+    type_self_pattern cl_num self_type val_env met_env par_env spat
   in
-  let self_type = pat.pat_type in
+  let public_self = pat.pat_type in
 
-  (* Check that the binder has a correct type, and introduce a dummy
-     method preventing self type from being closed. *)
-  let ty = Ctype.newvar () in
-  Ctype.unify val_env
-      (Ctype.filter_method val_env dummy_method Private ty)
-      (Ctype.newty (Ttuple []));
-  begin try Ctype.unify val_env self_type ty with
+  (* Check that the binder has a correct type *)
+  let ty =
+    if final then Ctype.newty (Tobject (Ctype.newvar(), ref None))
+    else self_type in
+  begin try Ctype.unify val_env public_self ty with
     Ctype.Unify _ ->
-      raise(Error(spat.ppat_loc, Pattern_type_clash self_type))
+      raise(Error(spat.ppat_loc, Pattern_type_clash public_self))
+  end;
+  let get_methods ty =
+    (fst (Ctype.flatten_fields
+            (Ctype.object_fields (Ctype.expand_head val_env ty)))) in
+  if final then begin
+    (* Copy known information to still empty self_type *)
+    List.iter
+      (fun (lab,kind,ty) ->
+        try Ctype.unify val_env ty
+            (Ctype.filter_method val_env lab Public self_type)
+        with _ -> assert false)
+      (get_methods public_self)
   end;
 
-  (* Class fields *)
+  (* Typing of class fields *)
   let (_, _, _, fields, concr_meths, _, _) =
     List.fold_left (class_field cl_num self_type meths vars)
       (val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
@@ -564,22 +582,56 @@ and class_structure cl_num val_env met_env (spat, str) =
       str
   in
   Ctype.unify val_env self_type (Ctype.newvar ());
-  let methods =
-    if !Clflags.principal then
-      fst (Ctype.flatten_fields (Ctype.object_fields self_type))
-    else [] in
-  List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
-  let vars_final = !vars in
-  let fields = List.map Lazy.force (List.rev fields) in
-  vars := vars_final;
-  List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) methods;
-
-  {cl_field = fields;
-   cl_meths = Meths.map (function (id, ty) -> id) !meths},
+  let sign =
+    {cty_self = public_self;
+     cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
+     cty_concr = concr_meths } in
+  let methods = get_methods self_type in
+  let priv_meths =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
+      methods in
+  if final then begin
+    (* Unify public_self and a copy of self_type. self_type will not
+       be modified after this point *)
+    Ctype.close_object self_type;
+    let mets = virtual_methods {sign with cty_self = self_type} in
+    if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
+    let self_methods =
+      List.fold_right
+        (fun (lab,kind,ty) rem ->
+          if lab = dummy_method then rem else
+          Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+        methods (Ctype.newty Tnil) in
+    begin try Ctype.unify val_env public_self
+        (Ctype.newty (Tobject(self_methods, ref None)))
+    with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
+    end;
+  end;
 
-  {cty_self = self_type;
-   cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
-   cty_concr = concr_meths }
+  (* Typing of method bodies *)
+  if !Clflags.principal then
+    List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
+  let fields = List.map Lazy.force (List.rev fields) in
+  if !Clflags.principal then
+    List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ()))
+      methods;
+  let meths = Meths.map (function (id, ty) -> id) !meths in
+
+  (* Check for private methods made public *)
+  let pub_meths' =
+    List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
+      (get_methods public_self) in
+  let names = List.map (fun (x,_,_) -> x) in
+  let l1 = names priv_meths and l2 = names pub_meths' in
+  let added = List.filter (fun x -> List.mem x l1) l2 in
+  if added <> [] then
+    Location.prerr_warning loc
+      (Warnings.Other
+         (String.concat " "
+            ("the following private methods were made public implicitly:\n "
+             :: added)));
+
+  {cl_field = fields; cl_meths = meths}, sign
 
 and class_expr cl_num val_env met_env scl =
   match scl.pcl_desc with
@@ -610,17 +662,21 @@ and class_expr cl_num val_env met_env scl =
       let cl =        
         rc {cl_desc = Tclass_ident path;
             cl_loc = scl.pcl_loc;
-            cl_type = clty'}
+            cl_type = clty';
+            cl_env = val_env}
       in
       let (vals, meths, concrs) = extract_constraints clty in
       rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
           cl_loc = scl.pcl_loc;
-          cl_type = clty'}
+          cl_type = clty';
+          cl_env = val_env}
   | Pcl_structure cl_str ->
-      let (desc, ty) = class_structure cl_num val_env met_env cl_str in
+      let (desc, ty) =
+        class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
       rc {cl_desc = Tclass_structure desc;
           cl_loc = scl.pcl_loc;
-          cl_type = Tcty_signature ty}
+          cl_type = Tcty_signature ty;
+          cl_env = val_env}
   | Pcl_fun (l, Some default, spat, sbody) ->
       let loc = default.pexp_loc in
       let scases =
@@ -682,7 +738,8 @@ and class_expr cl_num val_env met_env scl =
           (Warnings.Other "This optional argument cannot be erased");
       rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
           cl_loc = scl.pcl_loc;
-          cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type)}
+          cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_env = val_env}
   | Pcl_apply (scl', sargs) ->
       let cl = class_expr cl_num val_env met_env scl' in
       let rec nonopt_labels ls ty_fun =
@@ -769,7 +826,8 @@ and class_expr cl_num val_env met_env scl =
       in
       rc {cl_desc = Tclass_apply (cl, args);
           cl_loc = scl.pcl_loc;
-          cl_type = cty}
+          cl_type = cty;
+          cl_env = val_env}
   | Pcl_let (rec_flag, sdefs, scl') ->
       let (defs, val_env) =
         try
@@ -802,7 +860,8 @@ and class_expr cl_num val_env met_env scl =
       let cl = class_expr cl_num val_env met_env scl' in
       rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
           cl_loc = scl.pcl_loc;
-          cl_type = cl.cl_type}
+          cl_type = cl.cl_type;
+          cl_env = val_env}
   | Pcl_constraint (scl', scty) ->
       Ctype.begin_class_def ();
       let context = Typetexp.narrow () in
@@ -824,7 +883,8 @@ and class_expr cl_num val_env met_env scl =
       let (vals, meths, concrs) = extract_constraints clty in
       rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
           cl_loc = scl.pcl_loc;
-          cl_type = snd (Ctype.instance_class [] clty)}
+          cl_type = snd (Ctype.instance_class [] clty);
+          cl_env = val_env}
 
 (*******************************)
 
@@ -1034,7 +1094,7 @@ let class_infos define_class kind
   in
 
   if cl.pci_virt = Concrete then begin
-    match virtual_methods typ with
+    match virtual_methods (Ctype.signature_of_class_type typ) with
       []   -> ()
     | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
   end;
@@ -1149,10 +1209,13 @@ let merge_type_decls
 let final_env define_class env
     (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
      arity, pub_meths, coe, expr) =
-  Env.add_type obj_id obj_abbr (
-  Env.add_type cl_id cl_abbr (
-  Env.add_cltype ty_id cltydef (
-  if define_class then Env.add_class id clty env else env)))
+  (* Add definitions after cleaning them *)
+  Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) (
+  Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) (
+  Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
+  if define_class then
+    Env.add_class id (Subst.class_declaration Subst.identity clty) env
+  else env)))
 
 (* Check that #c is coercible to c if there is a self-coercion *)
 let check_coercions env
@@ -1237,6 +1300,40 @@ let class_type_declarations env cls =
      decl,
    env)
 
+let rec unify_parents env ty cl =
+  match cl.cl_desc with
+    Tclass_ident p ->
+      begin try
+        let decl = Env.find_class p env in
+        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
+        Ctype.unify env ty (Ctype.instance body)
+      with exn -> assert (exn = Not_found)
+      end
+  | Tclass_structure st -> unify_parents_struct env ty st
+  | Tclass_fun (_, _, cl, _)
+  | Tclass_apply (cl, _)
+  | Tclass_let (_, _, _, cl)
+  | Tclass_constraint (cl, _, _, _) -> unify_parents env ty cl
+and unify_parents_struct env ty st =
+  List.iter
+    (function Cf_inher (cl, _, _) -> unify_parents env ty cl
+      | _ -> ())
+    st.cl_field
+
+let type_object env loc s =
+  incr class_num;
+  let (desc, sign) =
+    class_structure (string_of_int !class_num) true env env loc s in
+  let sty = Ctype.expand_head env sign.cty_self in
+  Ctype.hide_private_methods sty;
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  let meths = List.map (fun (s,_,_) -> s) fields in
+  unify_parents_struct env sign.cty_self desc;
+  (desc, sign, meths)
+
+let () =
+  Typecore.type_object := type_object
+
 (*******************************)
 
 (* Approximate the class declaration as class ['params] id = object end *)
@@ -1318,9 +1415,9 @@ let report_error ppf = function
   | Virtual_class (cl, mets) ->
       let print_mets ppf mets =
         List.iter (function met -> fprintf ppf "@ %s" met) mets in
-      let cl_mark = if cl then " type" else "" in
+      let cl_mark = if cl then "" else " type" in
       fprintf ppf
-        "@[This class %s should be virtual@ \
+        "@[This class%s should be virtual@ \
            @[<2>The following methods are undefined :%a@]
          @]"
         cl_mark print_mets mets
@@ -1390,3 +1487,9 @@ let report_error ppf = function
       Printtyp.report_unification_error ppf trace
         (fun ppf -> fprintf ppf "Type")
         (fun ppf -> fprintf ppf "is not compatible with type")
+  | Final_self_clash trace ->
+      Printtyp.report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "This object is expected to have type")
+        (function ppf ->
+           fprintf ppf "but has actually type")
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index 89a6e6b4f..ae7d4325e 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -71,6 +71,7 @@ type error =
   | Cannot_coerce_self of type_expr
   | Non_collapsable_conjunction of
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
+  | Final_self_clash of (type_expr * type_expr) list
 
 exception Error of Location.t * error
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 774469305..47f87cf2c 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -67,6 +67,11 @@ 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 -> Location.t -> Parsetree.class_structure ->
+	 class_structure * class_signature * string list)
 
 (*
   Saving and outputting type information.
@@ -523,7 +528,8 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   (pat, pv, val_env, met_env)
 
 let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
-let type_self_pattern cl_num val_env met_env par_env spat =
+
+let type_self_pattern cl_num privty val_env met_env par_env spat =
   let spat = 
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
                        "selfpat-" ^ cl_num))
@@ -540,7 +546,7 @@ let type_self_pattern cl_num val_env met_env par_env spat =
       (fun (id, ty) (val_env, met_env, par_env) ->
          (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
           Env.add_value id {val_type = ty;
-                            val_kind = Val_self (meths, vars, cl_num)}
+                            val_kind = Val_self (meths, vars, cl_num, privty)}
             met_env,
           Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
       pv (val_env, met_env, par_env)
@@ -583,7 +589,20 @@ let rec is_nonexpansive exp =
       is_nonexpansive ifso && is_nonexpansive_opt ifnot
   | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
       true
-  | Texp_lazy e -> true
+  (* Note: nonexpansive only means no _observable_ side effects *)
+  | Texp_lazy e -> is_nonexpansive e
+  | Texp_object ({cl_field=fields}, {cty_vars=vars}, _) ->
+      let count = ref 0 in
+      List.for_all
+        (function
+            Cf_meth _ -> true
+          | Cf_val (_,_,e) -> incr count; is_nonexpansive e
+          | Cf_init e -> is_nonexpansive e
+          | Cf_inher _ | Cf_let _ -> false)
+        fields &&
+      Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
+        vars true &&
+      !count = 0
   | _ -> false
 
 and is_nonexpansive_opt = function
@@ -796,7 +815,7 @@ let rec type_exp env sexp =
                   Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                 in
                 Texp_instvar(self_path, path)
-            | Val_self (_, _, cl_num) ->
+            | Val_self (_, _, cl_num, _) ->
                 let (path, _) =
                   Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
                 in
@@ -1123,9 +1142,9 @@ let rec type_exp env sexp =
       begin try
         let (exp, typ) =
           match obj.exp_desc with
-            Texp_ident(path, {val_kind = Val_self (meths, _, _)}) ->
+            Texp_ident(path, {val_kind = Val_self (meths, _, _, privty)}) ->
               let (id, typ) =
-                filter_self_method env met Private meths obj.exp_type
+                filter_self_method env met Private meths privty
               in
               (Texp_send(obj, Tmeth_val id), typ)
           | Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
@@ -1138,10 +1157,10 @@ let rec type_exp env sexp =
                 Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
                 Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
               with
-                (_, ({val_kind = Val_self (meths, _, _)} as desc)),
+                (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
                 (path, _) ->
                   let (_, typ) =
-                    filter_self_method env met Private meths obj.exp_type
+                    filter_self_method env met Private meths privty
                   in
                   let method_type = newvar () in
                   let (obj_ty, res_ty) = filter_arrow env method_type "" in
@@ -1251,7 +1270,7 @@ let rec type_exp env sexp =
         with Not_found ->
           raise(Error(sexp.pexp_loc, Outside_class))
       with
-        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _)}),
+        (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
         (path_self, _) ->
           let type_override (lab, snewval) =
             begin try
@@ -1318,6 +1337,14 @@ let rec type_exp env sexp =
          exp_type = instance (Predef.type_lazy_t arg.exp_type);
          exp_env = env;
        }
+  | Pexp_object s ->
+      let desc, sign, meths = !type_object env sexp.pexp_loc s in
+      re {
+        exp_desc = Texp_object (desc, sign, meths);
+        exp_loc = sexp.pexp_loc;
+        exp_type = sign.cty_self;
+        exp_env = env;
+      }
   | Pexp_poly _ ->
       assert false
 
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 06c479ea6..3511b93b5 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -35,7 +35,7 @@ val type_class_arg_pattern:
         Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
         Env.t * Env.t
 val type_self_pattern:
-        string -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+        string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
         Typedtree.pattern *
         (Ident.t * type_expr) Meths.t ref *
         (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
@@ -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 -> Location.t -> Parsetree.class_structure ->
+   Typedtree.class_structure * class_signature * string list) ref
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 58577c9df..ab05b564d 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
@@ -87,7 +88,8 @@ and meth =
 and class_expr =
   { cl_desc: class_expr_desc;
     cl_loc: Location.t;
-    cl_type: class_type }
+    cl_type: class_type;
+    cl_env: Env.t }
 
 and class_expr_desc =
     Tclass_ident of Path.t
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 4fa213b6f..587b08874 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
@@ -86,7 +87,8 @@ and meth =
 and class_expr =
   { cl_desc: class_expr_desc;
     cl_loc: Location.t;
-    cl_type: class_type }
+    cl_type: class_type;
+    cl_env: Env.t }
 
 and class_expr_desc =
     Tclass_ident of Path.t
diff --git a/typing/types.ml b/typing/types.ml
index 9954d56c4..81efda3b8 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -91,7 +91,7 @@ and value_kind =
   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
   | Val_self of (Ident.t * type_expr) Meths.t ref *
                 (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-                string
+                string * type_expr
                                         (* Self *)
   | Val_anc of (string * Ident.t) list * string
                                         (* Ancestor *)
diff --git a/typing/types.mli b/typing/types.mli
index 2a52037ee..77164cd5d 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -92,7 +92,7 @@ and value_kind =
   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
   | Val_self of (Ident.t * type_expr) Meths.t ref *
                 (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-                string
+                string * type_expr
                                         (* Self *)
   | Val_anc of (string * Ident.t) list * string
                                         (* Ancestor *)