Skip to content

Commit

Permalink
Merge pull request #10719 from stedolan/arityfix
Browse files Browse the repository at this point in the history 
Ensure that build_apply respects Lambda.max_arity
  • Loading branch information
@Octachron
Octachron committed Feb 15, 2022
2 parents 0374f64 + cc59327 commit ce1a0a5
Show file tree
Hide file tree
Showing 11 changed files with 154 additions and 133 deletions.
3 changes: 3 additions & 0 deletions Changes
View file
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
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
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
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
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
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
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

0 comments on commit ce1a0a5

Please sign in to comment.