Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #169 from nojb/lapply-record 

Turn Lapply case of Lambda.lambda into a record
master
Gabriel Scherer 2015-11-23 06:58:57 +01:00
parent abf21032f8 aaed35bf87
commit 6a91a85132
11 changed files with 174 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
asmcomp/closure.ml
View File

@ -119,7 +119,13 @@ let split_default_wrapper fun_id kind params body attr =
let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in
let map_param p = try List.assoc p map with Not_found -> p in
let args = List.map (fun p -> Lvar (map_param p)) params in
let wrapper_body = Lapply (Lvar inner_id, args, no_apply_info) in
let wrapper_body =
Lapply {ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Lvar inner_id;
ap_args=args;
ap_inlined=Default_inline}
in
let inner_params = List.map map_param params in
let new_ids = List.map Ident.rename inner_params in
@ -859,7 +865,7 @@ let rec close fenv cenv = function
(* We convert [f a] to [let a' = a in fun b c -> f a' b c]
when fun_arity > nargs *)
| Lapply(funct, args, {apply_loc=loc; apply_inlined=attribute}) ->
| Lapply{ap_func = funct; ap_args = args; ap_loc = loc; ap_inlined = attribute} ->
let nargs = List.length args in
begin match (close fenv cenv funct, close_list fenv cenv args) with
((ufunct, Value_closure(fundesc, approx_res)),
@ -894,7 +900,11 @@ let rec close fenv cenv = function
(Lfunction{
kind = Curried;
params = final_args;
body = Lapply(funct, internal_args, mk_apply_info loc);
body = Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=funct;
ap_args=internal_args;
ap_inlined=Default_inline};
attr = default_function_attribute})
in
let new_fun = iter first_args new_fun in
@ -964,7 +974,11 @@ let rec close fenv cenv = function
end
| Lprim(Pdirapply loc,[funct;arg])
| Lprim(Prevapply loc,[arg;funct]) ->
close fenv cenv (Lapply(funct, [arg], mk_apply_info loc))
close fenv cenv (Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=funct;
ap_args=[arg];
ap_inlined=Default_inline})
| Lprim(Pgetglobal id, []) as lam ->
check_constant_result lam
(getglobal id)

10
bytecomp/bytegen.ml
View File

@ -453,7 +453,7 @@ let rec comp_expr env exp sz cont =
end
| Lconst cst ->
Kconst cst :: cont
| Lapply(func, args, info) ->
| Lapply{ap_func = func; ap_args = args} ->
let nargs = List.length args in
if is_tailcall cont then begin
comp_args env args sz
@ -577,7 +577,11 @@ let rec comp_expr env exp sz cont =
comp_expr env arg sz (add_const_unit cont)
| Lprim(Pdirapply loc, [func;arg])
| Lprim(Prevapply loc, [arg;func]) ->
let exp = Lapply(func, [arg], mk_apply_info loc) in
let exp = Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=func;
ap_args=[arg];
ap_inlined=Default_inline} in
comp_expr env exp sz cont
| Lprim(Pnot, [arg]) ->
let newcont =
@ -820,7 +824,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{ap_args = args} -> Event_return (List.length args)
| Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
| _ -> Event_other
in

38
bytecomp/lambda.ml
View File

