Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Ensure that build_apply respects Lambda.max_arity #10719

Merged
merged 3 commits into from Feb 15, 2022
Merged

Ensure that build_apply respects Lambda.max_arity #10719

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
4a89198
Make Lambda.lfunction private
stedolan Oct 20, 2021
abcc899
Ensure that build_apply respects Lambda.max_arity
stedolan Oct 20, 2021
cc59327
Changes
stedolan Nov 4, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
3 changes: 3 additions & 0 deletions Changes
View file
Open in desktop
Expand Up @@ -179,6 +179,9 @@ OCaml 4.14.0
- #10681: Enforce boolean conditions for the native backend
(Vincent Laviron, review by Gabriel Scherer)

- #10719: Ensure that build_apply respects Lambda.max_arity
(Stephen Dolan, review by Xavier Leroy)

- #10728: Ensure that functions are evaluated after their arguments
(Stephen Dolan, review by Mark Shinwell)

Expand Down
14 changes: 9 additions & 5 deletions lambda/lambda.ml
View file
Open in desktop
Expand Up @@ -360,6 +360,15 @@ let const_int n = Const_base (Const_int n)

let const_unit = const_int 0

let max_arity () =
if !Clflags.native_code then 126 else max_int
(* 126 = 127 (the maximal number of parameters supported in C--)
- 1 (the hidden parameter containing the environment) *)

let lfunction ~kind ~params ~return ~body ~attr ~loc =
assert (List.length params <= max_arity ());
Lfunction { kind; params; return; body; attr; loc }

let lambda_unit = Lconst const_unit

