add

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

1 files changed, 800 insertions, 0 deletions

diff --git a/testlabl/marshal_objects.diffs b/testlabl/marshal_objects.diffs
new file mode 100644
index 000000000..bb9b4dd71
--- /dev/null
+++ b/testlabl/marshal_objects.diffs
@@ -0,0 +1,800 @@
+? 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