summaryrefslogtreecommitdiffstats
path: root/bytecomp
diff options
context:
space:
mode:
Diffstat (limited to 'bytecomp')
-rw-r--r--bytecomp/bytegen.ml11
-rw-r--r--bytecomp/lambda.ml8
-rw-r--r--bytecomp/lambda.mli2
-rw-r--r--bytecomp/printlambda.ml2
-rw-r--r--bytecomp/simplif.ml12
-rw-r--r--bytecomp/translclass.ml89
-rw-r--r--bytecomp/translcore.ml20
-rw-r--r--bytecomp/translcore.mli3
-rw-r--r--bytecomp/translmod.ml16
9 files changed, 89 insertions, 74 deletions
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 2cd0c65b0..45df057e1 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -414,13 +414,15 @@ let rec comp_expr env exp sz cont =
end
| Lconst cst ->
Kconst cst :: cont
- | Lapply(func, args) ->
+ | Lapply(func, args, loc) ->
let nargs = List.length args in
- if is_tailcall cont then
+ 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))
- else
+ 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))
@@ -431,6 +433,7 @@ let rec comp_expr env exp sz cont =
(Kpush :: comp_expr env func (sz + 3 + nargs)
(Kapply nargs :: cont1))
end
+ end
| Lsend(kind, met, obj, args) ->
let args = if kind = Cached then List.tl args else args in
let nargs = List.length args + 1 in
@@ -746,7 +749,7 @@ let rec comp_expr env exp sz cont =
| Lev_after ty ->
let info =
match lam with
- Lapply(_, args) -> Event_return (List.length args)
+ Lapply(_, args, _) -> Event_return (List.length args)
| Lsend(_, _, _, args) -> Event_return (List.length args + 1)
| _ -> Event_other
in
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index b66378c9e..c6017d918 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -124,7 +124,7 @@ type shared_code = (int * int) list
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
- | Lapply of lambda * lambda list
+ | Lapply of lambda * lambda list * Location.t
| Lfunction of function_kind * Ident.t list * lambda
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
@@ -170,7 +170,7 @@ let rec same l1 l2 =
Ident.same v1 v2
| Lconst c1, Lconst c2 ->
c1 = c2
- | Lapply(a1, bl1), Lapply(a2, bl2) ->
+ | Lapply(a1, bl1, _), Lapply(a2, bl2, _) ->
same a1 a2 && samelist same bl1 bl2
| Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) ->
k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2
@@ -240,7 +240,7 @@ let name_lambda_list args fn =
let rec iter f = function
Lvar _
| Lconst _ -> ()
- | Lapply(fn, args) ->
+ | Lapply(fn, args, _) ->
f fn; List.iter f args
| Lfunction(kind, params, body) ->
f body
@@ -374,7 +374,7 @@ let subst_lambda s lam =
Lvar id as l ->
begin try Ident.find_same id s with Not_found -> l end
| Lconst sc as l -> l
- | Lapply(fn, args) -> Lapply(subst fn, List.map subst args)
+ | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc)
| Lfunction(kind, params, body) -> Lfunction(kind, params, subst body)
| Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
| Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 6a9c75fd8..cf8152a9a 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -133,7 +133,7 @@ type shared_code = (int * int) list (* stack size -> code label *)
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
- | Lapply of lambda * lambda list
+ | Lapply of lambda * lambda list * Location.t
| Lfunction of function_kind * Ident.t list * lambda
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 3f42f7e1e..a67642b2e 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -185,7 +185,7 @@ let rec lam ppf = function
Ident.print ppf id
| Lconst cst ->
struct_const ppf cst
- | Lapply(lfun, largs) ->
+ | Lapply(lfun, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index ee59cab74..f7381d962 100644
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -26,8 +26,8 @@ let rec eliminate_ref id = function
Lvar v as lam ->
if Ident.same v id then raise Real_reference else lam
| Lconst cst as lam -> lam
- | Lapply(e1, el) ->
- Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el)
+ | Lapply(e1, el, loc) ->
+ Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
| Lfunction(kind, params, body) as lam ->
if IdentSet.mem id (free_variables lam)
then raise Real_reference
@@ -104,7 +104,7 @@ let simplify_exits lam =
let rec count = function
| (Lvar _| Lconst _) -> ()
- | Lapply(l1, ll) -> count l1; List.iter count ll
+ | Lapply(l1, ll, _) -> count l1; List.iter count ll
| Lfunction(kind, params, l) -> count l
| Llet(str, v, l1, l2) ->
count l2; count l1
@@ -185,7 +185,7 @@ let simplify_exits lam =
let rec simplif = function
| (Lvar _|Lconst _) as l -> l
- | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll)
+ | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
| Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
| Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
| Lletrec(bindings, body) ->
@@ -276,7 +276,7 @@ let simplify_lets lam =
let rec count = function
| Lvar v -> incr_var v
| Lconst cst -> ()
- | Lapply(l1, ll) -> count l1; List.iter count ll
+ | Lapply(l1, ll, _) -> count l1; List.iter count ll
| Lfunction(kind, params, l) -> count l
| Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
(* v will be replaced by w in l2, so each occurrence of v in l2
@@ -346,7 +346,7 @@ let simplify_lets lam =
l
end
| Lconst cst as l -> l
- | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll)
+ | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
| Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
| Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
Hashtbl.add subst v (simplif (Lvar w));
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index fd2b91de0..7ea71185e 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -34,12 +34,14 @@ let lfunction params body =
| _ ->
Lfunction (Curried, params, body)
-let lapply func args =
+let lapply func args loc =
match func with
- Lapply(func', args') ->
- Lapply(func', args' @ args)
+ Lapply(func', args', _) ->
+ Lapply(func', args' @ args, loc)
| _ ->
- Lapply(func, args)
+ Lapply(func, args, loc)
+
+let mkappl (func, args) = Lapply (func, args, Location.none);;
let lsequence l1 l2 =
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
@@ -68,7 +70,7 @@ let copy_inst_var obj id expr templ offset =
Lvar offset])])]))
let transl_val tbl create name =
- Lapply (oo_prim (if create then "new_variable" else "get_variable"),
+ mkappl (oo_prim (if create then "new_variable" else "get_variable"),
[Lvar tbl; transl_label name])
let transl_vals tbl create vals rem =
@@ -82,7 +84,7 @@ let meths_super tbl meths inh_meths =
(fun (nm, id) rem ->
try
(nm, id,
- Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
+ mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
:: rem
with Not_found -> rem)
inh_meths []
@@ -97,16 +99,16 @@ let create_object cl obj init =
let (inh_init, obj_init, has_init) = init obj' in
if obj_init = lambda_unit then
(inh_init,
- Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
+ mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
else"create_object_opt"),
[obj; Lvar cl]))
else begin
(inh_init,
Llet(Strict, obj',
- Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
+ mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
Lsequence(obj_init,
if not has_init then Lvar obj' else
- Lapply (oo_prim "run_initializers_opt",
+ mkappl (oo_prim "run_initializers_opt",
[obj; Lvar obj'; Lvar cl]))))
end
@@ -120,7 +122,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
| Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
in
((envs, (obj_init, path)::inh_init),
- Lapply(Lvar obj_init, env @ [obj]))
+ mkappl(Lvar obj_init, env @ [obj]))
| Tclass_structure str ->
create_object cl_table obj (fun obj ->
let (inh_init, obj_init, has_init) =
@@ -177,7 +179,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
let (inh_init, obj_init) =
build_object_init cl_table obj params inh_init obj_init cl
in
- (inh_init, transl_apply obj_init oexprs)
+ (inh_init, transl_apply obj_init oexprs Location.none)
| Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
@@ -203,7 +205,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
let bind_method tbl lab id cl_init =
- Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+ Llet(StrictOpt, id, mkappl (oo_prim "get_method_label",
[Lvar tbl; transl_label lab]),
cl_init)
@@ -219,7 +221,7 @@ let bind_methods tbl meths vals cl_init =
"new_methods_variables", [transl_meth_list (List.map fst vals)]
in
Llet(StrictOpt, ids,
- Lapply (oo_prim getter,
+ mkappl (oo_prim getter,
[Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
List.fold_right
(fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
@@ -229,9 +231,9 @@ let output_methods tbl methods lam =
match methods with
[] -> lam
| [lab; code] ->
- lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+ lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
| _ ->
- lsequence (Lapply(oo_prim "set_methods",
+ lsequence (mkappl(oo_prim "set_methods",
[Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
lam
@@ -254,7 +256,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
let lpath = transl_path path in
(inh_init,
Llet (Strict, obj_init,
- Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
+ mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
bind_super cla super cl_init))
| _ ->
@@ -295,7 +297,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
(inh_init, cl_init, methods, vals @ values)
| Cf_init exp ->
(inh_init,
- Lsequence(Lapply (oo_prim "add_initializer",
+ Lsequence(mkappl (oo_prim "add_initializer",
Lvar cla :: msubst false (transl_exp exp)),
cl_init),
methods, values))
@@ -348,7 +350,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
cl_init valids in
(inh_init,
Llet (Strict, inh,
- Lapply(oo_prim "inherits", narrow_args @
+ mkappl(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
| _ ->
@@ -357,10 +359,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
in
if cstr then core cl_init else
let (inh_init, cl_init) =
- core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
+ core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
in
(inh_init,
- Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
+ Lsequence(mkappl (oo_prim "narrow", narrow_args),
+ cl_init))
end
let rec build_class_lets cl =
@@ -407,7 +410,7 @@ let rec transl_class_rebind obj_init cl vf =
| rem -> build [] rem)
| Tclass_apply (cl, oexprs) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
- (path, transl_apply obj_init oexprs)
+ (path, transl_apply obj_init oexprs Location.none)
| Tclass_let (rec_flag, defs, vals, cl) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
@@ -435,7 +438,7 @@ let transl_class_rebind ids cl vf =
try
let obj_init = Ident.create "obj_init"
and self = Ident.create "self" in
- let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
+ let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in
let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));
@@ -452,13 +455,13 @@ let transl_class_rebind ids cl vf =
Llet(
Alias, cla, transl_path path,
Lprim(Pmakeblock(0, Immutable),
- [Lapply(Lvar new_init, [lfield cla 0]);
+ [mkappl(Lvar new_init, [lfield cla 0]);
lfunction [table]
(Llet(Strict, env_init,
- Lapply(lfield cla 1, [Lvar table]),
+ mkappl(lfield cla 1, [Lvar table]),
lfunction [envs]
- (Lapply(Lvar new_init,
- [Lapply(Lvar env_init, [Lvar envs])]))));
+ (mkappl(Lvar new_init,
+ [mkappl(Lvar env_init, [Lvar envs])]))));
lfield cla 2;
lfield cla 3])))
with Exit ->
@@ -497,12 +500,12 @@ let rec builtin_meths self env env2 body =
match body with
| Llet(_, s', Lvar s, body) when List.mem s self ->
builtin_meths (s'::self) env env2 body
- | Lapply(f, [arg]) when const_path f ->
+ | Lapply(f, [arg], _) when const_path f ->
let s, args = conv arg in ("app_"^s, f :: args)
- | Lapply(f, [arg; p]) when const_path f && const_path p ->
+ | Lapply(f, [arg; p], _) when const_path f && const_path p ->
let s, args = conv arg in
("app_"^s^"_const", f :: args @ [p])
- | Lapply(f, [p; arg]) when const_path f && const_path p ->
+ | 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 ->
@@ -533,7 +536,7 @@ module M = struct
open CamlinternalOO
let builtin_meths self env env2 body =
let builtin, args = builtin_meths self env env2 body in
- (* if not arr then [Lapply(oo_prim builtin, args)] else *)
+ (* if not arr then [mkappl(oo_prim builtin, args)] else *)
let tag = match builtin with
"get_const" -> GetConst
| "get_var" -> GetVar
@@ -680,11 +683,11 @@ let transl_class ids cl_id arity pub_meths cl vflag =
tags pub_meths;
let ltable table lam =
Llet(Strict, table,
- Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
+ mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
and ldirect obj_init =
Llet(Strict, obj_init, cl_init,
- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
- Lapply(Lvar obj_init, [lambda_unit])))
+ Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
+ mkappl (Lvar obj_init, [lambda_unit])))
in
(* Simplest case: an object defined at toplevel (ids=[]) *)
if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
@@ -695,16 +698,16 @@ let transl_class ids cl_id arity pub_meths cl vflag =
Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
and lbody fv =
if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
- Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
+ mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
Lvar class_init])
else
ltable table (
Llet(
- Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
+ Strict, env_init, mkappl (Lvar class_init, [Lvar table]),
Lsequence(
- Lapply (oo_prim "init_class", [Lvar table]),
+ mkappl (oo_prim "init_class", [Lvar table]),
Lprim(Pmakeblock(0, Immutable),
- [Lapply(Lvar env_init, [lambda_unit]);
+ [mkappl (Lvar env_init, [lambda_unit]);
Lvar class_init; Lvar env_init; lambda_unit]))))
and lbody_virt lenvs =
Lprim(Pmakeblock(0, Immutable),
@@ -740,7 +743,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
lam)
and def_ids cla lam =
Llet(StrictOpt, env2,
- Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
+ mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
lam)
in
let inh_paths =
@@ -754,7 +757,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
and lcache lam =
if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
Llet(Strict, cached,
- Lapply(oo_prim "lookup_tables",
+ mkappl (oo_prim "lookup_tables",
[Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
lam)
and lset cached i lam =
@@ -763,7 +766,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
let ldirect () =
ltable cla
(Llet(Strict, env_init, def_ids cla cl_init,
- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
+ Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
lset cached 0 (Lvar env_init))))
and lclass_virt () =
lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
@@ -775,14 +778,14 @@ let transl_class ids cl_id arity pub_meths cl vflag =
if ids = [] then ldirect () else
if not concrete then lclass_virt () else
lclass (
- Lapply (oo_prim "make_class_store",
+ mkappl (oo_prim "make_class_store",
[transl_meth_list pub_meths;
Lvar class_init; Lvar cached]))),
make_envs (
- if ids = [] then Lapply(lfield cached 0, [lenvs]) else
+ if ids = [] then mkappl (lfield cached 0, [lenvs]) else
Lprim(Pmakeblock(0, Immutable),
if concrete then
- [Lapply(lfield cached 0, [lenvs]);
+ [mkappl (lfield cached 0, [lenvs]);
lfield cached 1;
lfield cached 0;
lenvs]
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index be60ef5bb..4ab167c84 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -569,7 +569,10 @@ and transl_exp0 e =
&& List.for_all (fun (arg,_) -> arg <> None) args ->
let args, args' = cut p.prim_arity args in
let wrap f =
- event_after e (if args' = [] then f else transl_apply f args') in
+ if args' = []
+ then event_after e f
+ else event_after e (transl_apply f args' e.exp_loc)
+ in
let wrap0 f =
if args' = [] then f else wrap f in
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
@@ -594,7 +597,7 @@ and transl_exp0 e =
if primitive_is_ccall prim then wrap p else wrap0 p
end
| Texp_apply(funct, oargs) ->
- event_after e (transl_apply (transl_exp funct) oargs)
+ event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
| Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
Matching.for_multiple_match e.exp_loc
(transl_list argl) (transl_cases pat_expr_list) partial
@@ -705,7 +708,7 @@ and transl_exp0 e =
in
event_after e lam
| Texp_new (cl, _) ->
- Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
+ Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
| Texp_instvar(path_self, path) ->
Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
| Texp_setinstvar(path_self, path, expr) ->
@@ -713,7 +716,8 @@ and transl_exp0 e =
| Texp_override(path_self, modifs) ->
let cpy = Ident.create "copy" in
Llet(Strict, cpy,
- Lapply(Translobj.oo_prim "copy", [transl_path path_self]),
+ Lapply(Translobj.oo_prim "copy", [transl_path path_self],
+ Location.none),
List.fold_right
(fun (path, expr) rem ->
Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
@@ -748,17 +752,17 @@ and transl_cases pat_expr_list =
and transl_tupled_cases patl_expr_list =
List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
-and transl_apply lam sargs =
+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)
- | Lapply(lexp, largs) ->
- Lapply(lexp, largs @ args)
+ | Lapply(lexp, largs, _) ->
+ Lapply(lexp, largs @ args, loc)
| lexp ->
- Lapply(lexp, args)
+ Lapply(lexp, args, loc)
in
let rec build_apply lam args = function
(None, optional) :: l ->
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 8148f9b8a..baac05567 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -23,7 +23,8 @@ open Lambda
val name_pattern: string -> (pattern * 'a) list -> Ident.t
val transl_exp: expression -> lambda
-val transl_apply: lambda -> (expression option * optional) list -> lambda
+val transl_apply: lambda -> (expression option * optional) list
+ -> Location.t -> lambda
val transl_let:
rec_flag -> (pattern * expression) list -> lambda -> lambda
val transl_primitive: Primitive.description -> lambda
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 4e52eb71a..00d08e475 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -47,7 +47,8 @@ let rec apply_coercion restr arg =
name_lambda arg (fun id ->
Lfunction(Curried, [param],
apply_coercion cc_res
- (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)]))))
+ (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
+ Location.none))))
| Tcoerce_primitive p ->
transl_primitive p
@@ -202,7 +203,7 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
bind_inits rem
| (id, Some(loc, shape), rhs) :: rem ->
- Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]),
+ Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none),
bind_inits rem)
and bind_strict = function
[] ->
@@ -217,7 +218,8 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
patch_forwards rem
| (id, Some(loc, shape), rhs) :: rem ->
- Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]),
+ Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs],
+ Location.none),
patch_forwards rem)
in
bind_inits bindings
@@ -258,7 +260,7 @@ let rec transl_module cc rootpath mexp =
oo_wrap mexp.mod_env true
(apply_coercion cc)
(Lapply(transl_module Tcoerce_none None funct,
- [transl_module ccarg None arg]))
+ [transl_module ccarg None arg], mexp.mod_loc))
| Tmod_constraint(arg, mty, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
@@ -556,12 +558,14 @@ let toplevel_name id =
let toploop_getvalue id =
Lapply(Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
- [Lconst(Const_base(Const_string (toplevel_name id)))])
+ [Lconst(Const_base(Const_string (toplevel_name id)))],
+ Location.none)
let toploop_setvalue id lam =
Lapply(Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
- [Lconst(Const_base(Const_string (toplevel_name id))); lam])
+ [Lconst(Const_base(Const_string (toplevel_name id))); lam],
+ Location.none)
let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-24 19:50:06 +0000