diff options
Diffstat (limited to 'testlabl/marshal_objects.diffs')
| -rw-r--r-- | testlabl/marshal_objects.diffs | 800 |
1 files changed, 0 insertions, 800 deletions
diff --git a/testlabl/marshal_objects.diffs b/testlabl/marshal_objects.diffs deleted file mode 100644 index bb9b4dd71..000000000 --- a/testlabl/marshal_objects.diffs +++ /dev/null @@ -1,800 +0,0 @@ -? 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 |