path: root/experimental/garrigue/marshal_objects.diff

? bytecomp/alpha_eq.ml
Index: bytecomp/lambda.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v
retrieving revision 1.44
diff -u -r1.44 lambda.ml
--- bytecomp/lambda.ml	25 Aug 2005 15:35:16 -0000	1.44
+++ bytecomp/lambda.ml	2 Feb 2006 05:08:56 -0000
@@ -287,9 +287,10 @@
     let compare = compare
   end)
 
-let free_ids get l =
+let free_ids get used l =
   let fv = ref IdentSet.empty in
   let rec free l =
+    let old = !fv in
     iter free l;
     fv := List.fold_right IdentSet.add (get l) !fv;
     match l with
@@ -307,17 +308,20 @@
         fv := IdentSet.remove v !fv
     | Lassign(id, e) ->
         fv := IdentSet.add id !fv
+    | Lifused(id, e) ->
+        if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv
     | Lvar _ | Lconst _ | Lapply _
     | Lprim _ | Lswitch _ | Lstaticraise _
     | Lifthenelse _ | Lsequence _ | Lwhile _
-    | Lsend _ | Levent _ | Lifused _ -> ()
+    | Lsend _ | Levent _ -> ()
   in free l; !fv
 
-let free_variables l =
-  free_ids (function Lvar id -> [id] | _ -> []) l
+let free_variables ?(ifused=false) l =
+  free_ids (function Lvar id -> [id] | _ -> []) ifused l
 
 let free_methods l =
-  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
+  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> [])
+    false l
 
 (* Check if an action has a "when" guard *)
 let raise_count = ref 0
Index: bytecomp/lambda.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v
retrieving revision 1.42
diff -u -r1.42 lambda.mli
--- bytecomp/lambda.mli	25 Aug 2005 15:35:16 -0000	1.42
+++ bytecomp/lambda.mli	2 Feb 2006 05:08:56 -0000
@@ -177,7 +177,7 @@
 
 val iter: (lambda -> unit) -> lambda -> unit
 module IdentSet: Set.S with type elt = Ident.t
-val free_variables: lambda -> IdentSet.t
+val free_variables: ?ifused:bool -> lambda -> IdentSet.t
 val free_methods: lambda -> IdentSet.t
 
 val transl_path: Path.t -> lambda
Index: bytecomp/translclass.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
retrieving revision 1.38
diff -u -r1.38 translclass.ml
--- bytecomp/translclass.ml	13 Aug 2005 20:59:37 -0000	1.38
+++ bytecomp/translclass.ml	2 Feb 2006 05:08:56 -0000
@@ -46,6 +46,10 @@
 
 let lfield v i = Lprim(Pfield i, [Lvar v])
 
+let ltuple l = Lprim(Pmakeblock(0,Immutable), l)
+
+let lprim name args = Lapply(oo_prim name, args)
+
 let transl_label l = share (Const_immstring l)
 
 let rec transl_meth_list lst =
@@ -68,8 +72,8 @@
                                                     Lvar offset])])]))
 
 let transl_val tbl create name =
-  Lapply (oo_prim (if create then "new_variable" else "get_variable"),
-          [Lvar tbl; transl_label name])
+  lprim (if create then "new_variable" else "get_variable")
+    [Lvar tbl; transl_label name]
 
 let transl_vals tbl create vals rem =
   List.fold_right
@@ -82,7 +86,7 @@
     (fun (nm, id) rem ->
        try
          (nm, id,
-          Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
+          lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)])
          :: rem
        with Not_found -> rem)
     inh_meths []
@@ -97,17 +101,15 @@
   let (inh_init, obj_init, has_init) = init obj' in
   if obj_init = lambda_unit then
     (inh_init,
-     Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
-                      else"create_object_opt"),
-             [obj; Lvar cl]))
+     lprim (if has_init then "create_object_and_run_initializers"
+            else"create_object_opt")
+       [obj; Lvar cl])
   else begin
    (inh_init,
-    Llet(Strict, obj',
-            Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
+    Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl],
          Lsequence(obj_init,
                    if not has_init then Lvar obj' else
-                   Lapply (oo_prim "run_initializers_opt",
-			   [obj; Lvar obj'; Lvar cl]))))
+                   lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl])))
   end
 
 let rec build_object_init cl_table obj params inh_init obj_init cl =
