summaryrefslogtreecommitdiff
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/bytegen.ml10
-rw-r--r--bytecomp/lambda.ml12
-rw-r--r--bytecomp/lambda.mli2
-rw-r--r--bytecomp/printlambda.ml2
-rw-r--r--bytecomp/simplif.ml89
-rw-r--r--bytecomp/translclass.ml10
-rw-r--r--bytecomp/translcore.ml20
7 files changed, 109 insertions, 36 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 09c254d4f3..b6c8f6fae8 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -413,12 +413,10 @@ let rec comp_expr env exp sz cont =
| Lapply(func, args, loc) ->
let nargs = List.length args in
if is_tailcall cont then begin
- Stypes.record (Stypes.An_call (loc, Annot.Tail));
comp_args env args sz
(Kpush :: comp_expr env func (sz + nargs)
(Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
end else begin
- Stypes.record (Stypes.An_call (loc, Annot.Stack));
if nargs < 4 then
comp_args env args sz
(Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
@@ -430,7 +428,7 @@ let rec comp_expr env exp sz cont =
(Kapply nargs :: cont1))
end
end
- | Lsend(kind, 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' =
@@ -746,9 +744,9 @@ let rec comp_expr env exp sz cont =
| Lev_after ty ->
let info =
match lam with
- Lapply(_, args, _) -> Event_return (List.length args)
- | Lsend(_, _, _, args) -> Event_return (List.length args + 1)
- | _ -> Event_other
+ Lapply(_, args, _) -> Event_return (List.length args)
+ | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
+ | _ -> Event_other
in
let ev = event (Event_after ty) info in
let cont1 = add_event ev cont in
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index ff94a6d9cc..06523ebcc1 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -140,7 +140,7 @@ type lambda =
| Lwhile of lambda * lambda
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
- | Lsend of meth_kind * lambda * lambda * lambda list
+ | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
@@ -201,7 +201,7 @@ let rec same l1 l2 =
same b1 b2 && df1 = df2 && same c1 c2
| Lassign(id1, a1), Lassign(id2, a2) ->
Ident.same id1 id2 && same a1 a2
- | Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
+ | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) ->
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
| Levent(a1, ev1), Levent(a2, ev2) ->
same a1 a2 && ev1.lev_loc = ev2.lev_loc
@@ -277,7 +277,7 @@ let rec iter f = function
f e1; f e2; f e3
| Lassign(id, e) ->
f e
- | Lsend (k, met, obj, args) ->
+ | Lsend (k, met, obj, args, _) ->
List.iter f (met::obj::args)
| Levent (lam, evt) ->
f lam
@@ -320,7 +320,7 @@ let free_variables l =
free_ids (function Lvar id -> [id] | _ -> []) l
let free_methods l =
- free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
+ free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
(* Check if an action has a "when" guard *)
let raise_count = ref 0
@@ -398,8 +398,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 (k, met, obj, args) ->
- Lsend (k, subst met, subst obj, List.map subst args)
+ | Lsend (k, met, obj, args, loc) ->
+ Lsend (k, subst met, subst obj, List.map subst args, loc)
| 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 8c34ac94ab..e671b89156 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -149,7 +149,7 @@ type lambda =
| Lwhile of lambda * lambda
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
| Lassign of Ident.t * lambda
- | Lsend of meth_kind * lambda * lambda * lambda list
+ | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 0d6e19148d..9bfa099e15 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -285,7 +285,7 @@ let rec lam ppf = function
lam hi lam body
| Lassign(id, expr) ->
fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
- | Lsend (k, met, obj, largs) ->
+ | Lsend (k, met, obj, largs, _) ->
let args ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
let kind =
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 6081d5bd4a..e758eed489 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -75,9 +75,9 @@ let rec eliminate_ref id = function
dir, eliminate_ref id e3)
| Lassign(v, e) ->
Lassign(v, eliminate_ref id e)
- | Lsend(k, m, o, el) ->
+ | Lsend(k, m, o, el, loc) ->
Lsend(k, eliminate_ref id m, eliminate_ref id o,
- List.map (eliminate_ref id) el)
+ List.map (eliminate_ref id) el, loc)
| Levent(l, ev) ->
Levent(eliminate_ref id l, ev)
| Lifused(v, e) ->
@@ -144,7 +144,7 @@ let simplify_exits lam =
(* Lalias-bound variables are never assigned, so don't increase
v's refcount *)
count l
- | Lsend(k, 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(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
+ | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
| 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,11 +402,86 @@ 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(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
+ | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
| Levent(l, ev) -> Levent(simplif l, ev)
| Lifused(v, l) ->
if count_var v > 0 then simplif l else lambda_unit
in
simplif lam
-let simplify_lambda lam = simplify_lets (simplify_exits lam)
+let rec emit_tail_infos is_tail lambda =
+ let is_tail_native_heuristic _ =
+ true in
+ let call_kind x =
+ if is_tail && ((not !Clflags.native_code) || (is_tail_native_heuristic x)) then
+ Annot.Tail
+ else
+ Annot.Stack in
+ match lambda with
+ | Lvar _ -> ()
+ | Lconst _ -> ()
+ | Lapply (func, l, loc) ->
+ list_emit_tail_infos false l;
+ Stypes.record (Stypes.An_call (loc, call_kind ()))
+ | Lfunction (_, _, lam) ->
+ emit_tail_infos true lam
+ | Llet (_, _, lam, body) ->
+ emit_tail_infos false lam;
+ emit_tail_infos is_tail body
+ | Lletrec (bindings, body) ->
+ List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
+ emit_tail_infos is_tail body
+ | Lprim (Pidentity, [arg]) ->
+ emit_tail_infos is_tail arg
+ | Lprim (Psequand, [arg1; arg2])
+ | Lprim (Psequor, [arg1; arg2]) ->
+ emit_tail_infos false arg1;
+ emit_tail_infos is_tail arg2
+ | Lprim (_, l) ->
+ list_emit_tail_infos false l
+ | Lswitch (lam, sw) ->
+ emit_tail_infos false lam;
+ list_emit_tail_infos_fun snd is_tail sw.sw_consts;
+ list_emit_tail_infos_fun snd is_tail sw.sw_blocks
+ | Lstaticraise (_, l) ->
+ list_emit_tail_infos false l
+ | Lstaticcatch (body, _, handler) ->
+ emit_tail_infos is_tail body;
+ emit_tail_infos is_tail handler
+ | Ltrywith (body, _, handler) ->
+ emit_tail_infos false body;
+ emit_tail_infos is_tail handler
+ | Lifthenelse (cond, ifso, ifno) ->
+ emit_tail_infos false cond;
+ emit_tail_infos is_tail ifso;
+ emit_tail_infos is_tail ifno
+ | Lsequence (lam1, lam2) ->
+ emit_tail_infos false lam1;
+ emit_tail_infos is_tail lam2
+ | Lwhile (cond, body) ->
+ emit_tail_infos false cond;
+ emit_tail_infos false body
+ | Lfor (_, low, high, _, body) ->
+ emit_tail_infos false low;
+ emit_tail_infos false high;
+ emit_tail_infos false body
+ | Lassign (_, lam) ->
+ emit_tail_infos false lam
+ | Lsend (_, meth, obj, args, loc) ->
+ emit_tail_infos false meth;
+ emit_tail_infos false obj;
+ list_emit_tail_infos false args;
+ Stypes.record (Stypes.An_call (loc, call_kind ()))
+ | Levent (lam, _) ->
+ emit_tail_infos is_tail lam
+ | Lifused (_, lam) ->
+ emit_tail_infos is_tail lam
+and list_emit_tail_infos_fun f is_tail =
+ List.iter (fun x -> emit_tail_infos is_tail (f x))
+and list_emit_tail_infos is_tail =
+ List.iter (emit_tail_infos is_tail)
+
+let simplify_lambda lam =
+ let res = simplify_lets (simplify_exits lam) in
+ emit_tail_infos true res;
+ res
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index cf5783a979..e18a13ba6c 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -495,7 +495,7 @@ 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(Self, met, Lvar s, []) when List.mem s self ->
+ | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
"meth", [met]
| _ -> raise Not_found
in
@@ -510,15 +510,15 @@ 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(Self, 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(Self, met, Lvar s, []) when List.mem s self ->
+ | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
("get_meth", [met])
- | Lsend(Public, met, arg, []) ->
+ | Lsend(Public, met, arg, [], _) ->
let s, args = conv arg in
("send_"^s, met :: args)
- | Lsend(Cached, met, arg, [_;_]) ->
+ | Lsend(Cached, met, arg, [_;_], _) ->
let s, args = conv arg in
("send_"^s, met :: args)
| Lfunction (Curried, [x], body) ->
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 31b1e8093b..b0a1ec6ef8 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -571,12 +571,12 @@ and transl_exp0 e =
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(kind, Lvar meth, Lvar obj, []))
+ Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
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]))
+ Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
else
transl_primitive p
| Texp_ident(path, {val_kind = Val_anc _}) ->
@@ -614,10 +614,10 @@ and transl_exp0 e =
if public_send || p.prim_name = "%sendself" then
let kind = if public_send then Public else Self in
let obj = List.hd argl in
- wrap (Lsend (kind, List.nth argl 1, obj, []))
+ wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
else if p.prim_name = "%sendcache" then
match argl with [obj; meth; cache; pos] ->
- wrap (Lsend(Cached, meth, obj, [cache; pos]))
+ wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
| _ -> assert false
else begin
let prim = transl_prim p args in
@@ -737,11 +737,11 @@ and transl_exp0 e =
let obj = transl_exp expr in
let lam =
match met with
- Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
+ Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
| 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)
+ Lsend (kind, tag, obj, cache, e.exp_loc)
in
event_after e lam
| Texp_new (cl, _) ->
@@ -840,10 +840,10 @@ and transl_tupled_cases patl_expr_list =
and transl_apply lam sargs loc =
let lapply funct args =
match funct with
- Lsend(k, lmet, lobj, largs) ->
- Lsend(k, lmet, lobj, largs @ args)
- | Levent(Lsend(k, lmet, lobj, largs), _) ->
- Lsend(k, lmet, lobj, largs @ args)
+ Lsend(k, lmet, lobj, largs, loc) ->
+ Lsend(k, lmet, lobj, largs @ args, loc)
+ | Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
+ Lsend(k, lmet, lobj, largs @ args, loc)
| Lapply(lexp, largs, _) ->
Lapply(lexp, largs @ args, loc)
| lexp ->
View Lorry Controller Status