summaryrefslogtreecommitdiffstats
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/bytegen.ml23
-rw-r--r--bytecomp/emitcode.ml2
-rw-r--r--bytecomp/instruct.ml2
-rw-r--r--bytecomp/instruct.mli2
-rw-r--r--bytecomp/lambda.ml9
-rw-r--r--bytecomp/lambda.mli4
-rw-r--r--bytecomp/matching.mli4
-rw-r--r--bytecomp/printinstr.ml2
-rw-r--r--bytecomp/printlambda.ml6
-rw-r--r--bytecomp/simplif.ml12
-rw-r--r--bytecomp/translclass.ml80
-rw-r--r--bytecomp/translclass.mli2
-rw-r--r--bytecomp/translcore.ml64
-rw-r--r--bytecomp/translmod.ml4
-rw-r--r--bytecomp/translobj.ml83
-rw-r--r--bytecomp/translobj.mli4
16 files changed, 206 insertions, 97 deletions
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
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 13:05:23 +0000