@ -166,22 +166,6 @@ type inline_attribute =
| Never_inline (* [@inline never] *)
| Default_inline (* no [@inline] attribute *)
type apply_info = {
apply_loc : Location.t;
apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
apply_inlined : inline_attribute; (* specified with [@inlined] attribute *)
}
let mk_apply_info ?(tailcall=false) ?(inlined_attribute=Default_inline) loc =
{apply_loc=loc;
apply_should_be_tailcall=tailcall;
apply_inlined=inlined_attribute;}
let no_apply_info =
{apply_loc=Location.none;
apply_should_be_tailcall=false;
apply_inlined=Default_inline;}
type function_kind = Curried | Tupled
type let_kind = Strict | Alias | StrictOpt | Variable
@ -197,7 +181,7 @@ type function_attribute = {
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list * apply_info
| Lapply of lambda_apply
| Lfunction of lfunction
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
@ -222,6 +206,13 @@ and lfunction =
body: lambda;
attr: function_attribute; } (* specified with [@inline] attribute *)
and lambda_apply =
{ ap_func : lambda;
ap_args : lambda list;
ap_loc : Location.t;
ap_should_be_tailcall : bool;
ap_inlined : inline_attribute }
and lambda_switch =
{ sw_numconsts: int;
sw_consts: (int * lambda) list;
@ -275,8 +266,10 @@ let make_key e =
(* Mutable constants are not shared *)
raise Not_simple
| Lconst _ -> e
| Lapply (e,es,info) ->
Lapply (tr_rec env e,tr_recs env es,{info with apply_loc=Location.none})
| Lapply ap ->
Lapply {ap with ap_func = tr_rec env ap.ap_func;
ap_args = tr_recs env ap.ap_args;
ap_loc = Location.none}
| Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *)
let ex = tr_rec env ex in
tr_rec (Ident.add x ex env) e
@ -357,7 +350,7 @@ let iter_opt f = function
let iter f = function
Lvar _
| Lconst _ -> ()
| Lapply(fn, args, _) ->
| Lapply{ap_func = fn; ap_args = args} ->
f fn; List.iter f args
| Lfunction{kind; params; body} ->
f body
@ -504,9 +497,10 @@ 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, loc) -> Lapply(subst fn, List.map subst args, loc)
| Lapply ap ->
Lapply{ap with ap_func = subst ap.ap_func; ap_args = List.map subst ap.ap_args}
| Lfunction{kind; params; body; attr} ->
Lfunction{kind; params; body = subst body; attr}
Lfunction{kind; params; body = subst body; attr}
| Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
| Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
| Lprim(p, args) -> Lprim(p, List.map subst args)

27
bytecomp/lambda.mli
View File

@ -166,24 +166,6 @@ type inline_attribute =
| Never_inline (* [@inline never] *)
| Default_inline (* no [@inline] attribute *)
type apply_info = {
apply_loc : Location.t;
apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
apply_inlined : inline_attribute; (* specified with [@inlined] attribute *)
}
val no_apply_info : apply_info
(** Default [apply_info]: no location, no tailcall *)
val mk_apply_info : ?tailcall:bool -> ?inlined_attribute:inline_attribute ->
Location.t -> apply_info
(** Build apply_info
@param tailcall if true, the application should be in tail position;
default false
@param inlined_attribute specify wether the function should be inlined
or not
*)
type function_kind = Curried | Tupled
type let_kind = Strict | Alias | StrictOpt | Variable
@ -208,7 +190,7 @@ type function_attribute = {
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list * apply_info
| Lapply of lambda_apply
| Lfunction of lfunction
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
@ -235,6 +217,13 @@ and lfunction =
body: lambda;
attr: function_attribute; } (* specified with [@inline] attribute *)
and lambda_apply =
{ ap_func : lambda;
ap_args : lambda list;
ap_loc : Location.t;
ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
ap_inlined : inline_attribute } (* specified with the [@inline] attribute *)
and lambda_switch =
{ sw_numconsts: int; (* Number of integer cases *)
sw_consts: (int * lambda) list; (* Integer cases *)

12
bytecomp/matching.ml
View File

@ -1517,7 +1517,11 @@ let inline_lazy_force_cond arg loc =
(* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
Lprim(Pintcomp Ceq,
[Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]),
Lapply(force_fun, [varg], mk_apply_info loc),
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=force_fun;
ap_args=[varg];
ap_inlined=Default_inline},
(* ... arg *)
varg))))
@ -1535,7 +1539,11 @@ let inline_lazy_force_switch arg loc =
sw_blocks =
[ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
(Obj.lazy_tag,
Lapply(force_fun, [varg], mk_apply_info loc)) ];
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=force_fun;
ap_args=[varg];
ap_inlined=Default_inline}) ];
sw_failaction = Some varg } ))))
let inline_lazy_force arg loc =

8
bytecomp/printlambda.ml
View File

