diff options
39 files changed, 665 insertions, 435 deletions
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index b4cc25c7b..4a92c9f11 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -175,14 +175,17 @@ let make_startup_file ppf filename units_list = compile_phrase (Cmmgen.entry_point name_list); let apply_functions = ref (IntSet.add 2 (IntSet.add 3 IntSet.empty)) in (* The callback functions always reference caml_apply[23] *) - let curry_functions = - ref IntSet.empty in + let send_functions = ref IntSet.empty in + let curry_functions = ref IntSet.empty in List.iter (fun (info,_,_) -> List.iter (fun n -> apply_functions := IntSet.add n !apply_functions) info.ui_apply_fun; List.iter + (fun n -> send_functions := IntSet.add n !send_functions) + info.ui_send_fun; + List.iter (fun n -> curry_functions := IntSet.add n !curry_functions) info.ui_curry_fun) units_list; @@ -190,6 +193,9 @@ let make_startup_file ppf filename units_list = (fun n -> compile_phrase (Cmmgen.apply_function n)) !apply_functions; IntSet.iter + (fun n -> compile_phrase (Cmmgen.send_function n)) + !send_functions; + IntSet.iter (fun n -> List.iter (compile_phrase) (Cmmgen.curry_function n)) !curry_functions; Array.iter diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 8129707c1..58e4447d6 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -222,8 +222,8 @@ let rename_approx mapping_lbl mapping_id approx = Ufor(id, ren_ulambda u1, ren_ulambda u2, dir, ren_ulambda u3) | Uassign(id, u) -> Uassign(id, ren_ulambda u) - | Usend(u1, u2, ul) -> - Usend(ren_ulambda u1, ren_ulambda u2, List.map ren_ulambda ul) in + | Usend(k, u1, u2, ul) -> + Usend(k, ren_ulambda u1, ren_ulambda u2, List.map ren_ulambda ul) in let rec ren_approx = function Value_closure(fd, res) -> @@ -285,6 +285,7 @@ let build_package_cmx members target symbols_to_rename cmxfile = ui_approx = rename_approx mapping_lbl mapping_id approx; ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units); ui_apply_fun = union(List.map (fun info -> info.ui_apply_fun) units); + ui_send_fun = union(List.map (fun info -> info.ui_send_fun) units); ui_force_link = List.exists (fun info -> info.ui_force_link) units } in Compilenv.write_unit_info pkg_infos cmxfile diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index c854b3ac7..5b4464290 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -40,7 +40,7 @@ type ulambda = | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda - | Usend of ulambda * ulambda * ulambda list + | Usend of meth_kind * ulambda * ulambda * ulambda list and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 31ff125ce..116d8c75a 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -40,7 +40,7 @@ type ulambda = | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda - | Usend of ulambda * ulambda * ulambda list + | Usend of meth_kind * ulambda * ulambda * ulambda list and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 239678c4d..41dc1d3cb 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -62,7 +62,7 @@ let occurs_var var u = | Uwhile(cond, body) -> occurs cond || occurs body | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u - | Usend(met, obj, args) -> + | Usend(_, met, obj, args) -> occurs met || occurs obj || List.exists occurs args and occurs_array a = try @@ -152,7 +152,7 @@ let lambda_smaller lam threshold = size := !size + 4; lambda_size low; lambda_size high; lambda_size body | Uassign(id, lam) -> incr size; lambda_size lam - | Usend(met, obj, args) -> + | Usend(_, met, obj, args) -> size := !size + 8; lambda_size met; lambda_size obj; lambda_list_size args and lambda_list_size l = List.iter lambda_size l @@ -306,8 +306,8 @@ let rec substitute sb ulam = with Not_found -> id in Uassign(id', substitute sb u) - | Usend(u1, u2, ul) -> - Usend(substitute sb u1, substitute sb u2, List.map (substitute sb) ul) + | Usend(k, u1, u2, ul) -> + Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul) (* Perform an inline expansion *) @@ -457,10 +457,10 @@ let rec close fenv cenv = function | ((ufunct, _), uargs) -> (Ugeneric_apply(ufunct, uargs), Value_unknown) end - | Lsend(met, obj, args) -> + | Lsend(kind, met, obj, args) -> let (umet, _) = close fenv cenv met in let (uobj, _) = close fenv cenv obj in - (Usend(umet, uobj, close_list fenv cenv args), Value_unknown) + (Usend(kind, umet, uobj, close_list fenv cenv args), Value_unknown) | Llet(str, id, lam, body) -> let (ulam, alam) = close_named fenv cenv id lam in begin match (str, alam) with diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 9d099b003..dfe24acb3 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -245,6 +245,9 @@ let get_tag ptr = Cop(Cload Byte_unsigned, [Cop(Cadda, [ptr; Cconst_int(tag_offset)])]) +let get_size ptr = + Cop(Clsr, [header ptr; Cconst_int 10]) + (* Array indexing *) let log2_size_addr = Misc.log2 size_addr @@ -312,13 +315,22 @@ let string_length exp = (* Message sending *) +let lookup_tag obj tag = + bind "tag" tag (fun tag -> + Cop(Cextcall("caml_get_public_method", typ_addr, false), [obj; tag])) + let lookup_label obj lab = bind "lab" lab (fun lab -> let table = Cop (Cload Word, [obj]) in - let buck_index = Cop(Clsr, [lab; Cconst_int 16]) in - let bucket = Cop(Cload Word, [Cop (Cadda, [table; buck_index])]) in - let item_index = Cop(Cand, [lab; Cconst_int (255 * size_addr)]) in - Cop (Cload Word, [Cop (Cadda, [bucket; item_index])])) + addr_array_ref table lab) + +let call_cached_method obj tag cache pos args = + let arity = List.length args in + let cache = array_indexing log2_size_addr cache pos in + Compilenv.need_send_fun arity; + Cop(Capply typ_addr, + Cconst_symbol("caml_send" ^ string_of_int arity) :: + obj :: tag :: cache :: args) (* Allocation *) @@ -806,17 +818,23 @@ let rec transl = function let cargs = Cconst_symbol(apply_function arity) :: List.map transl (args @ [clos]) in Cop(Capply typ_addr, cargs) - | Usend(met, obj, []) -> + | Usend(kind, met, obj, args) -> + let call_met obj args clos = + if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else + let arity = List.length args + 1 in + let cargs = Cconst_symbol(apply_function arity) :: obj :: + (List.map transl args) @ [clos] in + Cop(Capply typ_addr, cargs) + in bind "obj" (transl obj) (fun obj -> - bind "met" (lookup_label obj (transl met)) (fun clos -> - Cop(Capply typ_addr, [get_field clos 0; obj; clos]))) - | Usend(met, obj, args) -> - let arity = List.length args + 1 in - bind "obj" (transl obj) (fun obj -> - bind "met" (lookup_label obj (transl met)) (fun clos -> - let cargs = Cconst_symbol(apply_function arity) :: - obj :: (List.map transl args) @ [clos] in - Cop(Capply typ_addr, cargs))) + match kind, args with + Self, _ -> + bind "met" (lookup_label obj (transl met)) (call_met obj args) + | Cached, cache :: pos :: args -> + call_cached_method obj (transl met) (transl cache) (transl pos) + (List.map transl args) + | _ -> + bind "met" (lookup_tag obj (transl met)) (call_met obj args)) | Ulet(id, exp, body) -> begin match is_unboxed_number exp with No_unboxing -> @@ -1676,6 +1694,56 @@ let compunit size ulam = Cdefine_symbol glob; Cskip(size * size_addr)] :: c3 +(* +CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) +{ + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { // no need to check the 1st time + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value)+1; + return Field (meths, li-1); +} +*) + +let cache_public_method meths tag cache = + let raise_num = next_raise_count () in + let li = Ident.create "li" and hi = Ident.create "hi" + and mi = Ident.create "mi" and tagged = Ident.create "tagged" in + Clet ( + li, Cconst_int 3, + Clet ( + hi, Cop(Cload Word, [meths]), + Csequence( + Ccatch + (raise_num, [], + Cloop + (Clet( + mi, + Cop(Cor, + [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]); + Cconst_int 1]), + Csequence( + Cifthenelse + (Cop (Ccmpi Clt, + [tag; + Cop(Cload Word, + [Cop(Cadda, + [meths; lsl_const (Cvar mi) log2_size_addr])])]), + Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])), + Cassign(li, Cvar mi)), + Cifthenelse + (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []), + Ctuple [])))), + Ctuple []), + Clet ( + tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr; + Cconst_int(1 - 3 * size_addr)]), + Csequence(Cop (Cstore Word, [cache; Cvar tagged]), + Cvar tagged))))) + (* Generate an application function: (defun caml_applyN (a1 ... aN clos) (if (= clos.arity N) @@ -1687,7 +1755,7 @@ let compunit size ulam = (app closN-1.code aN closN-1)))) *) -let apply_function arity = +let apply_function_body arity = let arg = Array.create arity (Ident.create "arg") in for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; let clos = Ident.create "clos" in @@ -1702,13 +1770,56 @@ let apply_function arity = [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]), app_fun newclos (n+1)) end in - let all_args = Array.to_list arg @ [clos] in - let body = - Cifthenelse( - Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), - Cop(Capply typ_addr, - get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), - app_fun clos 0) in + let args = Array.to_list arg in + let all_args = args @ [clos] in + (args, clos, + if arity = 1 then app_fun clos 0 else + Cifthenelse( + Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), + Cop(Capply typ_addr, + get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), + app_fun clos 0)) + +let send_function arity = + let (args, clos', body) = apply_function_body (1+arity) in + let cache = Ident.create "cache" + and obj = List.hd args + and tag = Ident.create "tag" in + let clos = + let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in + let meths = Ident.create "meths" and cached = Ident.create "cached" in + let real = Ident.create "real" in + let mask = get_field (Cvar meths) 1 in + let cached_pos = Cvar cached in + let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]); + Cconst_int(3*size_addr-1)]) in + let tag' = Cop(Cload Word, [tag_pos]) in + Clet ( + meths, Cop(Cload Word, [obj]), + Clet ( + cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]), + Clet ( + real, + Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]), + cache_public_method (Cvar meths) tag cache, + cached_pos), + Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]); + Cconst_int(2*size_addr-1)])])))) + + in + let body = Clet(clos', clos, body) in + let fun_args = + [obj, typ_addr; tag, typ_int; cache, typ_addr] + @ List.map (fun id -> (id, typ_addr)) (List.tl args) in + Cfunction + {fun_name = "caml_send" ^ string_of_int arity; + fun_args = fun_args; + fun_body = body; + fun_fast = true} + +let apply_function arity = + let (args, clos, body) = apply_function_body arity in + let all_args = args @ [clos] in Cfunction {fun_name = "caml_apply" ^ string_of_int arity; fun_args = List.map (fun id -> (id, typ_addr)) all_args; diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 0bf27f8cd..fa4dba277 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -17,6 +17,7 @@ val compunit: int -> Clambda.ulambda -> Cmm.phrase list val apply_function: int -> Cmm.phrase +val send_function: int -> Cmm.phrase val curry_function: int -> Cmm.phrase list val entry_point: string list -> Cmm.phrase val global_table: string list -> Cmm.phrase diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 21833342f..351bed8ac 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -43,6 +43,7 @@ type unit_infos = mutable ui_approx: value_approximation; (* Approx of the structure *) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) + mutable ui_send_fun: int list; (* Send functions needed *) mutable ui_force_link: bool } (* Always linked *) (* Each .a library has a matching .cmxa file that provides the following @@ -64,6 +65,7 @@ let current_unit = ui_approx = Value_unknown; ui_curry_fun = []; ui_apply_fun = []; + ui_send_fun = []; ui_force_link = false } let reset name = @@ -74,6 +76,7 @@ let reset name = current_unit.ui_imports_cmx <- []; current_unit.ui_curry_fun <- []; current_unit.ui_apply_fun <- []; + current_unit.ui_send_fun <- []; current_unit.ui_force_link <- false let current_unit_name () = @@ -146,6 +149,10 @@ let need_apply_fun n = if not (List.mem n current_unit.ui_apply_fun) then current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun +let need_send_fun n = + if not (List.mem n current_unit.ui_send_fun) then + current_unit.ui_send_fun <- n :: current_unit.ui_send_fun + (* Write the description of the current unit *) let write_unit_info info filename = diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index fac7963bb..477ab99e8 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -34,6 +34,7 @@ type unit_infos = mutable ui_approx: value_approximation; (* Approx of the structure *) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) + mutable ui_send_fun: int list; (* Send functions needed *) mutable ui_force_link: bool } (* Always linked *) (* Each .a library has a matching .cmxa file that provides the following @@ -65,8 +66,9 @@ val set_global_approx: Clambda.value_approximation -> unit val need_curry_fun: int -> unit val need_apply_fun: int -> unit - (* Record the need of a currying (resp. application) function - with the given arity *) +val need_send_fun: int -> unit + (* Record the need of a currying (resp. application, + message sending) function with the given arity *) val read_unit_info: string -> unit_infos * Digest.t (* Read infos and CRC from a [.cmx] file. *) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 0bd9bd5aa..21798751c 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex f4e949d97..b3d1fb3c1 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index cdc4c9e28..8a8652488 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -409,20 +409,27 @@ let rec comp_expr env exp sz cont = (Kpush :: comp_expr env func (sz + 3 + nargs) (Kapply nargs :: cont1)) end - | Lsend(met, obj, args) -> + | Lsend(kind, met, obj, args) -> + let args = if kind = Cached then List.tl args else args in let nargs = List.length args + 1 in + let getmethod, args' = + if kind = Self then (Kgetmethod, met::obj::args) else + match met with + Lconst(Const_base(Const_int n)) -> (Kgetpubmet n, obj::args) + | _ -> (Kgetdynmet, met::obj::args) + in if is_tailcall cont then - comp_args env (met::obj::args) sz - (Kgetmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont) + comp_args env args' sz + (getmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont) else if nargs < 4 then - comp_args env (met::obj::args) sz - (Kgetmethod :: Kapply nargs :: cont) + comp_args env args' sz + (getmethod :: Kapply nargs :: cont) else begin let (lbl, cont1) = label_code cont in Kpush_retaddr lbl :: - comp_args env (met::obj::args) (sz + 3) - (Kgetmethod :: Kapply nargs :: cont1) + comp_args env args' (sz + 3) + (getmethod :: Kapply nargs :: cont1) end | Lfunction(kind, params, body) -> (* assume kind = Curried *) let lbl = new_label() in @@ -714,7 +721,7 @@ let rec comp_expr env exp sz cont = let info = match lam with Lapply(_, args) -> Event_return (List.length args) - | Lsend(_, _, args) -> Event_return (List.length args + 1) + | Lsend(_, _, _, args) -> Event_return (List.length args + 1) | _ -> Event_other in let ev = event (Event_after ty) info in diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index a2ee15a82..bd56ca642 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -293,6 +293,8 @@ let emit_instr = function | Kisint -> out opISINT | Kisout -> out opULTINT | Kgetmethod -> out opGETMETHOD + | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0 + | Kgetdynmet -> out opGETDYNMET | Kevent ev -> record_event ev | Kstop -> out opSTOP diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 81224dde6..fd13db5d7 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -97,6 +97,8 @@ type instruction = | Kisint | Kisout | Kgetmethod + | Kgetpubmet of int + | Kgetdynmet | Kevent of debug_event | Kstop diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index f609d5d94..fdedd8fd4 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -116,6 +116,8 @@ type instruction = | Kisint | Kisout | Kgetmethod + | Kgetpubmet of int + | Kgetdynmet | Kevent of debug_event | Kstop diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 9a2770f10..7f537ddf2 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -115,6 +115,8 @@ type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable +type meth_kind = Self | Public | Cached + type shared_code = (int * int) list type lambda = @@ -134,7 +136,7 @@ type lambda = | Lwhile of lambda * lambda | Lfor of Ident.t * lambda * lambda * direction_flag * lambda | Lassign of Ident.t * lambda - | Lsend of lambda * lambda * lambda list + | Lsend of meth_kind * lambda * lambda * lambda list | Levent of lambda * lambda_event | Lifused of Ident.t * lambda @@ -225,7 +227,7 @@ let free_variables l = freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv | Lassign(id, e) -> fv := IdentSet.add id !fv; freevars e - | Lsend (met, obj, args) -> + | Lsend (k, met, obj, args) -> List.iter freevars (met::obj::args) | Levent (lam, evt) -> freevars lam @@ -309,7 +311,8 @@ let subst_lambda s lam = | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2) | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3) | Lassign(id, e) -> Lassign(id, subst e) - | Lsend (met, obj, args) -> Lsend (subst met, subst obj, List.map subst args) + | Lsend (k, met, obj, args) -> + Lsend (k, subst met, subst obj, List.map subst args) | Levent (lam, evt) -> Levent (subst lam, evt) | Lifused (v, e) -> Lifused (v, subst e) and subst_decl (id, exp) = (id, subst exp) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index f862ca8aa..2c7c56e01 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -124,6 +124,8 @@ type let_kind = Strict | Alias | StrictOpt | Variable we can discard e if x does not appear in e' Variable: the variable x is assigned later in e' *) +type meth_kind = Self | Public | Cached + type shared_code = (int * int) list (* stack size -> code label *) type lambda = @@ -143,7 +145,7 @@ type lambda = | Lwhile of lambda * lambda | Lfor of Ident.t * lambda * lambda * direction_flag * lambda | Lassign of Ident.t * lambda - | Lsend of lambda * lambda * lambda list + | Lsend of meth_kind * lambda * lambda * lambda list | Levent of lambda * lambda_event | Lifused of Ident.t * lambda diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 763f8fe03..acbcd6ff8 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -35,3 +35,7 @@ val for_tupled_function: exception Cannot_flatten val flatten_pattern: int -> pattern -> pattern list + +val make_test_sequence: + lambda option -> primitive -> primitive -> lambda -> + (Asttypes.constant * lambda) list -> lambda diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index 8b2ba1e8c..a7c859d84 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -96,6 +96,8 @@ let instruction ppf = function | Kisint -> fprintf ppf "\tisint" | Kisout -> fprintf ppf "\tisout" | Kgetmethod -> fprintf ppf "\tgetmethod" + | Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n + | Kgetdynmet -> fprintf ppf "\tgetdynmet" | Kstop -> fprintf ppf "\tstop" | Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname ev.ev_char.Lexing.pos_cnum diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index b8af27831..4f66ddada 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -274,10 +274,12 @@ let rec lam ppf = function lam hi lam body | Lassign(id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (met, obj, largs) -> + | Lsend (k, met, obj, largs) -> let args ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs + let kind = + if k = Self then "self" else if k = Cached then "cache" else "" in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs | Levent(expr, ev) -> let kind = match ev.lev_kind with diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index add9ef7cc..ee59cab74 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -75,8 +75,8 @@ let rec eliminate_ref id = function dir, eliminate_ref id e3) | Lassign(v, e) -> Lassign(v, eliminate_ref id e) - | Lsend(m, o, el) -> - Lsend(eliminate_ref id m, eliminate_ref id o, + | Lsend(k, m, o, el) -> + Lsend(k, eliminate_ref id m, eliminate_ref id o, List.map (eliminate_ref id) el) | Levent(l, ev) -> Levent(eliminate_ref id l, ev) @@ -144,7 +144,7 @@ let simplify_exits lam = (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count l - | Lsend(m, o, ll) -> List.iter count (m::o::ll) + | Lsend(k, m, o, ll) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -250,7 +250,7 @@ let simplify_exits lam = | Lfor(v, l1, l2, dir, l3) -> Lfor(v, simplif l1, simplif l2, dir, simplif l3) | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll) + | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> Lifused (v,simplif l) in @@ -313,7 +313,7 @@ let simplify_lets lam = (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count l - | Lsend(m, o, ll) -> List.iter count (m::o::ll) + | Lsend(_, m, o, ll) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> if count_var v > 0 then count l @@ -402,7 +402,7 @@ let simplify_lets lam = | Lfor(v, l1, l2, dir, l3) -> Lfor(v, simplif l1, simplif l2, dir, simplif l3) | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(m, o, ll) -> Lsend(simplif m, simplif o, List.map simplif ll) + | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> if count_var v > 0 then simplif l else lambda_unit diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 5c8f819a8..59153bd67 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -22,7 +22,7 @@ open Translcore (* XXX Rajouter des evenements... *) -type error = Illegal_class_expr +type error = Illegal_class_expr | Tags of label * label exception Error of Location.t * error @@ -211,16 +211,24 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = (inh_init, lfunction [env] (subst_env env inh_init obj_init)) -let bind_method tbl public_methods lab id cl_init = - if List.mem lab public_methods then - Llet(Alias, id, Lvar (meth lab), cl_init) - else - Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), - cl_init) - -let bind_methods tbl public_methods meths cl_init = - Meths.fold (bind_method tbl public_methods) meths cl_init +let bind_method tbl lab id cl_init = + Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), + cl_init) + +let bind_methods tbl meths cl_init = + let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in + let len = List.length methl in + if len < 2 then Meths.fold (bind_method tbl) meths cl_init else + let ids = Ident.create "ids" in + let i = ref len in + Llet(StrictOpt, ids, + Lapply (oo_prim "get_method_labels", + [Lvar tbl; transl_meth_list (List.map fst methl)]), + List.fold_right + (fun (lab,id) lam -> + decr i; Llet(StrictOpt, id, Lprim(Pfield !i, [Lvar ids]), lam)) + methl cl_init) let output_methods tbl vals methods lam = let lam = @@ -241,7 +249,7 @@ let rec 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 = +let rec build_class_init cla cstr inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> begin match inh_init with @@ -263,7 +271,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = Cf_inher (cl, vals, meths) -> 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 + build_class_init cla false inh_init (transl_vals cla false false vals (transl_super cla str.cl_meths meths cl_init)) msubst top cl in @@ -304,18 +312,18 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = (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) + (inh_init, bind_methods cla 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 msubst top cl + build_class_init cla 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 false vals cl_init) | Tclass_apply (cl, exprs) -> - build_class_init cla pub_meths cstr inh_init cl_init msubst top cl + build_class_init cla 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 msubst top cl + build_class_init cla 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 false vals cl_init) @@ -339,7 +347,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init msubst top cl = cl_init)) | _ -> let core cl_init = - build_class_init cla pub_meths true inh_init cl_init msubst top cl + build_class_init cla true inh_init cl_init msubst top cl in if cstr then core cl_init else let (inh_init, cl_init) = @@ -463,8 +471,8 @@ let rec builtin_meths self env env2 body = "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] + | Lsend(Self, met, Lvar s, []) when List.mem s self -> + "meth", [met] | _ -> raise Not_found in match body with @@ -478,14 +486,17 @@ let rec builtin_meths self env env2 body = | 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 -> + | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self -> let s, args = conv arg in ("meth_app_"^s, Lvar n :: args) - | Lsend(Lvar n, Lvar s, []) when List.mem s self -> - ("get_meth", [Lvar n]) - | Lsend(Lvar n, arg, []) -> + | Lsend(Self, met, Lvar s, []) when List.mem s self -> + ("get_meth", [met]) + | Lsend(Public, met, arg, []) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lsend(Cached, met, arg, [_;_]) -> let s, args = conv arg in - ("send_"^s, Lvar n :: args) + ("send_"^s, met :: args) | Lfunction (Curried, [x], body) -> let rec enter self = function | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x']) @@ -621,14 +632,24 @@ let transl_class ids cl_id arity pub_meths cl = 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 msubst top cl + build_class_init cla 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 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 pub_meths = + List.sort + (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) + pub_meths in + let tags = List.map Btype.hash_variant pub_meths in + let rev_map = List.combine tags pub_meths in + List.iter2 + (fun tag name -> + let name' = List.assoc tag rev_map in + if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) + tags pub_meths; let ltable table lam = Llet(Strict, table, Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) @@ -764,3 +785,6 @@ open Format let report_error ppf = function | Illegal_class_expr -> fprintf ppf "This kind of class expression is not allowed" + | Tags (lab1, lab2) -> + fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" + lab1 lab2 "Change one of them." diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli index a17a0b117..85d5f74bc 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -19,7 +19,7 @@ val dummy_class : lambda -> lambda val transl_class : Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;; -type error = Illegal_class_expr +type error = Illegal_class_expr | Tags of string * string exception Error of Location.t * error diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index b5dbed54f..64684bf50 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -518,9 +518,16 @@ let rec transl_exp e = and transl_exp0 e = match e.exp_desc with Texp_ident(path, {val_kind = Val_prim p}) -> - if p.prim_name = "%send" then + let public_send = p.prim_name = "%send" in + if public_send || p.prim_name = "%sendself" then + let kind = if public_send then Public else Self in let obj = Ident.create "obj" and meth = Ident.create "meth" in - Lfunction(Curried, [obj; meth], Lsend(Lvar meth, Lvar obj, [])) + Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [])) + else if p.prim_name = "%sendcache" then + let obj = Ident.create "obj" and meth = Ident.create "meth" in + let cache = Ident.create "cache" and pos = Ident.create "pos" in + Lfunction(Curried, [obj; meth; cache; pos], + Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos])) else transl_primitive p | Texp_ident(path, {val_kind = Val_anc _}) -> @@ -544,17 +551,26 @@ and transl_exp0 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 - 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)]) - | (_, _) -> - if primitive_is_ccall prim - then event_after e (Lprim(prim, transl_list args)) - else Lprim(prim, transl_list args) + let argl = transl_list args in + let public_send = p.prim_name = "%send" + || not !Clflags.native_code && p.prim_name = "%sendcache"in + if public_send || p.prim_name = "%sendself" then + let kind = if public_send then Public else Self in + let obj = List.hd argl in + event_after e (Lsend (kind, List.nth argl 1, obj, [])) + else if p.prim_name = "%sendcache" then + match argl with [obj; meth; cache; pos] -> + event_after e (Lsend(Cached, meth, obj, [cache; pos])) + | _ -> assert false + else begin + let prim = transl_prim p args in + match (prim, args) with + (Praise, [arg1]) -> + Lprim(Praise, [event_after arg1 (List.hd argl)]) + | (_, _) -> + if primitive_is_ccall prim + then event_after e (Lprim(prim, argl)) + else Lprim(prim, argl) end | Texp_apply(funct, oargs) -> event_after e (transl_apply (transl_exp funct) oargs) @@ -657,12 +673,16 @@ and transl_exp0 e = (Lifthenelse(transl_exp cond, event_before body (transl_exp body), staticfail)) | Texp_send(expr, met) -> - let met_id = - match met with - Tmeth_name nm -> Translobj.meth nm - | Tmeth_val id -> id + let obj = transl_exp expr in + let lam = + match met with + Tmeth_val id -> Lsend (Self, Lvar id, obj, []) + | Tmeth_name nm -> + let (tag, cache) = Translobj.meth obj nm in + let kind = if cache = [] then Public else Cached in + Lsend (kind, tag, obj, cache) in - event_after e (Lsend(Lvar met_id, transl_exp expr, [])) + event_after e lam | Texp_new (cl, _) -> Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit]) | Texp_instvar(path_self, path) -> @@ -710,10 +730,10 @@ and transl_tupled_cases patl_expr_list = and transl_apply lam sargs = let lapply funct args = match funct with - Lsend(lmet, lobj, largs) -> - Lsend(lmet, lobj, largs @ args) - | Levent(Lsend(lmet, lobj, largs), _) -> - Lsend(lmet, lobj, largs @ args) + Lsend(k, lmet, lobj, largs) -> + Lsend(k, lmet, lobj, largs @ args) + | Levent(Lsend(k, lmet, lobj, largs), _) -> + Lsend(k, lmet, lobj, largs @ args) | Lapply(lexp, largs) -> Lapply(lexp, largs @ args) | lexp -> diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index f10254d7d..65da2bd62 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -540,7 +540,9 @@ let transl_store_implementation module_name (str, restr) = primitive_declarations := []; let module_id = Ident.create_persistent module_name in let (map, prims, size) = build_ident_map restr (defined_idents str) in - (size, transl_label_init (transl_store_structure module_id map prims str)) + transl_store_label_init module_id size + (transl_store_structure module_id map prims) str + (*size, transl_label_init (transl_store_structure module_id map prims str)*) (* Compile a toplevel phrase *) diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index ea449202e..9899e44b3 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -13,6 +13,7 @@ (* $Id$ *) open Misc +open Primitive open Asttypes open Longident open Lambda @@ -44,23 +45,55 @@ let share c = (* Collect labels *) -let used_methods = ref ([] : (string * Ident.t) list);; - -let meth lab = +let cache_required = ref false +let method_cache = ref lambda_unit +let method_count = ref 0 +let method_table = ref [] + +let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s))) + +let next_cache tag = + let n = !method_count in + incr method_count; + (tag, [!method_cache; Lconst(Const_base(Const_int n))]) + +let rec is_path = function + Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true + | Lprim (Pfield _, [lam]) -> is_path lam + | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) -> + is_path lam1 && is_path lam2 + | _ -> false + +let meth obj lab = + let tag = meth_tag lab in + if not (!cache_required && !Clflags.native_code) then (tag, []) else + if not (is_path obj) then next_cache tag else try - List.assoc lab !used_methods + let r = List.assoc obj !method_table in + try + (tag, List.assoc tag !r) + with Not_found -> + let p = next_cache tag in + r := p :: !r; + p with Not_found -> - let id = Ident.create lab in - used_methods := (lab, id)::!used_methods; - id + let p = next_cache tag in + method_table := (obj, ref [p]) :: !method_table; + p let reset_labels () = Hashtbl.clear consts; - used_methods := [] + method_count := 0; + method_table := [] (* Insert labels *) let string s = Lconst (Const_base (Const_string s)) +let int n = Lconst (Const_base (Const_int n)) + +let prim_makearray = + { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false } let transl_label_init expr = let expr = @@ -68,39 +101,41 @@ let transl_label_init expr = (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 - 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 +let transl_store_label_init glob size f arg = + method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]); + let expr = f arg in + let (size, expr) = + if !method_count = 0 then (size, expr) else + (size+1, + Lsequence( + Lprim(Psetfield(size, false), + [Lprim(Pgetglobal glob, []); + Lprim (Pccall prim_makearray, [int !method_count; int 0])]), + expr)) + in + (size, transl_label_init expr) (* Share classes *) let wrapping = ref false -let required = ref true let top_env = ref Env.empty let classes = ref [] let oo_add_class id = classes := id :: !classes; - (!top_env, !required) + (!top_env, !cache_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 + if !cache_required then f x else + try cache_required := true; let lam = f x in cache_required := false; lam + with exn -> cache_required := false; raise exn else try wrapping := true; - required := req; + cache_required := req; top_env := env; classes := []; let lambda = f x in diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index f0a92b332..d6e432da5 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -17,10 +17,12 @@ open Lambda val oo_prim: string -> lambda val share: structured_constant -> lambda -val meth: string -> Ident.t +val meth: lambda -> string -> lambda * lambda list val reset_labels: unit -> unit val transl_label_init: lambda -> lambda +val transl_store_label_init: + 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 diff --git a/byterun/extern.c b/byterun/extern.c index 8142f79e4..85a549539 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -338,9 +338,11 @@ static void extern_rec(value v) writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd)); extern_rec(v - Infix_offset_hd(hd)); break; + /* Use default case for objects case Object_tag: extern_invalid_argument("output_value: object value"); break; + */ case Custom_tag: { unsigned long sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 470ae825e..b626f2cb0 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -113,7 +113,7 @@ void caml_thread_code (code_t code, asize_t len) l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = - l[BULTINT] = l[BUGEINT] = 2; + l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; diff --git a/byterun/instruct.h b/byterun/instruct.h index c0cf5f2df..a2eb5b7b5 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -53,6 +53,7 @@ enum instructions { BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, ULTINT, UGEINT, BULTINT, BUGEINT, + GETPUBMET, GETDYNMET, STOP, EVENT, BREAK }; diff --git a/byterun/interp.c b/byterun/interp.c index 2c5df85d2..6622d4df8 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -1032,14 +1032,69 @@ value caml_interprete(code_t prog, asize_t prog_size) /* Object-oriented operations */ -#define Lookup(obj, lab) \ - Field (Field (Field (obj, 0), ((lab) >> 16) / sizeof (value)), \ - ((lab) / sizeof (value)) & 0xFF) +#define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab)) Instruct(GETMETHOD): accu = Lookup(sp[0], accu); Next; +#define CAML_METHOD_CACHE +#ifdef CAML_METHOD_CACHE + Instruct(GETPUBMET): { + /* accu == object, pc[0] == tag, pc[1] == cache */ + value meths = Field (accu, 0); + value ofs; +#ifdef CAML_TEST_CACHE + static int calls = 0, hits = 0; + if (calls >= 10000000) { + fprintf(stderr, "cache hit = %d%%\n", hits / 100000); + calls = 0; hits = 0; + } + calls++; +#endif + *--sp = accu; + accu = Val_int(*pc++); + ofs = *pc & Field(meths,1); + if (*(value*)(((char*)&Field(meths,3)) + ofs) == accu) { +#ifdef CAML_TEST_CACHE + hits++; +#endif + accu = *(value*)(((char*)&Field(meths,2)) + ofs); + } + else + { + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (accu < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *pc = (li-3)*sizeof(value); + accu = Field (meths, li-1); + } + pc++; + Next; + } +#else + Instruct(GETPUBMET): + *--sp = accu; + accu = Val_int(*pc); + pc += 2; + /* Fallthrough */ +#endif + Instruct(GETDYNMET): { + /* accu == tag, sp[0] == object, *pc == cache */ + value meths = Field (sp[0], 0); + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (accu < Field(meths,mi)) hi = mi-2; + else li = mi; + } + accu = Field (meths, li-1); + Next; + } + /* Debugging and machine control */ Instruct(STOP): diff --git a/byterun/obj.c b/byterun/obj.c index 6f95f952a..ef340701d 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -197,3 +197,50 @@ CAMLprim value caml_lazy_make_forward (value v) Modify (&Field (res, 0), v); CAMLreturn (res); } + +/* For camlinternalOO.ml + See also GETPUBMET in interp.c + */ + +CAMLprim value caml_get_public_method (value obj, value tag) +{ + value meths = Field (obj, 0); + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + return Field (meths, li-1); +} + +/* +value caml_cache_public_method (value meths, value tag, value *cache) +{ + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value)+1; + return Field (meths, li-1); +} + +value caml_cache_public_method2 (value *meths, value tag, value *cache) +{ + value ofs = *cache & meths[1]; + if (*(value*)(((char*)(meths+3)) + ofs - 1) == tag) + return *(value*)(((char*)(meths+2)) + ofs - 1); + { + int li = 3, hi = meths[0], mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < meths[mi]) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value)+1; + return meths[li-1]; + } +} +*/ diff --git a/stdlib/Makefile b/stdlib/Makefile index 30e78f01a..978102dd5 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -119,20 +119,24 @@ pervasives.p.cmx: pervasives.ml camlinternalOO.cmi: camlinternalOO.mli $(CAMLC) $(COMPFLAGS) -nopervasives -c camlinternalOO.mli +# camlinternalOO.cmx should not be inlined CIOO=camlinternalOO $(CIOO).cmx $(CIOO).p.cmx: $(CIOO).ml - $(MAKE) EXTRAFLAGS="-inline 0" CIOO=dummy $@ + $(MAKE) CAMLOPT="$(CAMLOPT)" OPTCOMPFLAGS="$(OPTCOMPFLAGS)" \ + EXTRAFLAGS="-inline 0" CIOO=dummy $@ # labelled modules require the -nolabels flag labelled.cmo: - $(MAKE) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) \ - COMPILER=$(COMPILER) $(LABELLED:.ml=.cmo) + $(MAKE) CAMLC="$(CAMLC)" COMPFLAGS="$(COMPFLAGS)" \ + EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmo) touch $@ labelled.cmx: - $(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx) + $(MAKE) CAMLOPT="$(CAMLOPT)" OPTCOMPFLAGS="$(OPTCOMPFLAGS)" \ + EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx) touch $@ labelled.p.cmx: - $(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx) + $(MAKE) CAMLOPT="$(CAMLOPT)" OPTCOMPFLAGS="$(OPTCOMPFLAGS)" \ + EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx) touch $@ .SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 7bf5c7b02..fff08b49f 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -54,185 +54,36 @@ let params = { (**** Parameters ****) let step = Sys.word_size / 16 -let first_bucket = 0 -let bucket_size = 32 (* Must be 256 or less *) let initial_object_size = 2 -(**** Index ****) - -type label = int - -let label_count = ref 0 - -let next label = - incr label_count; - let label = label + step in - if label mod (step * bucket_size) = 0 then - label + step * (65536 - bucket_size) - else - label - -let decode label = - (label / 65536 / step, (label mod (step * bucket_size)) / step) - (**** Items ****) -type item +type item = DummyA | DummyB | DummyC of int let dummy_item = (magic () : item) -(**** Buckets ****) - -type bucket = item array - -let version = ref 0 - -let set_bucket_version (bucket : bucket) = - bucket.(bucket_size) <- (magic !version : item) - -let bucket_version bucket = - (magic bucket.(bucket_size) : int) - -let bucket_list = ref [] - -let empty_bucket = [| |] - -let new_bucket () = - let bucket = Array.create (bucket_size + 1) dummy_item in - set_bucket_version bucket; - bucket_list := bucket :: !bucket_list; - bucket - -let copy_bucket bucket = - let bucket = Array.copy bucket in - set_bucket_version bucket; - bucket.(bucket_size) <- (magic !version : item); - bucket_list := bucket :: !bucket_list; - bucket - -(**** Make a clean bucket ****) - -let new_filled_bucket pos methods = - let bucket = new_bucket () in - List.iter - (fun (lab, met) -> - let (buck, elem) = decode lab in - if buck = pos then - bucket.(elem) <- (magic met : item)) - (List.rev methods); - bucket - -(**** Bucket merging ****) - -let small_buckets = ref (Array.create 10 [| |]) -let small_bucket_count = ref 0 - -let insert_bucket bucket = - let length = Array.length !small_buckets in - if !small_bucket_count >= length then begin - let new_array = Array.create (2 * length) [| |] in - Array.blit !small_buckets 0 new_array 0 length; - small_buckets := new_array - end; - !small_buckets.(!small_bucket_count) <- bucket; - incr small_bucket_count - -let remove_bucket n = - !small_buckets.(n) <- !small_buckets.(!small_bucket_count - 1); - decr small_bucket_count - -let bucket_used b = - let n = ref 0 in - for i = 0 to bucket_size - 1 do - if b.(i) != dummy_item then incr n - done; - !n - -let small_bucket b = bucket_used b <= params.bucket_small_size - -exception Failed - -let rec except e = - function - [] -> [] - | e'::l -> if e == e' then l else e'::(except e l) - -let merge_buckets b1 b2 = - for i = 0 to bucket_size - 1 do - if - (b2.(i) != dummy_item) && (b1.(i) != dummy_item) && (b2.(i) != b1.(i)) - then - raise Failed - done; - for i = 0 to bucket_size - 1 do - if b2.(i) != dummy_item then - b1.(i) <- b2.(i) - done; - bucket_list := except b2 !bucket_list; - b1 - -let prng = Random.State.make [| 0 |];; - -let rec choose bucket i = - if (i > 0) && (!small_bucket_count > 0) then begin - let n = Random.State.int prng !small_bucket_count in - if not (small_bucket !small_buckets.(n)) then begin - remove_bucket n; choose bucket i - end else - try - merge_buckets !small_buckets.(n) bucket - with Failed -> - choose bucket (i - 1) - end else begin - insert_bucket bucket; - bucket - end - -let compact b = - if - (b != empty_bucket) && (bucket_version b = !version) && (small_bucket b) - then - choose b params.retry_count - else - b +(**** Types ****) -let compact_buckets buckets = - for i = first_bucket to Array.length buckets - 1 do - buckets.(i) <- compact buckets.(i) - done +type tag +type label = int +type closure = item +type t = DummyA | DummyB | DummyC of int +type obj = t array +external ret : (obj -> 'a) -> closure = "%identity" (**** Labels ****) -let first_label = first_bucket * 65536 * step - -let last_label = ref first_label -let methods = Hashtbl.create 101 - -let new_label () = - let label = !last_label in - last_label := next !last_label; - label - -let new_method met = - try - Hashtbl.find methods met - with Not_found -> - let label = new_label () in - Hashtbl.add methods met label; - label - -let public_method_label met = - try - Hashtbl.find methods met - with Not_found -> - invalid_arg "Oo.public_method_label" - -let new_anonymous_method = - new_label - -(**** Types ****) - -type obj = t array +let public_method_label s : tag = + let accu = ref 0 in + for i = 0 to String.length s - 1 do + accu := 223 * !accu + Char.code s.[i] + done; + (* reduce to 31 bits *) + accu := !accu land (1 lsl 31 - 1); + (* make it signed for 64 bits architectures *) + let tag = if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu in + (* Printf.eprintf "%s = %d\n" s tag; flush stderr; *) + magic tag (**** Sparse array ****) @@ -247,7 +98,7 @@ type labs = bool Labs.t (* The compiler assumes that the first field of this structure is [size]. *) type table = { mutable size: int; - mutable buckets: bucket array; + mutable methods: closure array; mutable methods_by_name: meths; mutable methods_by_label: labs; mutable previous_states: @@ -258,20 +109,31 @@ type table = mutable initializers: (obj -> unit) list } let dummy_table = - { buckets = [| |]; + { methods = [| dummy_item |]; methods_by_name = Meths.empty; methods_by_label = Labs.empty; previous_states = []; hidden_meths = []; vars = Vars.empty; initializers = []; - size = initial_object_size } + size = 0 } let table_count = ref 0 -let new_table () = +let null_item : item = Obj.obj (Obj.field (Obj.repr 0n) 1) + +let rec fit_size n = + if n <= 2 then n else + fit_size ((n+1)/2) * 2 + +let new_table pub_labels = incr table_count; - { buckets = [| |]; + let len = Array.length pub_labels in + let methods = Array.create (len*2+2) null_item in + methods.(0) <- magic len; + methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1); + for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done; + { methods = methods; methods_by_name = Meths.empty; methods_by_label = Labs.empty; previous_states = []; @@ -281,40 +143,42 @@ let new_table () = size = initial_object_size } let resize array new_size = - let old_size = Array.length array.buckets in + let old_size = Array.length array.methods in if new_size > old_size then begin - let new_buck = Array.create new_size empty_bucket in - Array.blit array.buckets 0 new_buck 0 old_size; - array.buckets <- new_buck + let new_buck = Array.create new_size null_item in + Array.blit array.methods 0 new_buck 0 old_size; + array.methods <- new_buck end let put array label element = - let (buck, elem) = decode label in - resize array (buck + 1); - let bucket = ref (array.buckets.(buck)) in - if !bucket == empty_bucket then begin - bucket := new_bucket (); - array.buckets.(buck) <- !bucket - end; - !bucket.(elem) <- element + resize array (label + 1); + array.methods.(label) <- element (**** Classes ****) let method_count = ref 0 let inst_var_count = ref 0 -type t +(* type t *) type meth = item +let new_method table = + let index = Array.length table.methods in + resize table (index + 1); + index + let get_method_label table name = try Meths.find name table.methods_by_name with Not_found -> - let label = new_anonymous_method () in + let label = new_method table in table.methods_by_name <- Meths.add name label table.methods_by_name; table.methods_by_label <- Labs.add label true table.methods_by_label; label +let get_method_labels table names = + Array.map (get_method_label table) names + let set_method table label element = incr method_count; if Labs.find label table.methods_by_label then @@ -323,9 +187,8 @@ let set_method table label element = table.hidden_meths <- (label, element) :: table.hidden_meths let get_method table label = - try List.assoc label table.hidden_meths with Not_found -> - let (buck, elem) = decode label in - table.buckets.(buck).(elem) + try List.assoc label table.hidden_meths + with Not_found -> table.methods.(label) let to_list arr = if arr == magic 0 then [] else Array.to_list arr @@ -403,25 +266,39 @@ let new_variables table names = let get_variable table name = Vars.find name table.vars +let get_variables table names = + Array.map (get_variable table) names + let add_initializer table f = table.initializers <- f::table.initializers +(* +module Keys = Map.Make(struct type t = tag array let compare = compare end) +let key_map = ref Keys.empty +let get_key tags : item = + try magic (Keys.find tags !key_map : tag array) + with Not_found -> + key_map := Keys.add tags tags !key_map; + magic tags +*) + let create_table public_methods = - let table = new_table () in - 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; + if public_methods == magic 0 then new_table [||] else + (* [public_methods] must be in ascending order for bytecode *) + let tags = Array.map public_method_label public_methods in + let table = new_table tags in + Array.iteri + (fun i met -> + let lab = i*2+2 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 = inst_var_count := !inst_var_count + table.size - 1; - if params.compact_table then - compact_buckets table.buckets; - table.initializers <- List.rev table.initializers + table.initializers <- List.rev table.initializers; + resize table (3 + magic table.methods.(1) * 16 / Sys.word_size) let inherits cla vals virt_meths concr_meths (_, super, _, env) top = narrow cla vals virt_meths concr_meths; @@ -451,7 +328,7 @@ let create_object table = (* XXX Appel de [obj_block] *) let obj = Obj.new_block Obj.object_tag table.size in (* XXX Appel de [caml_modify] *) - Obj.set_field obj 0 (Obj.repr table.buckets); + Obj.set_field obj 0 (Obj.repr table.methods); set_id obj last_id; (Obj.obj obj) @@ -460,7 +337,7 @@ let create_object_opt obj_0 table = (* XXX Appel de [obj_block] *) let obj = Obj.new_block Obj.object_tag table.size in (* XXX Appel de [caml_modify] *) - Obj.set_field obj 0 (Obj.repr table.buckets); + Obj.set_field obj 0 (Obj.repr table.methods); set_id obj last_id; (Obj.obj obj) end @@ -490,17 +367,20 @@ let create_object_and_run_initializers obj_0 table = 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 +let sendself obj lab = + (magic obj : (obj -> t) array array).(0).(lab) obj *) -external send : obj -> label -> 'a = "%send" +external send : obj -> tag -> 'a = "%send" +external sendcache : obj -> tag -> t -> int -> 'a = "%sendcache" +external sendself : obj -> label -> 'a = "%sendself" +external get_public_method : obj -> tag -> closure + = "caml_get_public_method" "noalloc" (**** table collection access ****) -type tables = Empty | Cons of table * tables * tables +type tables = Empty | Cons of closure * tables * tables type mut_tables = - {key: table; mutable data: tables; mutable next: tables} + {key: closure; mutable data: tables; mutable next: tables} external mut : tables -> mut_tables = "%identity" let build_path n keys tables = @@ -533,39 +413,61 @@ let lookup_tables root keys = (**** 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 get_env e n = + ret (fun obj -> + Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) +let get_meth n = ret (fun obj -> sendself 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_env f e n = + ret (fun obj -> + f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)) +let app_meth f n = ret (fun obj -> f (sendself 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_const_meth f x n = ret (fun obj -> f x (sendself 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_meth_const f n x = ret (fun obj -> f (sendself obj n) x) let app_const_env f x e n = - ret (fun obj -> f x (Obj.field (Array.unsafe_get obj e) n)) + ret (fun obj -> + f x (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) 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) + ret (fun obj -> + f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x) +let meth_app_const n x = ret (fun obj -> (sendself obj n) x) let meth_app_var n m = - ret (fun obj -> (send obj n) (Array.unsafe_get obj m)) + ret (fun obj -> (sendself 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)) + ret (fun obj -> (sendself obj n) + (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m)) let meth_app_meth n m = - ret (fun obj -> (send obj n) (send obj m)) -let send_const m x = ret (fun obj -> send x m) -let send_var m n = ret (fun obj -> send (Obj.obj (Array.unsafe_get obj n)) m) -let send_env m e n = - ret (fun obj -> send (Obj.obj (Obj.field (Array.unsafe_get obj e) n)) m) -let send_meth m n = ret (fun obj -> send (send obj n) m) + ret (fun obj -> (sendself obj n) (sendself obj m)) +let send_const m x c = + ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c) +let send_var m n c = + ret (fun obj -> + sendcache (Obj.magic (Array.unsafe_get obj n) : obj) m + (Array.unsafe_get obj 0) c) +let send_env m e n c = + ret (fun obj -> + sendcache + (Obj.magic (Array.unsafe_get + (Obj.magic (Array.unsafe_get obj e) : obj) n) : obj) + m (Array.unsafe_get obj 0) c) +let send_meth m n c = + ret (fun obj -> + sendcache (sendself obj n) m (Array.unsafe_get obj 0) c) +let new_cache table = + let n = new_method table in + let n = + if n mod 2 = 0 || n > 2 + magic table.methods.(1) * 16 / Sys.word_size + then n else new_method table + in + table.methods.(n) <- Obj.magic 0; + n type impl = GetConst @@ -592,9 +494,9 @@ type impl = | SendVar | SendEnv | SendMeth - | Closure of Obj.t + | Closure of closure -let method_impl i arr = +let method_impl table i arr = let next () = incr i; magic arr.(!i) in match next() with GetConst -> let x : t = next() in get_const x @@ -631,17 +533,21 @@ let method_impl i arr = 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 - | SendConst -> let m = next() and x = next() in send_const m x - | SendVar -> let m = next() and n = next () in send_var m n - | SendEnv -> - let m = next() and e = next() and n = next() in send_env m e n - | SendMeth -> let m = next() and n = next () in send_meth m n + | SendConst -> + let m = next() and x = next() in send_const m x (new_cache table) + | SendVar -> + let m = next() and n = next () in send_var m n (new_cache table) + | SendEnv -> + let m = next() and e = next() and n = next() in + send_env m e n (new_cache table) + | SendMeth -> + let m = next() and n = next () in send_meth m n (new_cache table) | 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 + let label = methods.(!i) and clo = method_impl table i methods in set_method table label clo; incr i done @@ -649,35 +555,8 @@ let set_methods table methods = (**** Statistics ****) type stats = - { classes: int; labels: int; methods: int; inst_vars: int; buckets: int; - distrib : int array; small_bucket_count: int; small_bucket_max: int } - -let distrib () = - let d = Array.create 32 0 in - List.iter - (function b -> - let n = bucket_used b in - d.(n - 1) <- d.(n - 1) + 1) - !bucket_list; - d + { classes: int; methods: int; inst_vars: int; } let stats () = - { classes = !table_count; labels = !label_count; - methods = !method_count; inst_vars = !inst_var_count; - buckets = List.length !bucket_list; distrib = distrib (); - small_bucket_count = !small_bucket_count; - small_bucket_max = Array.length !small_buckets } - -let sort_buck lst = - List.map snd - (Sort.list (fun (n, _) (n', _) -> n <= n') - (List.map (function b -> (bucket_used b, b)) lst)) - -let show_buckets () = - List.iter - (function b -> - for i = 0 to bucket_size - 1 do - print_char (if b.(i) == dummy_item then '.' else '*') - done; - print_newline ()) - (sort_buck !bucket_list) + { classes = !table_count; + methods = !method_count; inst_vars = !inst_var_count; } diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli index 92345c4b1..8b6c980f6 100644 --- a/stdlib/camlinternalOO.mli +++ b/stdlib/camlinternalOO.mli @@ -17,22 +17,23 @@ All functions in this module are for system use only, not for the casual user. *) -(** {6 Methods} *) - -type label -val new_method : string -> label -val public_method_label : string -> label - (** {6 Classes} *) +type tag +type label type table type meth type t type obj +type closure +val public_method_label : string -> tag +val new_method : table -> label val new_variable : table -> string -> int val new_variables : table -> string array -> int val get_variable : table -> string -> int +val get_variables : table -> string array -> int array val get_method_label : table -> string -> label +val get_method_labels : table -> string array -> label array val get_method : table -> label -> meth val set_method : table -> label -> meth -> unit val set_methods : table -> label array -> unit @@ -60,17 +61,19 @@ 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 -external send : obj -> label -> t = "%send" +external send : obj -> tag -> t = "%send" +external sendcache : obj -> tag -> t -> int -> t = "%sendcache" +external sendself : obj -> label -> t = "%sendself" +external get_public_method : obj -> tag -> closure + = "caml_get_public_method" "noalloc" (** {6 Table cache} *) type tables -val lookup_tables : tables -> table array -> tables +val lookup_tables : tables -> closure 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 @@ -91,10 +94,10 @@ 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 -val send_const : label -> obj -> closure -val send_var : label -> int -> closure -val send_env : label -> int -> int -> closure -val send_meth : label -> label -> closure +val send_const : tag -> obj -> int -> closure +val send_var : tag -> int -> int -> closure +val send_env : tag -> int -> int -> int -> closure +val send_meth : tag -> label -> int -> closure type impl = GetConst @@ -121,10 +124,11 @@ type impl = | SendVar | SendEnv | SendMeth - | Closure of t + | Closure of closure (** {6 Parameters} *) +(* currently disabled *) type params = { mutable compact_table : bool; mutable copy_parent : bool; @@ -138,12 +142,6 @@ val params : params type stats = { classes : int; - labels : int; methods : int; - inst_vars : int; - buckets : int; - distrib : int array; - small_bucket_count : int; - small_bucket_max : int } + inst_vars : int } val stats : unit -> stats -val show_buckets : unit -> unit diff --git a/stdlib/oo.ml b/stdlib/oo.ml index e8795d857..c9ec64ae4 100644 --- a/stdlib/oo.ml +++ b/stdlib/oo.ml @@ -15,5 +15,5 @@ let copy = CamlinternalOO.copy external id : < .. > -> int = "%field1" -let new_method = CamlinternalOO.new_method +let new_method = CamlinternalOO.public_method_label let public_method_label = CamlinternalOO.public_method_label diff --git a/stdlib/oo.mli b/stdlib/oo.mli index c18bfa51e..b3111ce85 100644 --- a/stdlib/oo.mli +++ b/stdlib/oo.mli @@ -25,5 +25,5 @@ external id : < .. > -> int = "%field1" (**/**) (** For internal use (CamlIDL) *) -val new_method : string -> CamlinternalOO.label -val public_method_label : string -> CamlinternalOO.label +val new_method : string -> CamlinternalOO.tag +val public_method_label : string -> CamlinternalOO.tag diff --git a/stdlib/sys.ml b/stdlib/sys.ml index 3d7e7e256..c6646a029 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+18 (2004-05-17)";; +let ocaml_version = "3.07+19 (2004-05-26)";; diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index 5b9a85b4c..a362c91a1 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -234,6 +234,7 @@ type shape = | Uint_Primitive | Switch | Closurerec + | Pubmet ;; let op_shapes = [ @@ -368,6 +369,8 @@ let op_shapes = [ opOFFSETREF, Sint; opISINT, Nothing; opGETMETHOD, Nothing; + opGETDYNMET, Nothing; + opGETPUBMET, Pubmet; opBEQ, Sint_Disp; opBNEQ, Sint_Disp; opBLTINT, Sint_Disp; @@ -436,6 +439,10 @@ let print_instr ic = print_string ", "; print_int (orig + inputu ic); done; + | Pubmet + -> let tag = inputs ic in + let cache = inputu ic in + print_int tag | Nothing -> () with Not_found -> print_string "(unknown arguments)" end; |