@@ -203,14 +205,13 @@
 
 
 let bind_method tbl lab id cl_init =
-  Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
-                              [Lvar tbl; transl_label lab]),
+  Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab],
        cl_init)
 
-let bind_methods tbl meths vals cl_init =
-  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
+let bind_methods tbl methl vals cl_init =
   let len = List.length methl and nvals = List.length vals in
-  if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
+  if len < 2 && nvals = 0 then
+    List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else
   if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
   let ids = Ident.create "ids" in
   let i = ref len in
@@ -229,21 +230,19 @@
 	       vals' cl_init)
   in
   Llet(StrictOpt, ids,
-       Lapply (oo_prim getter,
-               [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
+       lprim getter
+         ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
        List.fold_right
-         (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
+         (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam))
          methl cl_init)
 
 let output_methods tbl methods lam =
   match methods with
     [] -> lam
   | [lab; code] ->
-      lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+      lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam
   | _ ->
-      lsequence (Lapply(oo_prim "set_methods",
-                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
-        lam
+      lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam
 
 let rec ignore_cstrs cl =
   match cl.cl_desc with
@@ -266,7 +265,8 @@
            Llet (Strict, obj_init, 
                  Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
 			if top then [Lprim(Pfield 3, [lpath])] else []),
-                 bind_super cla super cl_init))
+                 bind_super cla super cl_init),
+           [], [])
       | _ ->
           assert false
       end
@@ -278,10 +278,11 @@
             match field with
               Cf_inher (cl, vals, meths) ->
                 let cl_init = output_methods cla methods cl_init in
-                let inh_init, cl_init =
+                let (inh_init, cl_init, meths', vals') =
                   build_class_init cla false
                     (vals, meths_super cla str.cl_meths meths)
                     inh_init cl_init msubst top cl in
+                let cl_init = bind_methods cla meths' vals' cl_init in
                 (inh_init, cl_init, [], values)
             | Cf_val (name, id, exp) ->
                 (inh_init, cl_init, methods, (name, id)::values)
@@ -304,29 +305,37 @@
                 (inh_init, cl_init, methods, vals @ values)
             | Cf_init exp ->
                 (inh_init,
-                 Lsequence(Lapply (oo_prim "add_initializer",
-                                   Lvar cla :: msubst false (transl_exp exp)),
+                 Lsequence(lprim "add_initializer"
+                             (Lvar cla :: msubst false (transl_exp exp)),
                            cl_init),
                  methods, values))
           str.cl_field
           (inh_init, cl_init, [], [])
       in
       let cl_init = output_methods cla methods cl_init in
-      (inh_init, bind_methods cla str.cl_meths values cl_init)
+      (* inh_init, bind_methods cla str.cl_meths values cl_init *)
+      let methods =  Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in
+      (inh_init, cl_init, methods, values)
   | Tclass_fun (pat, vals, cl, _) ->
-      let (inh_init, cl_init) =
+      let (inh_init, cl_init, methods, values) =
         build_class_init cla cstr super inh_init cl_init msubst top cl
       in
+      let fv = free_variables ~ifused:true cl_init in
+      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals 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 vals cl_init *)
+      (inh_init, cl_init, methods, vals @ values)
   | Tclass_apply (cl, exprs) ->
       build_class_init cla cstr super inh_init cl_init msubst top cl
   | Tclass_let (rec_flag, defs, vals, cl) ->
-      let (inh_init, cl_init) =
+      let (inh_init, cl_init, methods, values) =
         build_class_init cla cstr super inh_init cl_init msubst top cl
       in
+      let fv = free_variables ~ifused:true cl_init in
+      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals 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 vals cl_init *)
+      (inh_init, cl_init, methods, vals @ values)
   | Tclass_constraint (cl, vals, meths, concr_meths) ->
       let virt_meths =
         List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
