diff --git a/jscomp/all.depend b/jscomp/all.depend index 290253c7e7..7e810da3cb 100644 --- a/jscomp/all.depend +++ b/jscomp/all.depend @@ -381,8 +381,9 @@ core/lam_dispatch_primitive.cmi : core/j.cmx core/lam_bounded_vars.cmi : core/lam.cmi ext/ident_hashtbl.cmi core/lam_beta_reduce.cmi : core/lam_stats.cmi core/lam_closure.cmi \ core/lam.cmi ext/ident_map.cmi -core/lam_compile_external_call.cmi : core/lam_compile_context.cmi core/j.cmx \ - syntax/external_ffi_types.cmi syntax/external_arg_spec.cmi +core/lam_compile_external_call.cmi : core/lam_compile_context.cmi \ + core/js_of_lam_variant.cmi core/j.cmx syntax/external_ffi_types.cmi \ + syntax/external_arg_spec.cmi core/lam_compile_external_obj.cmi : core/j.cmx syntax/external_arg_spec.cmi core/lam_compile_primitive.cmi : core/lam_compile_context.cmi core/lam.cmi \ core/j.cmx diff --git a/jscomp/core/js_of_lam_variant.ml b/jscomp/core/js_of_lam_variant.ml index 575f61b6ba..afc77936cd 100644 --- a/jscomp/core/js_of_lam_variant.ml +++ b/jscomp/core/js_of_lam_variant.ml @@ -25,6 +25,11 @@ module E = Js_exp_make module S = Js_stmt_make +type arg_expression = + | Splice0 + | Splice1 of E.t + | Splice2 of E.t * E.t + (* we need destruct [undefined] when input is optional *) let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = if arg == E.undefined then E.undefined else @@ -41,23 +46,24 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = }) dispatches))] (** invariant: optional is not allowed in this case *) -let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) : E.t list = +let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = match arg.expression_desc with | Array ([{expression_desc = Number (Int {i} | Uint i)}; cb], _) | Caml_block([{expression_desc = Number (Int {i} | Uint i)}; cb], _, _, _) -> - let v = Ext_list.assoc_by_int None (Int32.to_int i) dispatches in [E.str v ; cb ] + let v = Ext_list.assoc_by_int None (Int32.to_int i) dispatches in + Splice2(E.str v , cb ) | _ -> let event = Ext_ident.create "action" in - [ - E.ocaml_fun [event] + Splice2 + (E.ocaml_fun [event] [(S.int_switch arg (Ext_list.map (fun (i,r) -> {J.case = i ; body = [S.return (E.index (E.var event) 0l)], false (* FIXME: if true, still print break*) }) dispatches))] - ; (* TODO: improve, one dispatch later, + , (* TODO: improve, one dispatch later, the problem is that we can not create bindings due to the *) @@ -68,7 +74,7 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) : E.t body = [S.return (E.index (E.var event) 1l)], false (* FIXME: if true, still print break*) }) dispatches))] - ] + ) (* we need destruct [undefined] when input is optional *) let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t = diff --git a/jscomp/core/js_of_lam_variant.mli b/jscomp/core/js_of_lam_variant.mli index 1643ed8575..5eca14b8c3 100644 --- a/jscomp/core/js_of_lam_variant.mli +++ b/jscomp/core/js_of_lam_variant.mli @@ -22,7 +22,17 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val eval : J.expression -> (int * string) list -> J.expression -val eval_as_event : J.expression -> (int * string) list -> J.expression list -val eval_as_int : J.expression -> (int * int) list -> J.expression +(* module E = Js_exp_make *) + +type arg_expression = + | Splice0 + | Splice1 of J.expression + | Splice2 of J.expression * J.expression + +val eval : + J.expression -> (int * string) list -> J.expression +val eval_as_event : + J.expression -> (int * string) list -> arg_expression +val eval_as_int : + J.expression -> (int * int) list -> J.expression val eval_as_unwrap : J.expression -> J.expression diff --git a/jscomp/core/lam_compile_external_call.ml b/jscomp/core/lam_compile_external_call.ml index 0b3652bc4a..a2eed5f504 100644 --- a/jscomp/core/lam_compile_external_call.ml +++ b/jscomp/core/lam_compile_external_call.ml @@ -48,7 +48,16 @@ let handle_external_opt | None -> None - +type arg_expression = Js_of_lam_variant.arg_expression = + | Splice0 + | Splice1 of E.t + | Splice2 of E.t * E.t + +let append_list x xs = + match x with + | Splice0 -> xs + | Splice1 a -> a::xs + | Splice2 (a,b) -> a::b::xs (** The first return value is value, the second argument is side effect expressions Only the [unit] with no label will be ignored When we are passing a boxed value to external(optional), we need @@ -74,7 +83,7 @@ let handle_external_opt let ocaml_to_js_eff ({arg_label; arg_type }: External_arg_spec.t) (raw_arg : J.expression) - : E.t list * E.t list = + : arg_expression * E.t list = let arg = match arg_label with | Optional label -> Js_of_lam_option.get_default_undefined raw_arg @@ -87,19 +96,20 @@ let ocaml_to_js_eff | Fn_uncurry_arity _ -> assert false (* has to be preprocessed by {!Lam} module first *) | Extern_unit -> - (if arg_label = External_arg_spec.empty_label then [] else [E.unit]), + (if arg_label = External_arg_spec.empty_label then + Splice0 else Splice1 E.unit), (if Js_analyzer.no_side_effect_expression arg then [] else [arg]) (* leave up later to decide *) | Ignore -> - [], + Splice0, (if Js_analyzer.no_side_effect_expression arg then [] else [arg]) | NullString dispatches -> - [Js_of_lam_variant.eval arg dispatches],[] + Splice1 (Js_of_lam_variant.eval arg dispatches),[] | NonNullString dispatches -> Js_of_lam_variant.eval_as_event arg dispatches,[] (* FIXME: encode invariant below in the signature*) @@ -108,7 +118,7 @@ let ocaml_to_js_eff - the value *) | Int dispatches -> - [Js_of_lam_variant.eval_as_int arg dispatches],[] + Splice1 (Js_of_lam_variant.eval_as_int arg dispatches),[] | Unwrap -> let single_arg = match arg_label with @@ -134,8 +144,8 @@ let ocaml_to_js_eff | _ -> Js_of_lam_variant.eval_as_unwrap raw_arg in - [single_arg],[] - | Nothing | Array -> [arg], [] + Splice1 single_arg,[] + | Nothing | Array -> Splice1 arg, [] @@ -182,7 +192,7 @@ let assemble_args call_loc ffi js_splice arg_types args : E.t list * E.t option else let accs, eff = aux labels args in let acc, new_eff = ocaml_to_js_eff arg_kind arg in - Ext_list.append acc accs, Ext_list.append new_eff eff + append_list acc accs, Ext_list.append new_eff eff | { arg_label = Empty None | Label (_,None) | Optional _ ; _ } :: _ , [] -> assert false | [], _ :: _ -> assert false diff --git a/jscomp/core/lam_compile_external_call.mli b/jscomp/core/lam_compile_external_call.mli index 2c77dc2873..68c3e9d121 100644 --- a/jscomp/core/lam_compile_external_call.mli +++ b/jscomp/core/lam_compile_external_call.mli @@ -33,7 +33,7 @@ val ocaml_to_js_eff : External_arg_spec.t -> J.expression -> - J.expression list * J.expression list + Js_of_lam_variant.arg_expression * J.expression list val translate_ffi : Location.t -> diff --git a/jscomp/core/lam_compile_external_obj.ml b/jscomp/core/lam_compile_external_obj.ml index f276949e01..30690306ec 100644 --- a/jscomp/core/lam_compile_external_obj.ml +++ b/jscomp/core/lam_compile_external_obj.ml @@ -60,9 +60,10 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression let accs, eff, assign = aux labels args in let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff arg_kind arg in begin match acc with - | [ ] -> assert false - | x::xs -> - (label, E.fuse_to_seq x xs ) :: accs , Ext_list.append new_eff eff , assign + | Splice2 _ + | Splice0 -> assert false + | Splice1 x -> + (label, x) :: accs , Ext_list.append new_eff eff , assign end (* evaluation order is undefined *) | ({arg_label = Optional label; arg_type } as arg_kind)::labels, arg::args @@ -76,9 +77,10 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff ({arg_label = External_arg_spec.label label None; arg_type}) x in begin match acc with - | [] -> assert false - | x::xs -> - (label, E.fuse_to_seq x xs ) :: accs , Ext_list.append new_eff eff , assign + | Splice2 _ + | Splice0 -> assert false + | Splice1 x -> + (label, x) :: accs , Ext_list.append new_eff eff , assign end | _ -> accs, eff , (arg_kind,arg)::assign @@ -118,7 +120,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression External_arg_spec.empty_label} (E.index arg 0l ) in begin match acc with - | [ v ] -> + | Splice1 v -> [S.if_ arg [S.exp (E.assign (E.dot var_v label) ( match new_eff with @@ -126,7 +128,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | x :: xs -> E.seq (E.fuse_to_seq x xs ) v ) ) ] ] - |_ -> assert false + | Splice0 | Splice2 _ -> assert false end | Some (st,id) -> (* FIXME: see #2503 *) let arg = E.var id in @@ -136,7 +138,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression External_arg_spec.empty_label} (E.index arg 0l ) in begin match acc with - | [ v ] -> + | Splice1 v -> st :: [S.if_ arg [S.exp (E.assign (E.dot var_v label) (match new_eff with @@ -144,7 +146,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | x :: xs -> E.seq (E.fuse_to_seq x xs) v )) ]] - | _ -> assert false + | Splice0 | Splice2 _ -> assert false end end | _ -> assert false diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 9a291132be..d052e9cbd0 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -93344,9 +93344,19 @@ module Js_of_lam_variant : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val eval : J.expression -> (int * string) list -> J.expression -val eval_as_event : J.expression -> (int * string) list -> J.expression list -val eval_as_int : J.expression -> (int * int) list -> J.expression +(* module E = Js_exp_make *) + +type arg_expression = + | Splice0 + | Splice1 of J.expression + | Splice2 of J.expression * J.expression + +val eval : + J.expression -> (int * string) list -> J.expression +val eval_as_event : + J.expression -> (int * string) list -> arg_expression +val eval_as_int : + J.expression -> (int * int) list -> J.expression val eval_as_unwrap : J.expression -> J.expression end = struct @@ -93378,6 +93388,11 @@ end = struct module E = Js_exp_make module S = Js_stmt_make +type arg_expression = + | Splice0 + | Splice1 of E.t + | Splice2 of E.t * E.t + (* we need destruct [undefined] when input is optional *) let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = if arg == E.undefined then E.undefined else @@ -93394,23 +93409,24 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = }) dispatches))] (** invariant: optional is not allowed in this case *) -let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) : E.t list = +let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = match arg.expression_desc with | Array ([{expression_desc = Number (Int {i} | Uint i)}; cb], _) | Caml_block([{expression_desc = Number (Int {i} | Uint i)}; cb], _, _, _) -> - let v = Ext_list.assoc_by_int None (Int32.to_int i) dispatches in [E.str v ; cb ] + let v = Ext_list.assoc_by_int None (Int32.to_int i) dispatches in + Splice2(E.str v , cb ) | _ -> let event = Ext_ident.create "action" in - [ - E.ocaml_fun [event] + Splice2 + (E.ocaml_fun [event] [(S.int_switch arg (Ext_list.map (fun (i,r) -> {J.case = i ; body = [S.return (E.index (E.var event) 0l)], false (* FIXME: if true, still print break*) }) dispatches))] - ; (* TODO: improve, one dispatch later, + , (* TODO: improve, one dispatch later, the problem is that we can not create bindings due to the *) @@ -93421,7 +93437,7 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) : E.t body = [S.return (E.index (E.var event) 1l)], false (* FIXME: if true, still print break*) }) dispatches))] - ] + ) (* we need destruct [undefined] when input is optional *) let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t = @@ -93483,7 +93499,7 @@ module Lam_compile_external_call : sig val ocaml_to_js_eff : External_arg_spec.t -> J.expression -> - J.expression list * J.expression list + Js_of_lam_variant.arg_expression * J.expression list val translate_ffi : Location.t -> @@ -93550,7 +93566,16 @@ let handle_external_opt | None -> None +type arg_expression = Js_of_lam_variant.arg_expression = + | Splice0 + | Splice1 of E.t + | Splice2 of E.t * E.t +let append_list x xs = + match x with + | Splice0 -> xs + | Splice1 a -> a::xs + | Splice2 (a,b) -> a::b::xs (** The first return value is value, the second argument is side effect expressions Only the [unit] with no label will be ignored When we are passing a boxed value to external(optional), we need @@ -93576,7 +93601,7 @@ let handle_external_opt let ocaml_to_js_eff ({arg_label; arg_type }: External_arg_spec.t) (raw_arg : J.expression) - : E.t list * E.t list = + : arg_expression * E.t list = let arg = match arg_label with | Optional label -> Js_of_lam_option.get_default_undefined raw_arg @@ -93589,19 +93614,20 @@ let ocaml_to_js_eff | Fn_uncurry_arity _ -> assert false (* has to be preprocessed by {!Lam} module first *) | Extern_unit -> - (if arg_label = External_arg_spec.empty_label then [] else [E.unit]), + (if arg_label = External_arg_spec.empty_label then + Splice0 else Splice1 E.unit), (if Js_analyzer.no_side_effect_expression arg then [] else [arg]) (* leave up later to decide *) | Ignore -> - [], + Splice0, (if Js_analyzer.no_side_effect_expression arg then [] else [arg]) | NullString dispatches -> - [Js_of_lam_variant.eval arg dispatches],[] + Splice1 (Js_of_lam_variant.eval arg dispatches),[] | NonNullString dispatches -> Js_of_lam_variant.eval_as_event arg dispatches,[] (* FIXME: encode invariant below in the signature*) @@ -93610,7 +93636,7 @@ let ocaml_to_js_eff - the value *) | Int dispatches -> - [Js_of_lam_variant.eval_as_int arg dispatches],[] + Splice1 (Js_of_lam_variant.eval_as_int arg dispatches),[] | Unwrap -> let single_arg = match arg_label with @@ -93636,8 +93662,8 @@ let ocaml_to_js_eff | _ -> Js_of_lam_variant.eval_as_unwrap raw_arg in - [single_arg],[] - | Nothing | Array -> [arg], [] + Splice1 single_arg,[] + | Nothing | Array -> Splice1 arg, [] @@ -93684,7 +93710,7 @@ let assemble_args call_loc ffi js_splice arg_types args : E.t list * E.t option else let accs, eff = aux labels args in let acc, new_eff = ocaml_to_js_eff arg_kind arg in - Ext_list.append acc accs, Ext_list.append new_eff eff + append_list acc accs, Ext_list.append new_eff eff | { arg_label = Empty None | Label (_,None) | Optional _ ; _ } :: _ , [] -> assert false | [], _ :: _ -> assert false @@ -94001,9 +94027,10 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression let accs, eff, assign = aux labels args in let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff arg_kind arg in begin match acc with - | [ ] -> assert false - | x::xs -> - (label, E.fuse_to_seq x xs ) :: accs , Ext_list.append new_eff eff , assign + | Splice2 _ + | Splice0 -> assert false + | Splice1 x -> + (label, x) :: accs , Ext_list.append new_eff eff , assign end (* evaluation order is undefined *) | ({arg_label = Optional label; arg_type } as arg_kind)::labels, arg::args @@ -94017,9 +94044,10 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression let acc, new_eff = Lam_compile_external_call.ocaml_to_js_eff ({arg_label = External_arg_spec.label label None; arg_type}) x in begin match acc with - | [] -> assert false - | x::xs -> - (label, E.fuse_to_seq x xs ) :: accs , Ext_list.append new_eff eff , assign + | Splice2 _ + | Splice0 -> assert false + | Splice1 x -> + (label, x) :: accs , Ext_list.append new_eff eff , assign end | _ -> accs, eff , (arg_kind,arg)::assign @@ -94059,7 +94087,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression External_arg_spec.empty_label} (E.index arg 0l ) in begin match acc with - | [ v ] -> + | Splice1 v -> [S.if_ arg [S.exp (E.assign (E.dot var_v label) ( match new_eff with @@ -94067,7 +94095,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | x :: xs -> E.seq (E.fuse_to_seq x xs ) v ) ) ] ] - |_ -> assert false + | Splice0 | Splice2 _ -> assert false end | Some (st,id) -> (* FIXME: see #2503 *) let arg = E.var id in @@ -94077,7 +94105,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression External_arg_spec.empty_label} (E.index arg 0l ) in begin match acc with - | [ v ] -> + | Splice1 v -> st :: [S.if_ arg [S.exp (E.assign (E.dot var_v label) (match new_eff with @@ -94085,7 +94113,7 @@ let assemble_args_obj (labels : External_arg_spec.t list) (args : J.expression | x :: xs -> E.seq (E.fuse_to_seq x xs) v )) ]] - | _ -> assert false + | Splice0 | Splice2 _ -> assert false end end | _ -> assert false