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

nested mel uncurry experiment #952

Closed
wants to merge 1 commit into from
Closed

nested mel uncurry experiment #952

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions jscomp/common/external_arg_spec.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -61,6 +61,7 @@ type attr =
| Nothing
| Ignore
| Unwrap
| Nested_callback of { this : attr; args : attr list }

type param = { arg_type : attr; arg_label : label_noname }
type obj_param = { obj_arg_type : attr; obj_arg_label : label }
Expand Down
3 changes: 1 addition & 2 deletions jscomp/common/external_arg_spec.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -45,6 +45,7 @@ type attr =
| Nothing
| Ignore
| Unwrap
| Nested_callback of { this : attr; args : attr list }

type label_noname = Arg_label | Arg_empty | Arg_optional
type obj_param = { obj_arg_type : attr; obj_arg_label : label }
Expand All @@ -56,8 +57,6 @@ 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
Expand Down
84 changes: 52 additions & 32 deletions jscomp/core/lam.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,8 @@ open Import
module Constant = Melange_ffi.Lam_constant
module Methname = Melange_ffi.Lam_methname
module Tag_info = Melange_ffi.Lam_tag_info
module External_arg_spec = Melange_ffi.External_arg_spec
module External_ffi_types = Melange_ffi.External_ffi_types

type ident = Ident.t
type apply_status = App_na | App_infer_full | App_uncurry
Expand Down Expand Up @@ -805,21 +807,8 @@ let sequor l r = if_ l true_ r
let sequand l r = if_ l r false_

(*********************************)
(* only [handle_mel_non_obj_ffi] will be used outside *)
(*
[no_auto_uncurried_arg_types xs]
check if the FFI have @uncurry attribute.
if it does not we wrap it in a nomral way otherwise
*)
let rec no_auto_uncurried_arg_types (xs : Melange_ffi.External_arg_spec.params)
=
match xs with
| [] -> true
| { arg_type = Fn_uncurry_arity _; _ } :: _ -> false
| _ :: xs -> no_auto_uncurried_arg_types xs

let result_wrap loc
(result_type : Melange_ffi.External_ffi_types.return_wrapper) result =

let result_wrap loc (result_type : External_ffi_types.return_wrapper) result =
match result_type with
| Return_replaced_with_unit -> seq result unit
| Return_null_to_opt -> prim ~primitive:Pnull_to_opt ~args:[ result ] loc
Expand All @@ -829,14 +818,21 @@ let result_wrap loc
prim ~primitive:Pundefined_to_opt ~args:[ result ] loc
| Return_unset | Return_identity -> result

let rec transform_uncurried_arg_type loc
(arg_types : Melange_ffi.External_arg_spec.params) (args : t list) =
let rec transform_uncurried_arg_type loc (arg_types : External_arg_spec.params)
(args : t list) =
match (arg_types, args) with
| { arg_type = Fn_uncurry_arity n; arg_label } :: xs, y :: ys ->
| ( {
arg_type =
( Fn_uncurry_arity n
| Nested_callback { this = Fn_uncurry_arity n; args = _ } );
arg_label;
}
:: xs,
y :: ys ) ->
let o_arg_types, o_args = transform_uncurried_arg_type loc xs ys in
( { Melange_ffi.External_arg_spec.arg_type = Nothing; arg_label }
:: o_arg_types,
( { External_arg_spec.arg_type = Nothing; arg_label } :: o_arg_types,
prim ~primitive:(Pjs_fn_make n) ~args:[ y ] loc :: o_args )
| { arg_type = Nested_callback _; _ } :: _, _ :: _ -> assert false
| x :: xs, y :: ys -> (
match x with
| { arg_type = Arg_cst _; _ } ->
Expand All @@ -847,15 +843,39 @@ let rec transform_uncurried_arg_type loc
(x :: o_arg_types, y :: o_args))
| ([], [] | _ :: _, [] | [], _ :: _) as ok -> ok

let handle_mel_non_obj_ffi (arg_types : Melange_ffi.External_arg_spec.params)
(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
(prim ~primitive:(Pjs_call { prim_name; arg_types; ffi }) ~args loc)
else
let n_arg_types, n_args = transform_uncurried_arg_type loc arg_types args in
result_wrap loc result_type
(prim
~primitive:(Pjs_call { prim_name; arg_types = n_arg_types; ffi })
~args:n_args loc)
let handle_mel_non_obj_ffi =
(* only [handle_mel_non_obj_ffi] will be used outside
[no_auto_uncurried_arg_types xs]
check if the FFI have @uncurry attribute.
if it does not we wrap it in a normal way otherwise *)
let rec no_auto_uncurried_arg_types (xs : External_arg_spec.params) =
match xs with
| [] -> true
| {
arg_type =
Fn_uncurry_arity _ | Nested_callback { this = Fn_uncurry_arity _; _ };
_;
}
:: _ ->
false
| { arg_type = Nested_callback { this = _; args }; _ } :: _ ->
not
(List.exists
~f:(function
| External_arg_spec.Fn_uncurry_arity _ -> true | _ -> false)
args)
| _ :: xs -> no_auto_uncurried_arg_types xs
in
fun (arg_types : External_arg_spec.params)
(result_type : External_ffi_types.return_wrapper) ffi args loc prim_name ->
if no_auto_uncurried_arg_types arg_types then
result_wrap loc result_type
(prim ~primitive:(Pjs_call { prim_name; arg_types; ffi }) ~args loc)
else
let n_arg_types, n_args =
transform_uncurried_arg_type loc arg_types args
in
result_wrap loc result_type
(prim
~primitive:(Pjs_call { prim_name; arg_types = n_arg_types; ffi })
~args:n_args loc)
7 changes: 4 additions & 3 deletions jscomp/core/lam_compile_external_call.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -106,8 +106,8 @@ let ocaml_to_js_eff ~(arg_label : Melange_ffi.External_arg_spec.label_noname)
in
match arg_type with
Copy link
Member Author

@anmonteiro anmonteiro Dec 4, 2023 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

this function shows why we can't optimize nested [@mel.uncurry] implicitly. Here's the explanation:

  • whenever we apply arguments to an external function, we walk both the external argument list (as declared by the user), and the params passed to the function
  • nested [@mel.uncurry] are, however, and by definition, not parameters that we pass, but rather, arguments to some callback. Take the simplest example:
external foo : (((unit -> unit)[@mel.uncurry]) -> unit) -> unit = "foo"

let () = foo (fun f -> f ())

You can see how, in the function application, f is passed to us by the callback (the one we actually pass as a parameter). We don't have that information later on to apply f in the uncurried way.

Take, for example, a pathological case that could happen:

external foo : (((unit -> unit)[@mel.uncurry]) -> unit) -> unit = "foo"

let () = 
  let the_function = ref (fun () -> ()) in
  foo (fun f -> the_function := f);
  !the_function ()

| Arg_cst _ -> assert false
| Fn_uncurry_arity _ -> assert false
(* has to be preprocessed by {!Lam} module first *)
| Nested_callback { this = Fn_uncurry_arity _; _ } | Fn_uncurry_arity _ ->
assert false (* has to be preprocessed by {!Lam} module first *)
| Extern_unit ->
( (if arg_label = Arg_empty then Splice0 else Splice1 E.unit),
if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] )
Expand Down Expand Up @@ -142,7 +142,8 @@ let ocaml_to_js_eff ~(arg_label : Melange_ffi.External_arg_spec.label_noname)
| _ -> Js_of_lam_variant.eval_as_unwrap raw_arg
in
(Splice1 single_arg, [])
| Nothing -> (Splice1 arg, [])
| Nothing | Nested_callback { this = Nothing; args = [] } -> (Splice1 arg, [])
| Nested_callback _ -> assert false

let empty_pair = ([], [])
let add_eff eff e = match eff with None -> e | Some v -> E.seq v e
Expand Down
46 changes: 34 additions & 12 deletions ppx/ast_external_process.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,12 +40,9 @@ let variant_unwrap (row_fields : Parsetree.row_field list) : bool =
| [] -> false (* impossible syntax *)
| xs -> variant_can_unwrap_aux xs

(*
TODO: [nolabel] is only used once turn Nothing into Unit, refactor later
*)
let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) :
(* TODO: [nolabel] is only used once turn Nothing into Unit, refactor later *)
let spec_of_ptyp (nolabel : bool) ({ ptyp_desc; _ } as ptyp : core_type) :
External_arg_spec.attr =
let ptyp_desc = ptyp.ptyp_desc in
match
Ast_attributes.iter_process_mel_string_int_unwrap_uncurry
ptyp.ptyp_attributes
Expand Down Expand Up @@ -122,8 +119,26 @@ let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) :
(Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields))
| _ -> Nothing)