@@ -358,23 +367,34 @@
               cl_init valids in
           (inh_init,
            Llet (Strict, inh, 
-		 Lapply(oo_prim "inherits", narrow_args @
-			[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+		 lprim "inherits"
+                   (narrow_args @
+                    [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
                  Llet(StrictOpt, obj_init, lfield inh 0,
                  Llet(Alias, inh_vals, lfield inh 1,
-                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
+                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))),
+          [], [])
       | _ ->
 	  let core cl_init =
             build_class_init cla true super 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))
+          let (inh_init, cl_init, methods, values) =
+            core (Lsequence (lprim "widen" [Lvar cla], cl_init))
           in
-          (inh_init,
-           Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
+          let cl_init = bind_methods cla methods values cl_init in
+          (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], [])
       end
 
+let build_class_init cla env inh_init obj_init msubst top cl =
+  let inh_init = List.rev inh_init in
+  let (inh_init, cl_init, methods, values) =
+    build_class_init cla true ([],[]) inh_init obj_init msubst top cl in
+  assert (inh_init = []);
+  if IdentSet.mem env (free_variables ~ifused:true cl_init)
+  then bind_methods cla methods (("", env) :: values) cl_init
+  else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init)
+
 let rec build_class_lets cl =
   match cl.cl_desc with
     Tclass_let (rec_flag, defs, vals, cl) ->
@@ -459,16 +479,16 @@
     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])))
+    ltuple
+      [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
 
@@ -541,7 +561,7 @@
   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
+    if not arr then [lprim builtin args] else
     let tag = match builtin with
       "get_const" -> GetConst
     | "get_var"   -> GetVar
@@ -599,7 +619,8 @@
 
   (* 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 table_init = ref None in
+  let (top_env, req) = oo_add_class tables table_init 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
@@ -633,6 +654,7 @@
         begin try
           (* Doesn't seem to improve size for bytecode *)
           (* if not !Clflags.native_code then raise Not_found; *)
+          if !Clflags.debug then raise Not_found;
           builtin_meths arr [self] env env2 (lfunction args body')
         with Not_found ->
           [lfunction (self :: args)
@@ -665,15 +687,8 @@
     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' = List.rev inh_init in
-  let (inh_init', cl_init) =
-    build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
-  in
-  assert (inh_init' = []);
-  let table = Ident.create "table"
-  and class_init = Ident.create (Ident.name cl_id ^ "_init")
-  and env_init = Ident.create "env_init"
-  and obj_init = Ident.create "obj_init" in
+  let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in
+  let obj_init = Ident.create "obj_init" in
   let pub_meths =
     List.sort
       (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
@@ -685,42 +700,44 @@
       let name' = List.assoc tag rev_map in
       if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
     tags pub_meths;
+  let pos = cl.cl_loc.Location.loc_end in
+  let filepos = [transl_label pos.Lexing.pos_fname;
+                 Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in
   let ltable table lam =
-    Llet(Strict, table,
-         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
+    Llet(Strict, table, lprim "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]),
+         Lsequence(lprim "init_class_shared" (Lvar cla :: filepos),
                    Lapply(Lvar obj_init, [lambda_unit])))
   in
   (* Simplest case: an object defined at toplevel (ids=[]) *)
   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
 
+  let table = Ident.create "table"
+  and class_init = Ident.create (Ident.name cl_id ^ "_init")
+  and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in
+  let cl_init_fun = Lfunction(Curried, [cla], cl_init) in
   let concrete =
     ids = [] ||
     Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
-  and lclass lam =
-    let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
+  and lclass cl_init lam =
     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
   and lbody fv =
     if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
-      Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
-				    Lvar class_init])
+      lprim "make_class"
+        (transl_meth_list pub_meths :: Lvar class_init :: filepos)
     else
       ltable table (
       Llet(
       Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
-      Lsequence(
-      Lapply (oo_prim "init_class", [Lvar table]),
-      Lprim(Pmakeblock(0, Immutable),
-	    [Lapply(Lvar env_init, [lambda_unit]);
-	     Lvar class_init; Lvar env_init; lambda_unit]))))
+      Lsequence(lprim "init_class_shared" (Lvar table :: filepos),
+                ltuple [Lapply(Lvar env_init, [lambda_unit]);
+	                Lvar class_init; Lvar env_init; lambda_unit])))
   and lbody_virt lenvs =
-    Lprim(Pmakeblock(0, Immutable),
-          [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
+    ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs]
   in
   (* Still easy: a class defined at toplevel *)
-  if top && concrete then lclass lbody else
+  if top && concrete then lclass (llets cl_init_fun) lbody else
   if top then llets (lbody_virt lambda_unit) else
 
   (* Now for the hard stuff: prepare for table cacheing *)
@@ -733,23 +750,16 @@
   let lenv =
     let menv =
       if !new_ids_meths = [] then lambda_unit else
-      Lprim(Pmakeblock(0, Immutable),
-            List.map (fun id -> Lvar id) !new_ids_meths) in
+      ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in
     if !new_ids_init = [] then menv else
-    Lprim(Pmakeblock(0, Immutable),
-          menv :: List.map (fun id -> Lvar id) !new_ids_init)
+    ltuple (menv :: 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,
-         (if linh_envs = [] then lenv else
-         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 ""]),
+         (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)),
          lam)
   in
   let inh_paths =
@@ -757,46 +767,53 @@
       (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
   let inh_keys =
     List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
-  let lclass lam =
-    Llet(Strict, class_init,
-         Lfunction(Curried, [cla], def_ids cla cl_init), lam)
+  let lclass_init lam =
+    Llet(Strict, class_init, cl_init_fun, 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)]),
+    Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple 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))))
-  and lclass_virt () =
-    lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
+  let ldirect prim pos =
+    ltable cla (
+    Llet(Strict, env_init, cl_init,
+         Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init)))
+  and lclass_concrete cached =
+    ltuple [Lapply (lfield cached 0, [lenvs]);
+            lfield cached 1; lfield cached 0; lenvs]
   in
