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

[refactoring] gives tailcall attributes a more standard structure 

We want to start allowing more information in the payload of
[@tailcall] attributes (currently no payload is supported), for
example we could consider using [@tailcall false] to ask the code
generator to disable a tail call.

A first required step in this direction is to use a custom datatype to
represent the tail-call attribute, instead of a boolean. This is
consistent with the other application-site
attributes (inline_attribute, specialise_attribute, local_attribute),
so it makes the code more regular -- but the change itself is
boilerplate-y.
master
Gabriel Scherer 2020-04-12 15:28:13 +02:00
parent 792deb120f
commit d260a79416
15 changed files with 230 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Changes
View File

@ -138,6 +138,10 @@ Working version
- #9514: optimize pattern-matching exhaustivity analysis in the single-row case
(Gabriel Scherer, review by Stephen DOlan)
- #9442: refactor the implementation of the [@tailcall] attribute
to allow for a structured attribute payload
(Gabriel Scherer, review by Vladimir Keleshev and Nicolás Ojeda Bär)
### Build system:
- #9332, #9518, #9529: Cease storing C dependencies in the codebase. C

14
bytecomp/bytegen.ml
View File

@ -676,12 +676,14 @@ let rec comp_expr env exp sz cont =
comp_expr env arg sz (add_const_unit cont)
| Lprim(Pdirapply, [func;arg], loc)
| Lprim(Prevapply, [arg;func], loc) ->
let exp = Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=func;
ap_args=[arg];
ap_inlined=Default_inline;
ap_specialised=Default_specialise} in
let exp = Lapply{
ap_loc=loc;
ap_func=func;
ap_args=[arg];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
} in
comp_expr env exp sz cont
| Lprim(Pnot, [arg], _) ->
let newcont =

10
lambda/lambda.ml
View File

@ -211,6 +211,10 @@ type structured_constant =
| Const_float_array of string list
| Const_immstring of string
type tailcall_attribute =
| Should_be_tailcall (* [@tailcall] *)
| Default_tailcall (* no [@tailcall] attribute *)
type inline_attribute =
| Always_inline (* [@inline] or [@inline always] *)
| Never_inline (* [@inline never] *)
@ -311,7 +315,7 @@ and lambda_apply =
{ ap_func : lambda;
ap_args : lambda list;
ap_loc : scoped_location;
ap_should_be_tailcall : bool;
ap_tailcall : tailcall_attribute;
ap_inlined : inline_attribute;
ap_specialised : specialise_attribute; }
@ -765,13 +769,13 @@ let rename idmap lam =
let shallow_map f = function
| Lvar _
| Lconst _ as lam -> lam
| Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall;
| Lapply { ap_func; ap_args; ap_loc; ap_tailcall;
ap_inlined; ap_specialised } ->
Lapply {
ap_func = f ap_func;
ap_args = List.map f ap_args;
ap_loc;
ap_should_be_tailcall;
ap_tailcall;
ap_inlined;
ap_specialised;
}

6
lambda/lambda.mli
View File

@ -202,6 +202,10 @@ type structured_constant =
| Const_float_array of string list
| Const_immstring of string
type tailcall_attribute =
| Should_be_tailcall (* [@tailcall] *)
| Default_tailcall (* no [@tailcall] attribute *)
type inline_attribute =
| Always_inline (* [@inline] or [@inline always] *)
| Never_inline (* [@inline never] *)
@ -295,7 +299,7 @@ and lambda_apply =
{ ap_func : lambda;
ap_args : lambda list;
ap_loc : scoped_location;
ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *)
ap_tailcall : tailcall_attribute;
ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *)
ap_specialised : specialise_attribute; }

6
lambda/matching.ml
View File