@ -266,12 +266,12 @@ let rec lam ppf = function
Ident.print ppf id
| Lconst cst ->
struct_const ppf cst
| Lapply(lfun, largs, info) ->
| Lapply ap ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a%a%a)@]" lam lfun lams largs
apply_tailcall_attribute info.apply_should_be_tailcall
apply_inlined_attribute info.apply_inlined
fprintf ppf "@[<2>(apply@ %a%a%a%a)@]" lam ap.ap_func lams ap.ap_args
apply_tailcall_attribute ap.ap_should_be_tailcall
apply_inlined_attribute ap.ap_inlined
| Lfunction{kind; params; body; attr} ->
let pr_params ppf params =
match kind with

63
bytecomp/simplif.ml
View File

@ -24,8 +24,9 @@ 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, info) ->
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, info)
| Lapply ap ->
Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
ap_args = List.map (eliminate_ref id) ap.ap_args}
| Lfunction{kind; params; body} as lam ->
if IdentSet.mem id (free_variables lam)
then raise Real_reference
@ -106,7 +107,7 @@ let simplify_exits lam =
let rec count = function
| (Lvar _| Lconst _) -> ()
| Lapply(l1, ll, _) -> count l1; List.iter count ll
| Lapply ap -> count ap.ap_func; List.iter count ap.ap_args
| Lfunction{kind; params; body = l} -> count l
| Llet(str, v, l1, l2) ->
count l2; count l1
@ -193,9 +194,11 @@ let simplify_exits lam =
let rec simplif = function
| (Lvar _|Lconst _) as l -> l
| Lapply(l1, ll, info) -> Lapply(simplif l1, List.map simplif ll, info)
| Lapply ap ->
Lapply{ap with ap_func = simplif ap.ap_func;
ap_args = List.map simplif ap.ap_args}
| Lfunction{kind; params; body = l; attr} ->
Lfunction{kind; params; body = simplif l; attr}
Lfunction{kind; params; body = simplif l; attr}
| Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
| Lletrec(bindings, body) ->
Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
@ -203,16 +206,24 @@ let simplify_exits lam =
let ll = List.map simplif ll in
match p, ll with
(* Simplify %revapply, for n-ary functions with n > 1 *)
| Prevapply loc, [x; Lapply(f, args, info)]
| Prevapply loc, [x; Levent (Lapply(f, args, info),_)] ->
Lapply(f, args@[x], {info with apply_loc=loc})
| Prevapply loc, [x; f] -> Lapply(f, [x], mk_apply_info loc)
| Prevapply loc, [x; Lapply ap]
| Prevapply loc, [x; Levent (Lapply ap,_)] ->
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
| Prevapply loc, [x; f] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline}
(* Simplify %apply, for n-ary functions with n > 1 *)
| Pdirapply loc, [Lapply(f, args, info); x]
| Pdirapply loc, [Levent (Lapply(f, args, info),_); x] ->
Lapply(f, args@[x], {info with apply_loc=loc})
| Pdirapply loc, [f; x] -> Lapply(f, [x], mk_apply_info loc)
| Pdirapply loc, [Lapply ap; x]
| Pdirapply loc, [Levent (Lapply ap,_); x] ->
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
| Pdirapply loc, [f; x] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline}
| _ -> Lprim(p, ll)
end
@ -339,14 +350,13 @@ let simplify_lets lam =
| Lconst cst -> ()
| Lvar v ->
use_var bv v 1
| Lapply(Lfunction{kind = Curried; params; body}, args, _)
| Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
when optimize && List.length params = List.length args ->
count bv (beta_reduce params body args)
| Lapply(Lfunction{kind = Tupled; params; body},
[Lprim(Pmakeblock _, args)], _)
| Lapply{ap_func = Lfunction{kind = Tupled; params; body}; ap_args = [Lprim(Pmakeblock _, args)]}
when optimize && List.length params = List.length args ->
count bv (beta_reduce params body args)
| Lapply(l1, ll, _) ->
| Lapply{ap_func = l1; ap_args = ll} ->
count bv l1; List.iter (count bv) ll
| Lfunction{kind; params; body = l} ->
count Tbl.empty l
@ -432,14 +442,13 @@ let simplify_lets lam =
l
end
| Lconst cst as l -> l
| Lapply(Lfunction{kind = Curried; params; body}, args, _)
| Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
when optimize && List.length params = List.length args ->
simplif (beta_reduce params body args)
| Lapply(Lfunction{kind = Tupled; params; body},
[Lprim(Pmakeblock _, args)], _)
| Lapply{ap_func = Lfunction{kind = Tupled; params; body}; ap_args = [Lprim(Pmakeblock _, args)]}
when optimize && List.length params = List.length args ->
simplif (beta_reduce params body args)
| Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
| Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; ap_args = List.map simplif ap.ap_args}
| Lfunction{kind; params; body = l; attr} ->
begin match simplif l with
Lfunction{kind=Curried; params=params'; body; attr}
@ -526,15 +535,15 @@ let rec emit_tail_infos is_tail lambda =
match lambda with
| Lvar _ -> ()
| Lconst _ -> ()
| Lapply (func, l, ({apply_loc=loc} as info)) ->
if info.apply_should_be_tailcall
| Lapply ap ->
if ap.ap_should_be_tailcall
&& not is_tail
&& Warnings.is_active Warnings.Expect_tailcall
then Location.prerr_warning loc Warnings.Expect_tailcall;
emit_tail_infos false func;
list_emit_tail_infos false l;
then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall;
emit_tail_infos false ap.ap_func;
list_emit_tail_infos false ap.ap_args;
if !Clflags.annotations then
Stypes.record (Stypes.An_call (loc, call_kind l));
Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args))
| Lfunction {body = lam} ->
emit_tail_infos true lam
| Llet (_, _, lam, body) ->