+
   llets (
-  lcache (
-  Lsequence(
-  Lifthenelse(lfield cached 0, lambda_unit,
-              if ids = [] then ldirect () else
-              if not concrete then lclass_virt () 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),
-        if concrete then
-          [Lapply(lfield cached 0, [lenvs]);
-           lfield cached 1;
-           lfield cached 0;
-           lenvs]
-        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
-       )))))
+  if inh_paths = [] && concrete then
+    if ids = [] then begin
+      table_init := Some (ldirect "init_class_shared" filepos);
+      Lapply (Lvar tables, [lenvs])
+    end else begin
+      let init =
+        lclass cl_init_fun (fun _ ->
+          lprim "make_class_env"
+            (transl_meth_list pub_meths :: Lvar class_init :: filepos))
+      in table_init := Some init;
+      lclass_concrete tables
+    end
+  else begin
+    lcache (
+    Lsequence(
+    Lifthenelse(lfield cached 0, lambda_unit,
+                if ids = [] then lset cached 0 (ldirect "init_class" []) else
+                if not concrete then lset cached 0 cl_init_fun else
+                lclass_init (
+                lprim "make_class_store"
+                  [transl_meth_list pub_meths; Lvar class_init; Lvar cached])),
+    llets (
+    make_envs (
+    if ids = [] then Lapply(lfield cached 0, [lenvs]) else
+    if concrete then lclass_concrete cached else
+    ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs]))))
+  end))
 
 (* Wrapper for class compilation *)
 
Index: bytecomp/translobj.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v
retrieving revision 1.9
diff -u -r1.9 translobj.ml
--- bytecomp/translobj.ml	26 May 2004 11:10:51 -0000	1.9
+++ bytecomp/translobj.ml	2 Feb 2006 05:08:56 -0000
@@ -88,7 +88,6 @@
 
 (* Insert labels *)
 
-let string s = Lconst (Const_base (Const_string s))
 let int n = Lconst (Const_base (Const_int n))
 
 let prim_makearray =
@@ -124,8 +123,8 @@
 let top_env = ref Env.empty
 let classes = ref []
 
-let oo_add_class id =
-  classes := id :: !classes;
+let oo_add_class id init =
+  classes := (id, init) :: !classes;
   (!top_env, !cache_required)
 
 let oo_wrap env req f x =
@@ -141,10 +140,12 @@
     let lambda = f x in
     let lambda =
       List.fold_left