(* is_optional = false
*)
let rec collapse_arrow ~label arg return =
spec_of_ptyp (match label with Nolabel -> true | _ -> false) arg
::
(match return.ptyp_desc with
| Ptyp_arrow (arg_label, arg_typ, return_typ) ->
collapse_arrow ~label:arg_label arg_typ return_typ
| _ -> [])

let spec_of_ptyp (nolabel : bool) ({ ptyp_desc; _ } as ptyp : core_type) :
External_arg_spec.attr =
match ptyp_desc with
| Ptyp_arrow (arg_label, arg_typ, return_typ) ->
Nested_callback
{
this = spec_of_ptyp nolabel ptyp;
args = collapse_arrow ~label:arg_label arg_typ return_typ;
}
| _ -> spec_of_ptyp nolabel ptyp

(* is_optional = false *)
let refine_arg_type ~(nolabel : bool) (ptyp : Parsetree.core_type) :
External_arg_spec.attr =
match ptyp.ptyp_desc with
Expand Down Expand Up @@ -566,6 +581,9 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
Location.raise_errorf ~loc:ty.ptyp_loc
"`[%@mel.uncurry]' can't be used within \
`[@mel.obj]'"
| Nested_callback _ ->
Location.raise_errorf ~loc:ty.ptyp_loc
"`[@mel.obj]' doesn't support nested attributes"
| Extern_unit -> assert false
| Poly_var _ ->
raise
Expand All @@ -582,11 +600,12 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
result_types )
| Nothing | Unwrap ->
let s = Melange_ffi.Lam_methname.translate name in
(* XXX(anmonteiro): it's unsafe to just read the type of the
labelled argument declaration, since it could be `'a` in
the implementation, and e.g. `bool` in the interface. See
https://github.com/melange-re/melange/pull/58 for
a test case. *)
(* XXX(anmonteiro): it's unsafe to just read the type
of the labelled argument declaration, since it
could be `'a` in the implementation, and e.g.
`bool` in the interface. See
https://github.com/melange-re/melange/pull/58 for
a test case. *)
( {
obj_arg_label = External_arg_spec.optional false s;
obj_arg_type;
Expand Down Expand Up @@ -632,6 +651,9 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
Location.raise_errorf ~loc
"`[%@mel.uncurry]' can't be used within \
`[@mel.obj]'"
| Nested_callback _ ->
Location.raise_errorf ~loc:ty.ptyp_loc
"`[@mel.obj]' doesn't support nested attributes"
| Extern_unit -> assert false
| Poly_var _ ->
Location.raise_errorf ~loc
Expand Down
Loading