let default_function_attribute = {
Expand Down Expand Up @@ -998,10 +1007,5 @@ let find_exact_application kind ~arity args =
| _ -> None
end

let max_arity () =
if !Clflags.native_code then 126 else max_int
(* 126 = 127 (the maximal number of parameters supported in C--)
- 1 (the hidden parameter containing the environment) *)

let reset () =
raise_count := 0
12 changes: 11 additions & 1 deletion lambda/lambda.mli
View file
Open in desktop
Expand Up @@ -305,7 +305,7 @@ type lambda =
| Levent of lambda * lambda_event
| Lifused of Ident.t * lambda

and lfunction =
and lfunction = private
{ kind: function_kind;
params: (Ident.t * value_kind) list;
return: value_kind;
Expand Down Expand Up @@ -368,6 +368,16 @@ val lambda_unit: lambda
val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda

val lfunction :
kind:function_kind ->
params:(Ident.t * value_kind) list ->
return:value_kind ->
body:lambda ->
attr:function_attribute -> (* specified with [@inline] attribute *)
loc:scoped_location ->
lambda


val iter_head_constructor: (lambda -> unit) -> lambda -> unit
(** [iter_head_constructor f lam] apply [f] to only the first level of
sub expressions of [lam]. It does not recursively traverse the
Expand Down
16 changes: 8 additions & 8 deletions lambda/simplif.ml
View file
Open in desktop
Expand Up @@ -220,7 +220,7 @@ let simplify_exits lam =
Lapply{ap with ap_func = simplif ~try_depth ap.ap_func;
ap_args = List.map (simplif ~try_depth) ap.ap_args}
| Lfunction{kind; params; return; body = l; attr; loc} ->
Lfunction{kind; params; return; body = simplif ~try_depth l; attr; loc}
lfunction ~kind ~params ~return ~body:(simplif ~try_depth l) ~attr ~loc
| Llet(str, kind, v, l1, l2) ->
Llet(str, kind, v, simplif ~try_depth l1, simplif ~try_depth l2)
| Lmutlet(kind, v, l1, l2) ->
Expand Down Expand Up @@ -520,9 +520,9 @@ let simplify_lets lam =
type of the merged function taking [params @ params'] as
parameters is the type returned after applying [params']. *)
let return = return2 in
Lfunction{kind; params = params @ params'; return; body; attr; loc}
lfunction ~kind ~params:(params @ params') ~return ~body ~attr ~loc
| body ->
Lfunction{kind; params; return = return1; body; attr; loc}
lfunction ~kind ~params ~return:return1 ~body ~attr ~loc
end
| Llet(_str, _k, v, Lvar w, l2) when optimize ->
Hashtbl.add subst v (simplif (Lvar w));
Expand Down Expand Up @@ -749,18 +749,18 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
in
let body = Lambda.rename subst body in
let inner_fun =
Lfunction { kind = Curried;
params = List.map (fun id -> id, Pgenval) new_ids;
return; body; attr; loc; }
lfunction ~kind:Curried
~params:(List.map (fun id -> id, Pgenval) new_ids)
~return ~body ~attr ~loc
in
(wrapper_body, (inner_id, inner_fun))
in
try
let body, inner = aux [] body in
let attr = default_stub_attribute in
[(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner]
[(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc); inner]
with Exit ->
[(fun_id, Lfunction{kind; params; return; body; attr; loc})]
[(fun_id, lfunction ~kind ~params ~return ~body ~attr ~loc)]

(* Simplify local let-bound functions: if all occurrences are
fully-applied function calls in the same "tail scope", replace the
Expand Down
19 changes: 12 additions & 7 deletions lambda/tmc.ml
View file
Open in desktop
Expand Up @@ -947,21 +947,26 @@ and traverse_binding outer_ctx inner_ctx (var, def) =
(Debuginfo.Scoped_location.to_location lfun.loc)
Warnings.Unused_tmc_attribute;
let direct =
Lfunction { lfun with body = Choice.direct fun_choice } in
let { kind; params; return; body = _; attr; loc } = lfun in
let body = Choice.direct fun_choice in
lfunction ~kind ~params ~return ~body ~attr ~loc in
let dps =
let dst_param = {
var = Ident.create_local "dst";
offset = Ident.create_local "offset";
loc = lfun.loc;
} in
let dst = { dst_param with offset = Offset (Lvar dst_param.offset) } in
Lambda.duplicate @@ Lfunction { lfun with
kind =
Lambda.duplicate @@ lfunction
~kind:
(* Support of Tupled function: see [choice_apply]. *)
Curried;
params = add_dst_params dst_param lfun.params;
body = Choice.dps ~tail:true ~dst:dst fun_choice;
} in
Curried
~params:(add_dst_params dst_param lfun.params)
~return:lfun.return
~body:(Choice.dps ~tail:true ~dst:dst fun_choice)
~attr:lfun.attr
~loc:lfun.loc
in
let dps_var = special.dps_id in
[(var, direct); (dps_var, dps)]

Expand Down
13 changes: 8 additions & 5 deletions lambda/translattribute.ml
View file
Open in desktop
Expand Up @@ -234,6 +234,9 @@ let check_poll_local loc attr =
| _ ->
()

let lfunction_with_attr ~attr { kind; params; return; body; attr=_; loc } =
lfunction ~kind ~params ~return ~body ~attr ~loc

let add_inline_attribute expr loc attributes =
match expr, get_inline_attribute attributes with
| expr, Default_inline -> expr
Expand All @@ -247,7 +250,7 @@ let add_inline_attribute expr loc attributes =
let attr = { attr with inline } in
check_local_inline loc attr;
check_poll_inline loc attr;
Lfunction { funct with attr = attr }
lfunction_with_attr ~attr funct
| expr, (Always_inline | Hint_inline | Never_inline | Unroll _) ->
Location.prerr_warning loc
(Warnings.Misplaced_attribute "inline");
Expand All @@ -264,7 +267,7 @@ let add_specialise_attribute expr loc attributes =
(Warnings.Duplicated_attribute "specialise")
end;
let attr = { attr with specialise } in
Lfunction { funct with attr }
lfunction_with_attr ~attr funct
| expr, (Always_specialise | Never_specialise) ->
Location.prerr_warning loc
(Warnings.Misplaced_attribute "specialise");
Expand All @@ -283,7 +286,7 @@ let add_local_attribute expr loc attributes =
let attr = { attr with local } in
check_local_inline loc attr;
check_poll_local loc attr;
Lfunction { funct with attr }
lfunction_with_attr ~attr funct
| expr, (Always_local | Never_local) ->
Location.prerr_warning loc
(Warnings.Misplaced_attribute "local");
Expand All @@ -298,7 +301,7 @@ let add_tmc_attribute expr loc attributes =
Location.prerr_warning loc
(Warnings.Duplicated_attribute "tail_mod_cons");
let attr = { funct.attr with tmc_candidate = true } in
Lfunction { funct with attr }
lfunction_with_attr ~attr funct
| expr ->
Location.prerr_warning loc
(Warnings.Misplaced_attribute "tail_mod_cons");
Expand All @@ -320,7 +323,7 @@ let add_poll_attribute expr loc attributes =
check_poll_inline loc attr;
check_poll_local loc attr;
let attr = { attr with inline = Never_inline; local = Never_local } in
Lfunction { funct with attr }
lfunction_with_attr ~attr funct
| expr, Error_poll ->
Location.prerr_warning loc
(Warnings.Misplaced_attribute "error_poll");
Expand Down
93 changes: 48 additions & 45 deletions lambda/translclass.ml
View file
Open in desktop
Expand Up @@ -32,15 +32,16 @@ let lfunction params body =
match body with
| Lfunction {kind = Curried; params = params'; body = body'; attr; loc}
when List.length params + List.length params' <= Lambda.max_arity() ->
Lfunction {kind = Curried; params = params @ params';
return = Pgenval;
body = body'; attr;
loc}
lfunction ~kind:Curried ~params:(params @ params')
~return:Pgenval
~body:body'
~attr
~loc
| _ ->
Lfunction {kind = Curried; params; return = Pgenval;
body;
attr = default_function_attribute;
loc = Loc_unknown}
lfunction ~kind:Curried ~params ~return:Pgenval
~body
~attr:default_function_attribute
~loc:Loc_unknown

let lapply ap =
match ap.ap_func with
Expand Down Expand Up @@ -180,12 +181,13 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl =
(inh_init,
let build params rem =
let param = name_pattern "param" pat in
Lfunction {kind = Curried; params = (param, Pgenval)::params;
return = Pgenval;
attr = default_function_attribute;
loc = of_location ~scopes pat.pat_loc;
body = Matching.for_function ~scopes pat.pat_loc
None (Lvar param) [pat, rem] partial}
Lambda.lfunction
~kind:Curried ~params:((param, Pgenval)::params)
~return:Pgenval
~attr:default_function_attribute
~loc:(of_location ~scopes pat.pat_loc)
~body:(Matching.for_function ~scopes pat.pat_loc
None (Lvar param) [pat, rem] partial)
in
begin match obj_init with
Lfunction {kind = Curried; params; body = rem} -> build params rem
Expand Down Expand Up @@ -443,12 +445,13 @@ let rec transl_class_rebind ~scopes obj_init cl vf =
transl_class_rebind ~scopes obj_init cl vf in
let build params rem =
let param = name_pattern "param" pat in
Lfunction {kind = Curried; params = (param, Pgenval)::params;
return = Pgenval;
attr = default_function_attribute;
loc = of_location ~scopes pat.pat_loc;
body = Matching.for_function ~scopes pat.pat_loc
None (Lvar param) [pat, rem] partial}
Lambda.lfunction
~kind:Curried ~params:((param, Pgenval)::params)
~return:Pgenval
~attr:default_function_attribute
~loc:(of_location ~scopes pat.pat_loc)
~body:(Matching.for_function ~scopes pat.pat_loc
None (Lvar param) [pat, rem] partial)
in
(path, path_lam,
match obj_init with
Expand Down Expand Up @@ -791,11 +794,12 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =

let concrete = (vflag = Concrete)
and lclass lam =
let cl_init = llets (Lfunction{kind = Curried;
attr = default_function_attribute;
loc = Loc_unknown;
return = Pgenval;
params = [cla, Pgenval]; body = cl_init}) in
let cl_init = llets (Lambda.lfunction
~kind:Curried
~attr:default_function_attribute
~loc:Loc_unknown
~return:Pgenval
~params:[cla, Pgenval] ~body:cl_init) in
Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
and lbody fv =
if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then
Expand All @@ -813,11 +817,12 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
Loc_unknown))))
and lbody_virt lenvs =
Lprim(Pmakeblock(0, Immutable, None),
[lambda_unit; Lfunction{kind = Curried;
attr = default_function_attribute;
loc = Loc_unknown;
return = Pgenval;
params = [cla, Pgenval]; body = cl_init};
[lambda_unit; Lambda.lfunction
~kind:Curried
~attr:default_function_attribute
~loc:Loc_unknown
~return:Pgenval
~params:[cla, Pgenval] ~body:cl_init;
lambda_unit; lenvs],
Loc_unknown)
in
Expand Down Expand Up @@ -871,11 +876,12 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
in
let lclass lam =
Llet(Strict, Pgenval, class_init,
Lfunction{kind = Curried; params = [cla, Pgenval];
return = Pgenval;
attr = default_function_attribute;
loc = Loc_unknown;
body = def_ids cla cl_init}, lam)
Lambda.lfunction
~kind:Curried ~params:[cla, Pgenval]
~return:Pgenval
~attr:default_function_attribute
~loc:Loc_unknown
~body:(def_ids cla cl_init), lam)
and lcache lam =
if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
Llet(Strict, Pgenval, cached,
Expand All @@ -894,16 +900,13 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
lset cached 0 (Lvar env_init))))
and lclass_virt () =
lset cached 0
(Lfunction
{
kind = Curried;
attr = default_function_attribute;
loc = Loc_unknown;
return = Pgenval;
params = [cla, Pgenval];
body = def_ids cla cl_init;
}
)
(Lambda.lfunction
~kind:Curried
~attr:default_function_attribute
~loc:Loc_unknown
~return:Pgenval
~params:[cla, Pgenval]
~body:(def_ids cla cl_init))
in
let lupdate_cache =
if ids = [] then ldirect () else
Expand Down