-        (fun lambda id ->
+        (fun lambda (id, init) ->
           Llet(StrictOpt, id,
-               Lprim(Pmakeblock(0, Mutable),
-                     [lambda_unit; lambda_unit; lambda_unit]),
+               (match !init with
+                 Some lam -> lam
+               | None -> Lprim(Pmakeblock(0, Mutable),
+                               [lambda_unit; lambda_unit; lambda_unit])),
                lambda))
         lambda !classes
     in
Index: bytecomp/translobj.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v
retrieving revision 1.6
diff -u -r1.6 translobj.mli
--- bytecomp/translobj.mli	26 May 2004 11:10:51 -0000	1.6
+++ bytecomp/translobj.mli	2 Feb 2006 05:08:56 -0000
@@ -25,4 +25,4 @@
     Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
 
 val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
-val oo_add_class: Ident.t -> Env.t * bool
+val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool
Index: byterun/compare.h
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v
retrieving revision 1.2
diff -u -r1.2 compare.h
--- byterun/compare.h	31 Dec 2003 14:20:35 -0000	1.2
+++ byterun/compare.h	2 Feb 2006 05:08:56 -0000
@@ -17,5 +17,6 @@
 #define CAML_COMPARE_H
 
 CAMLextern int caml_compare_unordered;
+CAMLextern value caml_compare(value, value);
 
 #endif /* CAML_COMPARE_H */
Index: byterun/extern.c
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v
retrieving revision 1.59
diff -u -r1.59 extern.c
--- byterun/extern.c	4 Jan 2006 16:55:49 -0000	1.59
+++ byterun/extern.c	2 Feb 2006 05:08:56 -0000
@@ -411,6 +411,22 @@
       extern_record_location(v);
       break;
     }
+    case Object_tag: {
+      value field0;
+      mlsize_t i;
+      i = Wosize_val(Field(v, 0)) - 1;
+      field0 = Field(Field(v, 0),i);
+      if (Wosize_val(field0) > 0) {
+        writecode32(CODE_OBJECT, Wosize_hd (hd));
+        extern_record_location(v);
+        extern_rec(field0);
+        for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
+        v = Field(v, i);
+        goto tailcall;
+      }
+      if (!extern_closures)
+        extern_invalid_argument("output_value: dynamic class");
+    } /* may fall through */
     default: {
       value field0;
       mlsize_t i;
Index: byterun/intern.c
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v
retrieving revision 1.60
diff -u -r1.60 intern.c
--- byterun/intern.c	22 Sep 2005 14:21:50 -0000	1.60
+++ byterun/intern.c	2 Feb 2006 05:08:56 -0000
@@ -28,6 +28,8 @@
 #include "mlvalues.h"
 #include "misc.h"
 #include "reverse.h"
+#include "callback.h"
+#include "compare.h"
 
 static unsigned char * intern_src;
 /* Reading pointer in block holding input data. */
@@ -98,6 +100,25 @@
 #define readblock(dest,len) \
   (memmove((dest), intern_src, (len)), intern_src += (len))
 
+static value get_method_table (value key)
+{
+  static value *classes = NULL;
+  value current;
+  if (classes == NULL) {
+    classes = caml_named_value("caml_oo_classes");
+    if (classes == NULL) return 0;
+    caml_register_global_root(classes);
+  }
+  for (current = Field(*classes, 0); Is_block(current);
+       current = Field(current, 1))
+  {
+    value head = Field(current, 0);
+    if (caml_compare(key, Field(head, 0)) == Val_int(0))
+      return Field(head, 1);
+  }
+  return 0;
+}
+
 static void intern_cleanup(void)
 {
   if (intern_input_malloced) caml_stat_free(intern_input);
@@ -315,6 +336,24 @@
         Custom_ops_val(v) = ops;
         intern_dest += 1 + size;
         break;
+      case CODE_OBJECT:
+        size = read32u();
+        v = Val_hp(intern_dest);
+        *dest = v;
+        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
+        dest = (value *) (intern_dest + 1);
+        *intern_dest = Make_header(size, Object_tag, intern_color);
+        intern_dest += 1 + size;
+        intern_rec(dest);
+        *dest = get_method_table(*dest);
+        if (*dest == 0) {
+          intern_cleanup();
+          caml_failwith("input_value: unknown class");
+        }
+        for(size--, dest++; size > 1; size--, dest++)
+          intern_rec(dest);
+        goto tailcall;
+        
       default:
         intern_cleanup();
         caml_failwith("input_value: ill-formed message");
Index: byterun/intext.h
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v
retrieving revision 1.32
diff -u -r1.32 intext.h
--- byterun/intext.h	22 Sep 2005 14:21:50 -0000	1.32
+++ byterun/intext.h	2 Feb 2006 05:08:56 -0000
@@ -56,6 +56,7 @@
 #define CODE_CODEPOINTER 0x10
 #define CODE_INFIXPOINTER 0x11
 #define CODE_CUSTOM 0x12
+#define CODE_OBJECT 0x14
 
 #if ARCH_FLOAT_ENDIANNESS == 0x76543210
 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
Index: stdlib/camlinternalOO.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
retrieving revision 1.14
diff -u -r1.14 camlinternalOO.ml
--- stdlib/camlinternalOO.ml	25 Oct 2005 18:34:07 -0000	1.14
+++ stdlib/camlinternalOO.ml	2 Feb 2006 05:08:56 -0000
@@ -305,10 +305,38 @@
     public_methods;
   table
 
+(*
+let create_table_variables pub_meths priv_meths vars =
+  let tbl = create_table pub_meths in
+  let pub_meths = to_array pub_meths
+  and priv_meths = to_array priv_meths
+  and vars = to_array vars in
+  let len = 2 + Array.length pub_meths + Array.length priv_meths in
+  let res = Array.create len tbl in
+  let mv = new_methods_variables tbl pub_meths vars in
+  Array.blit mv 0 res 1;
+  res
+*)
+
 let init_class table =
   inst_var_count := !inst_var_count + table.size - 1;
   table.initializers <- List.rev table.initializers;
-  resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
+  let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in
+  (* keep 1 more for extra info *)
+  let len = if len > Array.length table.methods then len else len+1 in
+  resize table len
+
+let classes = ref []
+let () = Callback.register "caml_oo_classes" classes
+
+let init_class_shared table (file : string) (pos : int) =
+  init_class table;
+  let rec unique_pos pos =
+    if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000)
+    else pos in
+  let pos = unique_pos pos in
+  table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos);
+  classes := ((file, pos), table.methods) :: !classes
 
 let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
   narrow cla vals virt_meths concr_meths;