@ -1835,7 +1835,7 @@ let inline_lazy_force_cond arg loc =
[ tag_var; Lconst (Const_base (Const_int Obj.lazy_tag)) ],
loc ),
Lapply
{ ap_should_be_tailcall = false;
{ ap_tailcall = Default_tailcall;
ap_loc = loc;
ap_func = force_fun;
ap_args = [ varg ];
@ -1867,7 +1867,7 @@ let inline_lazy_force_switch arg loc =
[ (Obj.forward_tag, Lprim (Pfield 0, [ varg ], loc));
( Obj.lazy_tag,
Lapply
{ ap_should_be_tailcall = false;
{ ap_tailcall = Default_tailcall;
ap_loc = loc;
ap_func = force_fun;
ap_args = [ varg ];
@ -1886,7 +1886,7 @@ let inline_lazy_force arg loc =
instrumentation output.
(see https://github.com/stedolan/crowbar/issues/14) *)
Lapply
{ ap_should_be_tailcall = false;
{ ap_tailcall = Default_tailcall;
ap_loc = loc;
ap_func = Lazy.force code_force_lazy;
ap_args = [ arg ];

7
lambda/printlambda.ml
View File

@ -473,8 +473,9 @@ let function_attribute ppf { inline; specialise; local; is_a_functor; stub } =
| Never_local -> fprintf ppf "never_local@ "
end
let apply_tailcall_attribute ppf tailcall =
if tailcall then
let apply_tailcall_attribute ppf = function
| Default_tailcall -> ()
| Should_be_tailcall ->
fprintf ppf " tailcall"
let apply_inlined_attribute ppf = function
@ -498,7 +499,7 @@ let rec lam ppf = function
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args
apply_tailcall_attribute ap.ap_should_be_tailcall
apply_tailcall_attribute ap.ap_tailcall
apply_inlined_attribute ap.ap_inlined
apply_specialised_attribute ap.ap_specialised
| Lfunction{kind; params; return; body; attr} ->

50
lambda/simplif.ml
View File

@ -219,23 +219,28 @@ let simplify_exits lam =
| Prevapply, [x; Lapply ap]
| Prevapply, [x; Levent (Lapply ap,_)] ->
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
| Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| Prevapply, [x; f] ->
Lapply {
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
}
(* Simplify %apply, for n-ary functions with n > 1 *)
| Pdirapply, [Lapply ap; x]
| Pdirapply, [Levent (Lapply ap,_); x] ->
Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
| Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
| Pdirapply, [f; x] ->
Lapply {
ap_loc=loc;
ap_func=f;
ap_args=[x];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
}
(* Simplify %identity *)
| Pidentity, [e] -> e
@ -606,11 +611,18 @@ let rec emit_tail_infos is_tail lambda =
| Lvar _ -> ()
| Lconst _ -> ()
| Lapply ap ->
if ap.ap_should_be_tailcall
&& not is_tail
&& Warnings.is_active Warnings.Expect_tailcall
then Location.prerr_warning (to_location ap.ap_loc)
Warnings.Expect_tailcall;
begin match ap.ap_tailcall with
| Default_tailcall -> ()
| Should_be_tailcall ->
(* Note: we may want to instead check the call_kind,
which takes [is_tail_native_heuristic] into accout.
But then this means getting different warnings depending
on whether the native or bytecode compiler is used. *)
if not is_tail
&& Warnings.is_active Warnings.Expect_tailcall
then Location.prerr_warning (to_location ap.ap_loc)
Warnings.Expect_tailcall;
end;
emit_tail_infos false ap.ap_func;
list_emit_tail_infos false ap.ap_args
| Lfunction {body = lam} ->
@ -710,7 +722,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
ap_func = Lvar inner_id;
ap_args = args;
ap_loc = Loc_unknown;
ap_should_be_tailcall = false;
ap_tailcall = Default_tailcall;
ap_inlined = Default_inline;
ap_specialised = Default_specialise;
}

31
lambda/translattribute.ml
View File

@ -274,18 +274,29 @@ let get_tailcall_attribute e =
| {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true
| _ -> false
in
let tailcalls, exp_attributes =
let tailcalls, other_attributes =
List.partition is_tailcall_attribute e.exp_attributes
in
match tailcalls with
| [] -> false, e
| _ :: r ->
begin match r with
| [] -> ()
| {Parsetree.attr_name = {txt;loc}; _} :: _ ->
Location.prerr_warning loc (Warnings.Duplicated_attribute txt)
end;
true, { e with exp_attributes }
let tailcall_attribute = match tailcalls with
| [] -> Default_tailcall
| {Parsetree.attr_name = {txt; loc}; attr_payload = payload} :: r ->
begin match r with
| [] -> ()
| {Parsetree.attr_name = {txt;loc}; _} :: _ ->
Location.prerr_warning loc (Warnings.Duplicated_attribute txt)
end;
let payload_result : (_, _) result = match payload with
| PStr [] -> Ok Should_be_tailcall
| _ -> Error ()
in
match payload_result with
| Ok tailcall_attribute -> tailcall_attribute
| Error () ->
let msg = "No payload is currently supported." in
Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg));
Default_tailcall
in
tailcall_attribute, { e with exp_attributes = other_attributes }
let check_attribute e {Parsetree.attr_name = { txt; loc }; _} =
match txt with

2
lambda/translattribute.mli
View File

@ -67,7 +67,7 @@ val get_and_remove_specialised_attribute
val get_tailcall_attribute
: Typedtree.expression
-> bool * Typedtree.expression
-> Lambda.tailcall_attribute * Typedtree.expression
val add_function_attributes
: Lambda.lambda

28
lambda/translclass.ml
View File

@ -50,12 +50,14 @@ let lapply ap =
Lapply ap
let mkappl (func, args) =
Lapply {ap_should_be_tailcall=false;
ap_loc=Loc_unknown;
ap_func=func;
ap_args=args;
ap_inlined=Default_inline;
ap_specialised=Default_specialise};;
Lapply {
ap_loc=Loc_unknown;
ap_func=func;
ap_args=args;
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
};;
let lsequence l1 l2 =
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
@ -488,12 +490,14 @@ let transl_class_rebind ~scopes cl vf =
let obj_init = Ident.create_local "obj_init"
and self = Ident.create_local "self" in
let obj_init0 =
lapply {ap_should_be_tailcall=false;
ap_loc=Loc_unknown;
ap_func=Lvar obj_init;
ap_args=[Lvar self];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
lapply {
ap_loc=Loc_unknown;
ap_func=Lvar obj_init;
ap_args=[Lvar self];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
}
in
let _, path_lam, obj_init' =
transl_class_rebind_0 ~scopes self obj_init0 cl vf in

88
lambda/translcore.ml
View File

@ -259,7 +259,7 @@ and transl_exp0 ~scopes e =
in
if extra_args = [] then lam
else begin
let should_be_tailcall, funct =
let tailcall, funct =
Translattribute.get_tailcall_attribute funct
in
let inlined, funct =
@ -270,11 +270,11 @@ and transl_exp0 ~scopes e =
in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after ~scopes e
(transl_apply ~scopes ~should_be_tailcall ~inlined ~specialised
(transl_apply ~scopes ~tailcall ~inlined ~specialised
lam extra_args (of_location ~scopes e.exp_loc))
end
| Texp_apply(funct, oargs) ->
let should_be_tailcall, funct =
let tailcall, funct =
Translattribute.get_tailcall_attribute funct
in
let inlined, funct =
@ -285,7 +285,7 @@ and transl_exp0 ~scopes e =
in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after ~scopes e
(transl_apply ~scopes ~should_be_tailcall ~inlined ~specialised
(transl_apply ~scopes ~tailcall ~inlined ~specialised
(transl_exp ~scopes funct) oargs (of_location ~scopes e.exp_loc))
| Texp_match(arg, pat_expr_list, partial) ->
transl_match ~scopes e arg pat_expr_list partial
@ -454,13 +454,15 @@ and transl_exp0 ~scopes e =
event_after ~scopes e lam
| Texp_new (cl, {Location.loc=loc}, _) ->
let loc = of_location ~scopes loc in
Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=
Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc);
ap_args=[lambda_unit];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
Lapply{
ap_loc=loc;
ap_func=
Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc);
ap_args=[lambda_unit];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
}
| Texp_instvar(path_self, path, _) ->
let loc = of_location ~scopes e.exp_loc in
let self = transl_value_path loc e.exp_env path_self in
@ -476,12 +478,14 @@ and transl_exp0 ~scopes e =
let self = transl_value_path loc e.exp_env path_self in
let cpy = Ident.create_local "copy" in
Llet(Strict, Pgenval, cpy,
Lapply{ap_should_be_tailcall=false;
ap_loc=Loc_unknown;
ap_func=Translobj.oo_prim "copy";
ap_args=[self];
ap_inlined=Default_inline;
ap_specialised=Default_specialise},
Lapply{
ap_loc=Loc_unknown;
ap_func=Translobj.oo_prim "copy";
ap_args=[self];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
},
List.fold_right
(fun (path, _, expr) rem ->
let var = transl_value_path loc e.exp_env path in
@ -648,8 +652,12 @@ and transl_tupled_cases ~scopes patl_expr_list =
List.map (fun (patl, guard, expr) -> (patl, transl_guard ~scopes guard expr))
patl_expr_list
and transl_apply ~scopes ?(should_be_tailcall=false) ?(inlined = Default_inline)
?(specialised = Default_specialise) lam sargs loc =
and transl_apply ~scopes
?(tailcall=Default_tailcall)
?(inlined = Default_inline)
?(specialised = Default_specialise)
lam sargs loc
=
let lapply funct args =
match funct with
Lsend(k, lmet, lobj, largs, _) ->
@ -659,12 +667,14 @@ and transl_apply ~scopes ?(should_be_tailcall=false) ?(inlined = Default_inline)
| Lapply ap ->
Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc}
| lexp ->
Lapply {ap_should_be_tailcall=should_be_tailcall;
ap_loc=loc;
ap_func=lexp;
ap_args=args;
ap_inlined=inlined;
ap_specialised=specialised;}
Lapply {
ap_loc=loc;
ap_func=lexp;
ap_args=args;
ap_tailcall=tailcall;
ap_inlined=inlined;
ap_specialised=specialised;
}
in
let rec build_apply lam args = function
(None, optional) :: l ->
@ -1076,12 +1086,14 @@ and transl_letop ~scopes loc env let_ ands param case partial =
let exp = transl_exp ~scopes and_.bop_exp in
let lam =
bind Strict right_id exp
(Lapply{ap_should_be_tailcall = false;
ap_loc = of_location ~scopes and_.bop_loc;
ap_func = op;
ap_args=[Lvar left_id; Lvar right_id];
ap_inlined=Default_inline;
ap_specialised=Default_specialise})
(Lapply{
ap_loc = of_location ~scopes and_.bop_loc;
ap_func = op;
ap_args=[Lvar left_id; Lvar right_id];
ap_tailcall = Default_tailcall;
ap_inlined = Default_inline;
ap_specialised = Default_specialise;
})
in
bind Strict left_id prev_lam (loop lam rest)
in
@ -1103,12 +1115,14 @@ and transl_letop ~scopes loc env let_ ands param case partial =
let loc = of_location ~scopes case.c_rhs.exp_loc in
Lfunction{kind; params; return; body; attr; loc}
in
Lapply{ap_should_be_tailcall = false;
ap_loc = of_location ~scopes loc;
ap_func = op;
ap_args=[exp; func];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
Lapply{
ap_loc = of_location ~scopes loc;
ap_func = op;
ap_args=[exp; func];
ap_tailcall = Default_tailcall;
ap_inlined = Default_inline;
ap_specialised = Default_specialise;
}
(* Wrapper for class compilation *)

2
lambda/translcore.mli
View File

@ -25,7 +25,7 @@ val pure_module : module_expr -> let_kind
val transl_exp: scopes:scopes -> expression -> lambda
val transl_apply: scopes:scopes
-> ?should_be_tailcall:bool
-> ?tailcall:tailcall_attribute
-> ?inlined:inline_attribute
-> ?specialised:specialise_attribute
-> lambda -> (arg_label * expression option) list

101
lambda/translmod.ml
View File

@ -126,12 +126,14 @@ and apply_coercion_result loc strict funct params args cc_res =
loc = loc;
body = apply_coercion
loc Strict cc_res
(Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=Lvar id;
ap_args=List.rev args;
ap_inlined=Default_inline;
ap_specialised=Default_specialise})})
(Lapply{
ap_loc=loc;
ap_func=Lvar id;
ap_args=List.rev args;
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
})})
and wrap_id_pos_list loc id_pos_list get_field lam =
let fv = free_variables lam in
@ -358,12 +360,14 @@ let eval_rec_bindings bindings cont =
bind_inits rem
| (Id id, Some(loc, shape), _rhs) :: rem ->
Llet(Strict, Pgenval, id,
Lapply{ap_should_be_tailcall=false;
ap_loc=Loc_unknown;
ap_func=mod_prim "init_mod";
ap_args=[loc; shape];
ap_inlined=Default_inline;
ap_specialised=Default_specialise},
Lapply{
ap_loc=Loc_unknown;
ap_func=mod_prim "init_mod";
ap_args=[loc; shape];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
},
bind_inits rem)
and bind_strict = function
[] ->
@ -381,13 +385,16 @@ let eval_rec_bindings bindings cont =
| (_, None, _rhs) :: rem ->
patch_forwards rem
| (Id id, Some(_loc, shape), rhs) :: rem ->
Lsequence(Lapply{ap_should_be_tailcall=false;
ap_loc=Loc_unknown;
ap_func=mod_prim "update_mod";
ap_args=[shape; Lvar id; rhs];
ap_inlined=Default_inline;
ap_specialised=Default_specialise},
patch_forwards rem)
Lsequence(
Lapply {
ap_loc=Loc_unknown;
ap_func=mod_prim "update_mod";
ap_args=[shape; Lvar id; rhs];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
},
patch_forwards rem)
in
bind_inits bindings
@ -512,12 +519,13 @@ and transl_module ~scopes cc rootpath mexp =
in
oo_wrap mexp.mod_env true
(apply_coercion loc Strict cc)
(Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=transl_module ~scopes Tcoerce_none None funct;
ap_args=[transl_module ~scopes ccarg None arg];
ap_inlined=inlined_attribute;
ap_specialised=Default_specialise})
(Lapply{
ap_loc=loc;
ap_func=transl_module ~scopes Tcoerce_none None funct;
ap_args=[transl_module ~scopes ccarg None arg];
ap_tailcall=Default_tailcall;
ap_inlined=inlined_attribute;
ap_specialised=Default_specialise})
| Tmod_constraint(arg, _, _, ccarg) ->
transl_module ~scopes (compose_coercions cc ccarg) rootpath arg
| Tmod_unpack(arg, _) ->
@ -1401,27 +1409,32 @@ let toplevel_name id =
with Not_found -> Ident.name id
let toploop_getvalue id =
Lapply{ap_should_be_tailcall=false;
ap_loc=Loc_unknown;
ap_func=Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
Loc_unknown);
ap_args=[Lconst(Const_base(
Const_string (toplevel_name id, Location.none,None)))];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
Lapply{
ap_loc=Loc_unknown;
ap_func=Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
Loc_unknown);
ap_args=[Lconst(Const_base(
Const_string (toplevel_name id, Location.none, None)))];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
}
let toploop_setvalue id lam =
Lapply{ap_should_be_tailcall=false;
ap_loc=Loc_unknown;
ap_func=Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
Loc_unknown);
ap_args=[Lconst(Const_base(
Const_string (toplevel_name id, Location.none, None)));
lam];
ap_inlined=Default_inline;
ap_specialised=Default_specialise}
Lapply{
ap_loc=Loc_unknown;
ap_func=Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
Loc_unknown);
ap_args=
[Lconst(Const_base(
Const_string(toplevel_name id, Location.none, None)));
lam];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
}
let toploop_setvalue_id id = toploop_setvalue id (Lvar id)

29
middle_end/closure/closure.ml
View File

@ -940,12 +940,14 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
kind = Curried;
return = Pgenval;
params = List.map (fun v -> v, Pgenval) final_args;
body = Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=(Lvar funct_var);
ap_args=internal_args;
ap_inlined=Default_inline;
ap_specialised=Default_specialise};
body = Lapply{
ap_loc=loc;
ap_func=(Lvar funct_var);
ap_args=internal_args;
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
};
loc;
attr = default_function_attribute})
in
@ -1066,12 +1068,15 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
close env arg
| Lprim(Pdirapply,[funct;arg], loc)
| Lprim(Prevapply,[arg;funct], loc) ->
close env (Lapply{ap_should_be_tailcall=false;
ap_loc=loc;
ap_func=funct;
ap_args=[arg];
ap_inlined=Default_inline;
ap_specialised=Default_specialise})
close env
(Lapply{
ap_loc=loc;
ap_func=funct;
ap_args=[arg];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
})
| Lprim(Pgetglobal id, [], loc) ->
let dbg = Debuginfo.from_location loc in
check_constant_result (getglobal dbg id)

8
middle_end/flambda/closure_conversion.ml
View File

@ -225,8 +225,8 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
in
Flambda.create_let set_of_closures_var set_of_closures
(name_expr (Project_closure (project_closure)) ~name)
| Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _;
ap_inlined; ap_specialised; } ->
| Lapply { ap_func; ap_args; ap_loc;
ap_tailcall = _; ap_inlined; ap_specialised; } ->
Lift_code.lifting_helper (close_list t env ap_args)
~evaluation_order:`Right_to_left
~name:Names.apply_arg
@ -418,10 +418,10 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
{ ap_func = funct;
ap_args = [arg];
ap_loc = loc;
ap_should_be_tailcall = false;
(* CR-someday lwhite: it would be nice to be able to give
inlined attributes to functions applied with the application
application attributes to functions applied with the application
operators. *)
ap_tailcall = Default_tailcall;
ap_inlined = Default_inline;
ap_specialised = Default_specialise;
}