31
bytecomp/translclass.ml
View File

@ -31,14 +31,19 @@ let lfunction params body =
| _ ->
Lfunction {kind = Curried; params; body; attr = default_function_attribute}
let lapply func args loc =
match func with
Lapply(func', args', _) ->
Lapply(func', args' @ args, loc)
let lapply ap =
match ap.ap_func with
Lapply ap' ->
Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args}
| _ ->
Lapply(func, args, loc)
Lapply ap
let mkappl (func, args) = Lapply (func, args, no_apply_info);;
let mkappl (func, args) =
Lapply {ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=func;
ap_args=args;
ap_inlined=Default_inline};;
let lsequence l1 l2 =
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
@ -442,7 +447,13 @@ 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] no_apply_info in
let obj_init0 =
lapply {ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Lvar obj_init;
ap_args=[Lvar self];
ap_inlined=Default_inline}
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));
@ -504,12 +515,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{ap_func = f; ap_args = [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{ap_func = f; ap_args = [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{ap_func = f; ap_args = [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 ->

37
bytecomp/translcore.ml
View File

@ -729,11 +729,11 @@ and transl_exp0 e =
let should_be_tailcall, funct =
Translattribute.get_tailcall_attribute funct
in
let inlined_attribute, funct =
let inlined, funct =
Translattribute.get_inlined_attribute funct
in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after e (transl_apply ~should_be_tailcall ~inlined_attribute
event_after e (transl_apply ~should_be_tailcall ~inlined
f args' e.exp_loc)
in
let wrap0 f =
@ -785,11 +785,11 @@ and transl_exp0 e =
let should_be_tailcall, funct =
Translattribute.get_tailcall_attribute funct
in
let inlined_attribute, funct =
let inlined, funct =
Translattribute.get_inlined_attribute funct
in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after e (transl_apply ~should_be_tailcall ~inlined_attribute
event_after e (transl_apply ~should_be_tailcall ~inlined
(transl_exp funct) oargs e.exp_loc)
| Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) ->
transl_match e arg pat_expr_list exn_pat_expr_list partial
@ -907,8 +907,11 @@ and transl_exp0 e =
in
event_after e lam
| Texp_new (cl, {Location.loc=loc}, _) ->
Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]),
[lambda_unit], no_apply_info)
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]);
ap_args=[lambda_unit];
ap_inlined=Default_inline}
| Texp_instvar(path_self, path, _) ->
Lprim(Parrayrefu Paddrarray,
[transl_normal_path path_self; transl_normal_path path])
@ -917,8 +920,11 @@ and transl_exp0 e =
| Texp_override(path_self, modifs) ->
let cpy = Ident.create "copy" in
Llet(Strict, cpy,
Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self],
no_apply_info),
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Translobj.oo_prim "copy";
ap_args=[transl_normal_path path_self];
ap_inlined=Default_inline},
List.fold_right
(fun (path, _, expr) rem ->
Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
@ -1039,18 +1045,21 @@ and transl_tupled_cases patl_expr_list =
List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
patl_expr_list
and transl_apply ?(should_be_tailcall=false) ?inlined_attribute lam sargs loc =
and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) lam sargs loc =
let lapply funct args =
match funct with
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, info) ->
Lapply(lexp, largs @ args, {info with apply_loc=loc})
| Lapply ap ->
Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc}
| lexp ->
Lapply(lexp, args, mk_apply_info ~tailcall:should_be_tailcall
?inlined_attribute loc)
Lapply {ap_should_be_tailcall=should_be_tailcall;
ap_loc=loc;
ap_func=lexp;
ap_args=args;
ap_inlined=inlined}
in
let rec build_apply lam args = function
(None, optional) :: l ->
@ -1090,7 +1099,7 @@ and transl_apply ?(should_be_tailcall=false) ?inlined_attribute lam sargs loc =
| [] ->
lapply lam (List.rev_map fst args)
in
build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs)
(build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs) : Lambda.lambda)
and transl_function loc untuplify_fn repr partial cases =
match cases with