@@ -319,12 +347,18 @@
    Array.map (fun nm -> get_method cla (get_method_label cla nm))
      (to_array concr_meths))
 
-let make_class pub_meths class_init =
+let make_class pub_meths class_init file pos =
   let table = create_table pub_meths in
   let env_init = class_init table in
-  init_class table;
+  init_class_shared table file pos;
   (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
 
+let make_class_env pub_meths class_init file pos =
+  let table = create_table pub_meths in
+  let env_init = class_init table in
+  init_class_shared table file pos;
+  (env_init, class_init)
+
 type init_table = { mutable env_init: t; mutable class_init: table -> t }
 
 let make_class_store pub_meths class_init init_table =
Index: stdlib/camlinternalOO.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
retrieving revision 1.9
diff -u -r1.9 camlinternalOO.mli
--- stdlib/camlinternalOO.mli	25 Oct 2005 18:34:07 -0000	1.9
+++ stdlib/camlinternalOO.mli	2 Feb 2006 05:08:56 -0000
@@ -43,14 +43,20 @@
 val add_initializer : table -> (obj -> unit) -> unit
 val dummy_table : table
 val create_table : string array -> table
+(* val create_table_variables :
+    string array -> string array -> string array -> table *)
 val init_class : table -> unit
+val init_class_shared : table -> string -> int -> unit
 val inherits :
     table -> string array -> string array -> string array ->
     (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
     (Obj.t * int array * closure array)
 val make_class :
-    string array -> (table -> Obj.t -> t) ->
+    string array -> (table -> Obj.t -> t) -> string -> int ->
     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
+val make_class_env :
+    string array -> (table -> Obj.t -> t) -> string -> int ->
+    (Obj.t -> t) * (table -> Obj.t -> t)
 type init_table
 val make_class_store :
     string array -> (table -> t) -> init_table -> unit