From 5f04f5a8209462af3922856c54528be2ffbbf399 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 15 Aug 2024 21:45:50 -0700 Subject: [PATCH] refactor: external arg spec ffi representation --- jscomp/common/external_arg_spec.ml | 8 ++--- jscomp/common/external_arg_spec.mli | 10 ++---- jscomp/common/external_ffi_types.ml | 12 ++++--- jscomp/common/external_ffi_types.mli | 22 ++++++++---- jscomp/core/lam_compile_external_call.ml | 5 ++- jscomp/core/lam_compile_external_call.mli | 3 +- jscomp/core/lam_compile_external_obj.ml | 41 ++++++++++++----------- jscomp/core/lam_compile_external_obj.mli | 2 +- jscomp/core/lam_ffi.ml | 18 +++++++--- jscomp/core/lam_ffi.mli | 3 +- jscomp/core/lam_primitive.ml | 9 +++-- jscomp/core/lam_primitive.mli | 9 +++-- ppx/ast_external_mk.ml | 10 ++++-- ppx/ast_external_process.ml | 37 +++++++++++--------- 14 files changed, 117 insertions(+), 72 deletions(-) diff --git a/jscomp/common/external_arg_spec.ml b/jscomp/common/external_arg_spec.ml index 280835f186..0417193b99 100644 --- a/jscomp/common/external_arg_spec.ml +++ b/jscomp/common/external_arg_spec.ml @@ -62,9 +62,7 @@ type attr = | Ignore | Unwrap -type param = { arg_type : attr; arg_label : label_noname } -type obj_param = { obj_arg_type : attr; obj_arg_label : label } -type obj_params = obj_param list +type 'a param = { arg_type : attr; arg_label : 'a } let cst_obj_literal s = Arg_js_literal s let cst_int i = Arg_int_lit i @@ -75,5 +73,7 @@ let obj_label name = Obj_label { name } let optional for_sure_no_nested_option name = Obj_optional { name; for_sure_no_nested_option } -let empty_kind obj_arg_type = { obj_arg_label = empty_label; obj_arg_type } +let empty_kind obj_arg_type = + { arg_label = empty_label; arg_type = obj_arg_type } + let dummy = { arg_type = Nothing; arg_label = Arg_empty } diff --git a/jscomp/common/external_arg_spec.mli b/jscomp/common/external_arg_spec.mli index 4a916bb27d..392bcc58de 100644 --- a/jscomp/common/external_arg_spec.mli +++ b/jscomp/common/external_arg_spec.mli @@ -47,17 +47,13 @@ type attr = | Unwrap type label_noname = Arg_label | Arg_empty | Arg_optional -type obj_param = { obj_arg_type : attr; obj_arg_label : label } -type param = { arg_type : attr; arg_label : label_noname } -type obj_params = obj_param list +type 'a param = { arg_type : attr; arg_label : 'a } val cst_obj_literal : string -> cst val cst_int : int -> cst val cst_string : string -> cst val empty_label : label - -(* val empty_lit : cst -> label *) val obj_label : string -> label val optional : bool -> string -> label -val empty_kind : attr -> obj_param -val dummy : param +val empty_kind : attr -> label param +val dummy : label_noname param diff --git a/jscomp/common/external_ffi_types.ml b/jscomp/common/external_ffi_types.ml index 0bc17f028b..fcabc4de4d 100644 --- a/jscomp/common/external_ffi_types.ml +++ b/jscomp/common/external_ffi_types.ml @@ -93,14 +93,16 @@ type return_wrapper = | Return_null_undefined_to_opt | Return_replaced_with_unit -type params = Params of External_arg_spec.param list | Param_number of int +type params = + | Params of External_arg_spec.label_noname External_arg_spec.param list + | Param_number of int type t = | Ffi_mel of params * return_wrapper * external_spec (** [Ffi_mel(args,return,attr) ] [return] means return value is unit or not, [true] means is [unit] *) - | Ffi_obj_create of External_arg_spec.obj_params + | Ffi_obj_create of External_arg_spec.label External_arg_spec.param list | Ffi_inline_const of Lam_constant.t | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -238,7 +240,8 @@ let inline_float_primitive (i : string) : string list = [ ""; to_string (Ffi_inline_const (Const_float i)) ] let ffi_mel = - let rec ffi_mel_aux acc (params : External_arg_spec.param list) = + let rec ffi_mel_aux acc + (params : External_arg_spec.label_noname External_arg_spec.param list) = match params with | { arg_type = Nothing; arg_label = Arg_empty } (* same as External_arg_spec.dummy*) @@ -247,7 +250,8 @@ let ffi_mel = | _ :: _ -> -1 | [] -> acc in - fun (params : External_arg_spec.param list) return attr -> + fun (params : External_arg_spec.label_noname External_arg_spec.param list) + return attr -> let n = ffi_mel_aux 0 params in if n < 0 then Ffi_mel (Params params, return, attr) else Ffi_mel (Param_number n, return, attr) diff --git a/jscomp/common/external_ffi_types.mli b/jscomp/common/external_ffi_types.mli index b0c19e43a0..f730bed832 100644 --- a/jscomp/common/external_ffi_types.mli +++ b/jscomp/common/external_ffi_types.mli @@ -85,11 +85,13 @@ type return_wrapper = | Return_null_undefined_to_opt | Return_replaced_with_unit -type params = Params of External_arg_spec.param list | Param_number of int +type params = + | Params of External_arg_spec.label_noname External_arg_spec.param list + | Param_number of int type t = private | Ffi_mel of params * return_wrapper * external_spec - | Ffi_obj_create of External_arg_spec.obj_params + | Ffi_obj_create of External_arg_spec.label External_arg_spec.param list | Ffi_inline_const of Lam_constant.t | Ffi_normal (* When it's normal, it is handled as normal c functional ffi call *) @@ -109,10 +111,18 @@ val inline_int64_primitive : int64 -> string list val inline_float_primitive : string -> string list val ffi_mel : - External_arg_spec.param list -> return_wrapper -> external_spec -> t + External_arg_spec.label_noname External_arg_spec.param list -> + return_wrapper -> + external_spec -> + t val ffi_mel_as_prims : - External_arg_spec.param list -> return_wrapper -> external_spec -> string list + External_arg_spec.label_noname External_arg_spec.param list -> + return_wrapper -> + external_spec -> + string list -val ffi_obj_create : External_arg_spec.obj_params -> t -val ffi_obj_as_prims : External_arg_spec.obj_params -> string list +val ffi_obj_create : External_arg_spec.label External_arg_spec.param list -> t + +val ffi_obj_as_prims : + External_arg_spec.label External_arg_spec.param list -> string list diff --git a/jscomp/core/lam_compile_external_call.ml b/jscomp/core/lam_compile_external_call.ml index 8b20017fb7..781daf6c09 100644 --- a/jscomp/core/lam_compile_external_call.ml +++ b/jscomp/core/lam_compile_external_call.ml @@ -147,7 +147,10 @@ let ocaml_to_js_eff ~(arg_label : Melange_ffi.External_arg_spec.label_noname) let empty_pair = ([], []) let add_eff eff e = match eff with None -> e | Some v -> E.seq v e -type specs = Melange_ffi.External_arg_spec.param list +type specs = + Melange_ffi.External_arg_spec.label_noname Melange_ffi.External_arg_spec.param + list + type exprs = E.t list (* TODO: fix splice, diff --git a/jscomp/core/lam_compile_external_call.mli b/jscomp/core/lam_compile_external_call.mli index b1f1fd6a41..85a05d27fe 100644 --- a/jscomp/core/lam_compile_external_call.mli +++ b/jscomp/core/lam_compile_external_call.mli @@ -31,7 +31,8 @@ val ocaml_to_js_eff : val translate_ffi : Lam_compile_context.t -> - Melange_ffi.External_arg_spec.param list -> + Melange_ffi.External_arg_spec.label_noname Melange_ffi.External_arg_spec.param + list -> Melange_ffi.External_ffi_types.external_spec -> J.expression list -> J.expression diff --git a/jscomp/core/lam_compile_external_obj.ml b/jscomp/core/lam_compile_external_obj.ml index b907511def..84ed553853 100644 --- a/jscomp/core/lam_compile_external_obj.ml +++ b/jscomp/core/lam_compile_external_obj.ml @@ -38,16 +38,17 @@ module S = Js_stmt_make *) (* TODO: check stackoverflow *) -let assemble_obj_args (labels : Melange_ffi.External_arg_spec.obj_params) - (args : J.expression list) : J.block * J.expression = - let rec aux (labels : Melange_ffi.External_arg_spec.obj_params) args : - (Js_op.property_name * E.t) list * J.expression list * _ = +let assemble_obj_args + (labels : + Melange_ffi.External_arg_spec.label Melange_ffi.External_arg_spec.param + list) (args : J.expression list) : J.block * J.expression = + let rec aux + (labels : + Melange_ffi.External_arg_spec.label Melange_ffi.External_arg_spec.param + list) args : (Js_op.property_name * E.t) list * J.expression list * _ = match (labels, args) with | [], [] -> ([], [], []) - | ( { - obj_arg_label = Obj_label { name = label }; - obj_arg_type = Arg_cst cst; - } + | ( { arg_label = Obj_label { name = label }; arg_type = Arg_cst cst } :: labels, args ) -> let accs, eff, assign = aux labels args in @@ -55,25 +56,24 @@ let assemble_obj_args (labels : Melange_ffi.External_arg_spec.obj_params) eff, assign ) (* | {obj_arg_label = EmptyCst _ } :: rest , args -> assert false *) - | { obj_arg_label = Obj_empty; _ } :: labels, arg :: args -> + | { arg_label = Obj_empty; _ } :: labels, arg :: args -> (* unit type*) let ((accs, eff, assign) as r) = aux labels args in if Js_analyzer.no_side_effect_expression arg then r else (accs, arg :: eff, assign) - | ( ({ obj_arg_label = Obj_label { name = label }; _ } as arg_kind) :: labels, + | ( ({ arg_label = Obj_label { name = label }; _ } as arg_kind) :: labels, arg :: args ) -> ( let accs, eff, assign = aux labels args in let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label - ~arg_type:arg_kind.obj_arg_type arg + ~arg_type:arg_kind.arg_type arg in match acc with | Splice2 _ | Splice0 -> assert false | Splice1 x -> ((Js_op.Lit label, x) :: accs, List.append new_eff eff, assign) (* evaluation order is undefined *)) - | ( ({ obj_arg_label = Obj_optional { name = label; _ }; obj_arg_type } as - arg_kind) + | ( ({ arg_label = Obj_optional { name = label; _ }; arg_type } as arg_kind) :: labels, arg :: args ) -> let ((accs, eff, assign) as r) = aux labels args in @@ -81,15 +81,14 @@ let assemble_obj_args (labels : Melange_ffi.External_arg_spec.obj_params) ~for_sure_some:(fun x -> let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label - ~arg_type:obj_arg_type x + ~arg_type x in match acc with | Splice2 _ | Splice0 -> assert false | Splice1 x -> ((Js_op.Lit label, x) :: accs, List.append new_eff eff, assign)) ~not_sure:(fun _ -> (accs, eff, (arg_kind, arg) :: assign)) - | { obj_arg_label = Obj_empty | Obj_label _ | Obj_optional _; _ } :: _, [] - -> + | { arg_label = Obj_empty | Obj_label _ | Obj_optional _; _ } :: _, [] -> assert false | [], _ :: _ -> assert false in @@ -109,12 +108,14 @@ let assemble_obj_args (labels : Melange_ffi.External_arg_spec.obj_params) | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map)) :: List.concat_map ~f:(fun - ( (xlabel : Melange_ffi.External_arg_spec.obj_param), + ( (xlabel : + Melange_ffi.External_arg_spec.label + Melange_ffi.External_arg_spec.param), (arg : J.expression) ) -> match xlabel with | { - obj_arg_label = + arg_label = Obj_optional { name = label; for_sure_no_nested_option }; _; } -> ( @@ -125,7 +126,7 @@ let assemble_obj_args (labels : Melange_ffi.External_arg_spec.obj_params) | None -> ( let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff - ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type + ~arg_label:Arg_empty ~arg_type:xlabel.arg_type (if for_sure_no_nested_option then arg else Js_of_lam_option.val_from_option arg) in @@ -148,7 +149,7 @@ let assemble_obj_args (labels : Melange_ffi.External_arg_spec.obj_params) let arg = E.var id in let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff - ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type + ~arg_label:Arg_empty ~arg_type:xlabel.arg_type (if for_sure_no_nested_option then arg else Js_of_lam_option.val_from_option arg) in diff --git a/jscomp/core/lam_compile_external_obj.mli b/jscomp/core/lam_compile_external_obj.mli index 02f22e8ccd..0b95be772d 100644 --- a/jscomp/core/lam_compile_external_obj.mli +++ b/jscomp/core/lam_compile_external_obj.mli @@ -31,7 +31,7 @@ *) val assemble_obj_args : - Melange_ffi.External_arg_spec.obj_params -> + Melange_ffi.External_arg_spec.label Melange_ffi.External_arg_spec.param list -> J.expression list -> J.block * J.expression (* It returns a block in cases we need set the property dynamically: we need diff --git a/jscomp/core/lam_ffi.ml b/jscomp/core/lam_ffi.ml index 6a8ced4f32..732c65d6ce 100644 --- a/jscomp/core/lam_ffi.ml +++ b/jscomp/core/lam_ffi.ml @@ -30,14 +30,20 @@ if it does not we wrap it in a normal way otherwise *) let rec no_auto_uncurried_arg_types - (xs : Melange_ffi.External_arg_spec.param list) = + (xs : + Melange_ffi.External_arg_spec.label_noname + Melange_ffi.External_arg_spec.param + list) = match xs with | [] -> true | { arg_type = Fn_uncurry_arity _; _ } :: _ -> false | _ :: xs -> no_auto_uncurried_arg_types xs let rec transform_uncurried_arg_type loc - (arg_types : Melange_ffi.External_arg_spec.param list) (args : Lam.t list) = + (arg_types : + Melange_ffi.External_arg_spec.label_noname + Melange_ffi.External_arg_spec.param + list) (args : Lam.t list) = match (arg_types, args) with | { arg_type = Fn_uncurry_arity n; arg_label } :: xs, y :: ys -> let o_arg_types, o_args = transform_uncurried_arg_type loc xs ys in @@ -67,9 +73,11 @@ let handle_mel_non_obj_ffi = Lam.prim ~primitive:Pundefined_to_opt ~args:[ result ] loc | Return_unset | Return_identity -> result in - fun (arg_types : Melange_ffi.External_arg_spec.param list) - (result_type : Melange_ffi.External_ffi_types.return_wrapper) ffi args loc - prim_name -> + fun (arg_types : + Melange_ffi.External_arg_spec.label_noname + Melange_ffi.External_arg_spec.param + list) (result_type : Melange_ffi.External_ffi_types.return_wrapper) ffi + args loc prim_name -> if no_auto_uncurried_arg_types arg_types then result_wrap loc result_type (Lam.prim ~primitive:(Pjs_call { prim_name; arg_types; ffi }) ~args loc) diff --git a/jscomp/core/lam_ffi.mli b/jscomp/core/lam_ffi.mli index 88e575a379..207bed8564 100644 --- a/jscomp/core/lam_ffi.mli +++ b/jscomp/core/lam_ffi.mli @@ -23,7 +23,8 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val handle_mel_non_obj_ffi : - Melange_ffi.External_arg_spec.param list -> + Melange_ffi.External_arg_spec.label_noname Melange_ffi.External_arg_spec.param + list -> Melange_ffi.External_ffi_types.return_wrapper -> Melange_ffi.External_ffi_types.external_spec -> Lam.t list -> diff --git a/jscomp/core/lam_primitive.ml b/jscomp/core/lam_primitive.ml index fc616408fb..e20aff0109 100644 --- a/jscomp/core/lam_primitive.ml +++ b/jscomp/core/lam_primitive.ml @@ -48,10 +48,15 @@ type t = | Pccall of { prim_name : string } | Pjs_call of { prim_name : string; - arg_types : Melange_ffi.External_arg_spec.param list; + arg_types : + Melange_ffi.External_arg_spec.label_noname + Melange_ffi.External_arg_spec.param + list; ffi : Melange_ffi.External_ffi_types.external_spec; } - | Pjs_object_create of Melange_ffi.External_arg_spec.obj_params + | Pjs_object_create of + Melange_ffi.External_arg_spec.label Melange_ffi.External_arg_spec.param + list (* Exceptions *) | Praise (* Boolean operations *) diff --git a/jscomp/core/lam_primitive.mli b/jscomp/core/lam_primitive.mli index 281140ad2e..66955e5fa6 100644 --- a/jscomp/core/lam_primitive.mli +++ b/jscomp/core/lam_primitive.mli @@ -45,10 +45,15 @@ type t = | Pjs_call of { (* Location.t * [loc] is passed down *) prim_name : string; - arg_types : Melange_ffi.External_arg_spec.param list; + arg_types : + Melange_ffi.External_arg_spec.label_noname + Melange_ffi.External_arg_spec.param + list; ffi : Melange_ffi.External_ffi_types.external_spec; } - | Pjs_object_create of Melange_ffi.External_arg_spec.obj_params + | Pjs_object_create of + Melange_ffi.External_arg_spec.label Melange_ffi.External_arg_spec.param + list | Praise | Psequand | Psequor diff --git a/ppx/ast_external_mk.ml b/ppx/ast_external_mk.ml index d146ba0a93..f755940de4 100644 --- a/ppx/ast_external_mk.ml +++ b/ppx/ast_external_mk.ml @@ -166,7 +166,10 @@ let pval_prim_of_labels (labels : string Asttypes.loc list) = Melange_ffi.External_arg_spec.obj_label (Melange_ffi.Lam_methname.translate p.txt) in - { Melange_ffi.External_arg_spec.obj_arg_type = Nothing; obj_arg_label } + { + Melange_ffi.External_arg_spec.arg_type = Nothing; + arg_label = obj_arg_label; + } :: arg_kinds) labels ~init:[] in @@ -183,7 +186,10 @@ let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list) Melange_ffi.External_arg_spec.optional false label_name else Melange_ffi.External_arg_spec.obj_label label_name in - { Melange_ffi.External_arg_spec.obj_arg_type = Nothing; obj_arg_label } + { + Melange_ffi.External_arg_spec.arg_type = Nothing; + arg_label = obj_arg_label; + } :: arg_kinds) labels ~init: diff --git a/ppx/ast_external_process.ml b/ppx/ast_external_process.ml index 25abeab2ab..27627efe3e 100644 --- a/ppx/ast_external_process.ml +++ b/ppx/ast_external_process.ml @@ -527,8 +527,8 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | Arg_cst _ -> let s = Melange_ffi.Lam_methname.translate name in ( { - obj_arg_label = External_arg_spec.obj_label s; - obj_arg_type; + arg_label = External_arg_spec.obj_label s; + arg_type = obj_arg_type; }, arg_types, (* ignored in [arg_types], reserved in [result_types] *) @@ -536,8 +536,8 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | Nothing | Unwrap -> let s = Melange_ffi.Lam_methname.translate name in ( { - obj_arg_label = External_arg_spec.obj_label s; - obj_arg_type; + arg_label = External_arg_spec.obj_label s; + arg_type = obj_arg_type; }, param_type :: arg_types, Ast_helper.Of.tag { Asttypes.txt = name; loc } ty @@ -545,8 +545,8 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | Int _ -> let s = Melange_ffi.Lam_methname.translate name in ( { - obj_arg_label = External_arg_spec.obj_label s; - obj_arg_type; + arg_label = External_arg_spec.obj_label s; + arg_type = obj_arg_type; }, param_type :: arg_types, Ast_helper.Of.tag @@ -556,8 +556,8 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | Poly_var_string _ -> let s = Melange_ffi.Lam_methname.translate name in ( { - obj_arg_label = External_arg_spec.obj_label s; - obj_arg_type; + arg_label = External_arg_spec.obj_label s; + arg_type = obj_arg_type; }, param_type :: arg_types, Ast_helper.Of.tag @@ -590,8 +590,8 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) https://github.com/melange-re/melange/pull/58 for a test case. *) ( { - obj_arg_label = External_arg_spec.optional false s; - obj_arg_type; + arg_label = External_arg_spec.optional false s; + arg_type = obj_arg_type; }, param_type :: arg_types, Ast_helper.Of.tag @@ -603,8 +603,8 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | Int _ -> let s = Melange_ffi.Lam_methname.translate name in ( { - obj_arg_label = External_arg_spec.optional true s; - obj_arg_type; + arg_label = External_arg_spec.optional true s; + arg_type = obj_arg_type; }, param_type :: arg_types, Ast_helper.Of.tag @@ -616,8 +616,8 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) | Poly_var_string _ -> let s = Melange_ffi.Lam_methname.translate name in ( { - obj_arg_label = External_arg_spec.optional true s; - obj_arg_type; + arg_label = External_arg_spec.optional true s; + arg_type = obj_arg_type; }, param_type :: arg_types, Ast_helper.Of.tag @@ -665,7 +665,9 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) let external_desc_of_non_obj (loc : Location.t) (st : external_desc) (prim_name_or_pval_prim : bundle_source) (arg_type_specs_length : int) - arg_types_ty (arg_type_specs : External_arg_spec.param list) : + arg_types_ty + (arg_type_specs : + External_arg_spec.label_noname External_arg_spec.param list) : External_ffi_types.external_spec = match st with | { @@ -1051,7 +1053,10 @@ let handle_attributes (loc : Location.t) (type_annotation : core_type) else let arg_type_specs, new_arg_types_ty, arg_type_specs_length = let variadic = external_desc.variadic in - let (init : External_arg_spec.param list * param_type list * int) = + let (init + : External_arg_spec.label_noname External_arg_spec.param list + * param_type list + * int) = match external_desc.val_send_pipe with | Some obj -> ( match refine_arg_type ~nolabel:true obj with