2
bytecomp/translcore.mli
View File

@ -19,7 +19,7 @@ open Lambda
val transl_exp: expression -> lambda
val transl_apply: ?should_be_tailcall:bool
-> ?inlined_attribute:inline_attribute
-> ?inlined:inline_attribute
-> lambda -> (arg_label * expression option * optional) list
-> Location.t -> lambda
val transl_let: rec_flag -> value_binding list -> lambda -> lambda

46
bytecomp/translmod.ml
View File

@ -93,9 +93,11 @@ let rec apply_coercion strict restr arg =
attr = default_function_attribute;
body = apply_coercion
Strict cc_res
(Lapply(Lvar id,
[apply_coercion Alias cc_arg (Lvar param)],
no_apply_info))})
(Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Lvar id;
ap_args=[apply_coercion Alias cc_arg (Lvar param)];
ap_inlined=Default_inline})})
| Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
transl_primitive pc_loc pc_desc pc_env pc_type None
| Tcoerce_alias (path, cc) ->
@ -280,7 +282,11 @@ let eval_rec_bindings bindings cont =
bind_inits rem
| (id, Some(loc, shape), rhs) :: rem ->
Llet(Strict, id,
Lapply(mod_prim "init_mod", [loc; shape], no_apply_info),
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=mod_prim "init_mod";
ap_args=[loc; shape];
ap_inlined=Default_inline},
bind_inits rem)
and bind_strict = function
[] ->
@ -295,8 +301,11 @@ 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],
no_apply_info),
Lsequence(Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=mod_prim "update_mod";
ap_args=[shape; Lvar id; rhs];
ap_inlined=Default_inline},
patch_forwards rem)
in
bind_inits bindings
@ -368,8 +377,11 @@ let rec transl_module cc rootpath mexp =
| Tmod_apply(funct, arg, ccarg) ->
oo_wrap mexp.mod_env true
(apply_coercion Strict cc)
(Lapply(transl_module Tcoerce_none None funct,
[transl_module ccarg None arg], mk_apply_info mexp.mod_loc))
(Lapply{ap_should_be_tailcall=false;
ap_loc=mexp.mod_loc;
ap_func=transl_module Tcoerce_none None funct;
ap_args=[transl_module ccarg None arg];
ap_inlined=Default_inline})
| Tmod_constraint(arg, mty, _, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
@ -833,16 +845,18 @@ let toplevel_name id =
with Not_found -> Ident.name id
let toploop_getvalue id =
Lapply(Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
[Lconst(Const_base(Const_string (toplevel_name id, None)))],
no_apply_info)
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Lprim(Pfield toploop_getvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]);
ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))];
ap_inlined=Default_inline}
let toploop_setvalue id lam =
Lapply(Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
[Lconst(Const_base(Const_string (toplevel_name id, None))); lam],
no_apply_info)
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=Lprim(Pfield toploop_setvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]);
ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); lam];
ap_inlined=Default_inline}
let toploop_setvalue_id id = toploop_setvalue id (Lvar id)