diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index e2d4a51f46..b1717ae893 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -267,12 +267,14 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) }; args = [(_, lhs); (_, {pexp_desc = Pexp_apply {funct = d; args; partial}})]; + transformed_jsx; } -> (* Transform away pipe with apply call *) exprToContextPath ~inJsxContext { pexp_desc = - Pexp_apply {funct = d; args = (Nolabel, lhs) :: args; partial}; + Pexp_apply + {funct = d; args = (Nolabel, lhs) :: args; partial; transformed_jsx}; pexp_loc; pexp_attributes; } @@ -284,6 +286,7 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) (_, lhs); (_, {pexp_desc = Pexp_ident id; pexp_loc; pexp_attributes}); ]; partial; + transformed_jsx; } -> (* Transform away pipe with identifier *) exprToContextPath ~inJsxContext @@ -294,6 +297,7 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) funct = {pexp_desc = Pexp_ident id; pexp_loc; pexp_attributes}; args = [(Nolabel, lhs)]; partial; + transformed_jsx; }; pexp_loc; pexp_attributes; diff --git a/compiler/core/js_call_info.ml b/compiler/core/js_call_info.ml index 547f03c7f8..6412d91b1f 100644 --- a/compiler/core/js_call_info.ml +++ b/compiler/core/js_call_info.ml @@ -33,10 +33,12 @@ type call_info = {[ fun x y -> (f x y) === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity} +type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} -let dummy = {arity = NA; call_info = Call_na} +let dummy = {arity = NA; call_info = Call_na; call_transformed_jsx = false} -let builtin_runtime_call = {arity = Full; call_info = Call_builtin_runtime} +let builtin_runtime_call = + {arity = Full; call_info = Call_builtin_runtime; call_transformed_jsx = false} -let ml_full_call = {arity = Full; call_info = Call_ml} +let ml_full_call = + {arity = Full; call_info = Call_ml; call_transformed_jsx = false} diff --git a/compiler/core/js_call_info.mli b/compiler/core/js_call_info.mli index 0381c0cd2b..1977426737 100644 --- a/compiler/core/js_call_info.mli +++ b/compiler/core/js_call_info.mli @@ -35,7 +35,7 @@ type call_info = {[ fun x y -> f x y === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity} +type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} val dummy : t diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index bc174e7dd5..dba419bd18 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -524,6 +524,45 @@ and expression_desc cxt ~(level : int) f x : cxt = when Ext_list.length_equal el i ]} *) + | Call (e, el, {call_transformed_jsx = true}) -> ( + match el with + | [ + tag; + { + expression_desc = + Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); + }; + ] -> + let fields = + Ext_list.array_list_filter_map fields el (fun (f, opt) x -> + match x.expression_desc with + | Undefined _ when opt -> None + | _ -> Some (f, x)) + in + print_jsx cxt ~level f tag fields + | [ + tag; + { + expression_desc = + Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); + }; + key; + ] -> + let fields = + Ext_list.array_list_filter_map fields el (fun (f, opt) x -> + match x.expression_desc with + | Undefined _ when opt -> None + | _ -> Some (f, x)) + in + let fields = ("key", key) :: fields in + print_jsx cxt ~level f tag fields + | _ -> + expression_desc cxt ~level f + (Call + ( e, + el, + {call_transformed_jsx = false; arity = Full; call_info = Call_ml} + ))) | Call (e, el, info) -> P.cond_paren_group f (level > 15) (fun _ -> P.group f 0 (fun _ -> @@ -681,6 +720,7 @@ and expression_desc cxt ~(level : int) f x : cxt = P.cond_paren_group f (level > 12) (fun _ -> let cxt = expression ~level:0 cxt f prop in P.string f " in "; + P.string f " in "; expression ~level:0 cxt f obj) | Typeof e -> P.string f "typeof"; @@ -956,6 +996,58 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f "..."; expression ~level:13 cxt f e) +and print_jsx cxt ~(level : int) f (tag : J.expression) + (fields : (string * J.expression) list) : cxt = + let print_tag () = + match tag.expression_desc with + | J.Str {txt} -> P.string f txt + (* fragment *) + | J.Var (J.Qualified ({id = {name = "JsxRuntime"}}, Some "Fragment")) -> () + | _ -> + let _ = expression ~level cxt f tag in + () + in + let children_opt = + List.find_map (fun (n, e) -> if n = "children" then Some e else None) fields + in + let print_props () = + let props = List.filter (fun (n, _) -> n <> "children") fields in + if not (List.is_empty props) then + (List.iter (fun (n, x) -> + P.space f; + P.string f n; + P.string f "="; + P.string f "{"; + let _ = expression ~level:0 cxt f x in + P.string f "}")) + props + in + (match children_opt with + | None -> + P.string f "<"; + print_tag (); + print_props (); + P.string f "/>" + | Some children -> + let child_is_jsx = + match children.expression_desc with + | J.Call (_, _, {call_transformed_jsx = is_jsx}) -> is_jsx + | _ -> false + in + + P.string f "<"; + print_tag (); + print_props (); + P.string f ">"; + if not child_is_jsx then P.string f "{"; + let _ = expression ~level cxt f children in + if not child_is_jsx then P.string f "}"; + P.string f ""); + + cxt + and property_name_and_value_list cxt f (l : J.property_map) = iter_lst cxt f l (fun cxt f (pn, e) -> diff --git a/compiler/core/jsx_help.ml b/compiler/core/jsx_help.ml new file mode 100644 index 0000000000..a1a8f1c650 --- /dev/null +++ b/compiler/core/jsx_help.ml @@ -0,0 +1,47 @@ +let lambda_tag_info_to_string (e : Lambda.tag_info) = + match e with + | Lambda.Blk_constructor _ -> "Blk_constructor" + | Lambda.Blk_record_inlined _ -> "Blk_record_inlined" + | Lambda.Blk_tuple -> "Blk_tuple" + | Lambda.Blk_poly_var _ -> "Blk_poly_var" + | Lambda.Blk_record _ -> "Blk_record" + | Lambda.Blk_module _ -> "Blk_module" + | Lambda.Blk_module_export _ -> "Blk_module_export" + | Lambda.Blk_extension -> "Blk_extension" + | Lambda.Blk_some -> "Blk_some" + | Lambda.Blk_some_not_nested -> "Blk_some_not_nested" + | Lambda.Blk_record_ext _ -> "Blk_record_ext" + | Lambda.Blk_lazy_general -> "Blk_lazy_general" + +let j_exp_to_string (e : J.expression) = + match e.J.expression_desc with + | J.Object _ -> "Object" + | J.Str _ -> "String" + | J.Var _ -> "Var" + | J.Call _ -> "Call" + | J.Fun _ -> "Fun" + | J.Array _ -> "Array" + | J.Bin _ -> "Bin" + | J.Cond _ -> "Cond" + | J.New _ -> "New" + | J.Seq _ -> "Seq" + | J.Number _ -> "Number" + | J.Bool _ -> "Bool" + | J.Null -> "Null" + | J.Undefined _ -> "Undefined" + | J.Is_null_or_undefined _ -> "Is_null_or_undefined" + | J.Js_not _ -> "Js_not" + | J.Typeof _ -> "Typeof" + | J.String_index _ -> "String_index" + | J.Array_index _ -> "Array_index" + | J.Static_index _ -> "Static_index" + | J.Length _ -> "Length" + | J.Caml_block (_, _, _, tag) -> + Format.sprintf "Caml_block (%s)" (lambda_tag_info_to_string tag) + | J.Caml_block_tag _ -> "Caml_block_tag" + | J.Tagged_template _ -> "Tagged_template" + | J.Optional_block _ -> "Optional_block" + | J.Spread _ -> "Spread" + | J.Await _ -> "Await" + | J.Raw_js_code _ -> "Raw_js_code" + | _ -> "Other" diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 77f991e181..1c20bb2e8e 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -81,7 +81,12 @@ module Types = struct *) and prim_info = {primitive: Lam_primitive.t; args: t list; loc: Location.t} - and apply = {ap_func: t; ap_args: t list; ap_info: ap_info} + and apply = { + ap_func: t; + ap_args: t list; + ap_info: ap_info; + ap_transformed_jsx: bool; + } and t = | Lvar of ident @@ -121,7 +126,12 @@ module X = struct loc: Location.t; } - and apply = Types.apply = {ap_func: t; ap_args: t list; ap_info: ap_info} + and apply = Types.apply = { + ap_func: t; + ap_args: t list; + ap_info: ap_info; + ap_transformed_jsx: bool; + } and lfunction = Types.lfunction = { arity: int; @@ -159,10 +169,10 @@ include Types let inner_map (l : t) (f : t -> X.t) : X.t = match l with | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> ((* Obj.magic *) l : X.t) - | Lapply {ap_func; ap_args; ap_info} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> let ap_func = f ap_func in let ap_args = Ext_list.map ap_args f in - Lapply {ap_func; ap_args; ap_info} + Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} | Lfunction {body; arity; params; attr} -> let body = f body in Lfunction {body; arity; params; attr} @@ -279,7 +289,7 @@ let rec is_eta_conversion_exn params inner_args outer_args : t list = | _, _, _ -> raise_notrace Not_simple_form (** FIXME: more robust inlining check later, we should inline it before we add stub code*) -let rec apply fn args (ap_info : ap_info) : t = +let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = match fn with | Lfunction { @@ -300,7 +310,7 @@ let rec apply fn args (ap_info : ap_info) : t = Lprim {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc} | exception Not_simple_form -> - Lapply {ap_func = fn; ap_args = args; ap_info}) + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) | Lfunction { params; @@ -308,7 +318,8 @@ let rec apply fn args (ap_info : ap_info) : t = } -> ( match is_eta_conversion_exn params inner_args args with | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc} - | exception _ -> Lapply {ap_func = fn; ap_args = args; ap_info}) + | exception _ -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) | Lfunction { params; @@ -321,17 +332,17 @@ let rec apply fn args (ap_info : ap_info) : t = | args -> Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const) | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info} + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} (* | Lfunction {params;body} when Ext_list.same_length params args -> Ext_list.fold_right2 (fun p arg acc -> Llet(Strict,p,arg,acc) ) params args body *) (* TODO: more rigirous analysis on [let_kind] *)) | Llet (kind, id, e, (Lfunction _ as fn)) -> - Llet (kind, id, e, apply fn args ap_info) + Llet (kind, id, e, apply fn args ap_info ~ap_transformed_jsx) (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) - | _ -> Lapply {ap_func = fn; ap_args = args; ap_info} + | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} let rec eq_approx (l1 : t) (l2 : t) = match l1 with @@ -712,10 +723,12 @@ let result_wrap loc (result_type : External_ffi_types.return_wrapper) result = prim ~primitive:Pundefined_to_opt ~args:[result] loc | Return_unset | Return_identity -> result -let handle_bs_non_obj_ffi (arg_types : External_arg_spec.params) +let handle_bs_non_obj_ffi ?(transformed_jsx = false) + (arg_types : External_arg_spec.params) (result_type : External_ffi_types.return_wrapper) ffi args loc prim_name ~dynamic_import = result_wrap loc result_type (prim - ~primitive:(Pjs_call {prim_name; arg_types; ffi; dynamic_import}) + ~primitive: + (Pjs_call {prim_name; arg_types; ffi; dynamic_import; transformed_jsx}) ~args loc) diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 66858ac2a4..560d247669 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -41,7 +41,12 @@ type lambda_switch = { sw_names: Ast_untagged_variants.switch_names option; } -and apply = private {ap_func: t; ap_args: t list; ap_info: ap_info} +and apply = private { + ap_func: t; + ap_args: t list; + ap_info: ap_info; + ap_transformed_jsx: bool; +} and lfunction = { arity: int; @@ -85,6 +90,7 @@ and t = private val inner_map : t -> (t -> t) -> t val handle_bs_non_obj_ffi : + ?transformed_jsx:bool -> External_arg_spec.params -> External_ffi_types.return_wrapper -> External_ffi_types.external_spec -> @@ -103,7 +109,7 @@ val global_module : ?dynamic_import:bool -> ident -> t val const : Lam_constant.t -> t -val apply : t -> t list -> ap_info -> t +val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t val function_ : attr:Lambda.function_attribute -> diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 15ee9cff97..e038e56798 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -108,10 +108,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = (* here it makes sure that global vars are not rebound *) Lam.prim ~primitive ~args:(Ext_list.map args aux) loc | Lglobal_module _ -> lam - | Lapply {ap_func; ap_args; ap_info} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> let fn = aux ap_func in let args = Ext_list.map ap_args aux in - Lam.apply fn args ap_info + Lam.apply ~ap_transformed_jsx fn args ap_info | Lswitch ( l, { diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index ea865bbe6f..58ba342170 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -31,12 +31,13 @@ let args_either_function_or_const (args : Lam.t list) = | Lfunction _ | Lconst _ -> true | _ -> false) -let call_info_of_ap_status (ap_status : Lam.apply_status) : Js_call_info.t = +let call_info_of_ap_status call_transformed_jsx (ap_status : Lam.apply_status) : + Js_call_info.t = (* XXX *) match ap_status with - | App_infer_full -> {arity = Full; call_info = Call_ml} - | App_uncurry -> {arity = Full; call_info = Call_na} - | App_na -> {arity = NA; call_info = Call_ml} + | App_infer_full -> {arity = Full; call_info = Call_ml; call_transformed_jsx} + | App_uncurry -> {arity = Full; call_info = Call_na; call_transformed_jsx} + | App_na -> {arity = NA; call_info = Call_ml; call_transformed_jsx} let rec apply_with_arity_aux (fn : J.expression) (arity : int list) (args : E.t list) (len : int) : E.t = @@ -49,7 +50,14 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) if len >= x then let first_part, continue = Ext_list.split_at args x in apply_with_arity_aux - (E.call ~info:{arity = Full; call_info = Call_ml} fn first_part) + (E.call + ~info: + { + arity = Full; + call_info = Call_ml; + (* no clue if this is correct *) call_transformed_jsx = false; + } + fn first_part) rest continue (len - x) else if (* GPR #1423 *) @@ -63,7 +71,13 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) [ S.return_stmt (E.call - ~info:{arity = Full; call_info = Call_ml} + ~info: + { + arity = Full; + call_info = Call_ml; + (* no clue if this is correct *) call_transformed_jsx = + false; + } fn (Ext_list.append args @@ Ext_list.map params E.var)); ] @@ -306,7 +320,9 @@ let compile output_prefix = let expression = match appinfo.ap_info.ap_status with | (App_infer_full | App_uncurry) as ap_status -> - E.call ~info:(call_info_of_ap_status ap_status) fn args + E.call + ~info:(call_info_of_ap_status appinfo.ap_transformed_jsx ap_status) + fn args | App_na -> ( match ident_info.arity with | Submodule _ | Single Arity_na -> @@ -1439,6 +1455,7 @@ let compile output_prefix = ap_func = Lapply {ap_func; ap_args; ap_info = {ap_status = App_na; ap_inlined}}; ap_info = {ap_status = App_na} as outer_ap_info; + ap_transformed_jsx; } -> (* After inlining, we can generate such code, see {!Ari_regress_test}*) let ap_info = @@ -1446,7 +1463,9 @@ let compile output_prefix = else {outer_ap_info with ap_inlined} in compile_lambda lambda_cxt - (Lam.apply ap_func (Ext_list.append ap_args appinfo.ap_args) ap_info) + (Lam.apply ap_func + (Ext_list.append ap_args appinfo.ap_args) + ap_info ~ap_transformed_jsx) (* External function call: it can not be tailcall in this case*) | { ap_func = @@ -1529,7 +1548,9 @@ let compile output_prefix = Js_output.output_of_block_and_expression lambda_cxt.continuation args_code (E.call - ~info:(call_info_of_ap_status appinfo.ap_info.ap_status) + ~info: + (call_info_of_ap_status appinfo.ap_transformed_jsx + appinfo.ap_info.ap_status) fn_code args)) and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t) = diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index 6d9056e570..2a5ff0f3f4 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -267,9 +267,9 @@ let translate_scoped_access scopes obj = | [] -> obj | x :: xs -> Ext_list.fold_left xs (E.dot obj x) E.dot -let translate_ffi (cxt : Lam_compile_context.t) arg_types - (ffi : External_ffi_types.external_spec) (args : J.expression list) - ~dynamic_import = +let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) + arg_types (ffi : External_ffi_types.external_spec) + (args : J.expression list) ~dynamic_import = match ffi with | Js_call {external_module_name; name; splice : _; scopes; tagged_template = true} @@ -287,7 +287,15 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types | _ -> let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args)) + add_eff eff + (E.call + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } + fn args)) | Js_call { external_module_name = module_name; @@ -302,20 +310,52 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types if splice then let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + add_eff eff + (E.call + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } + fn args) else let args, eff = assemble_args_no_splice arg_types args in - add_eff eff @@ E.call ~info:{arity = Full; call_info = Call_na} fn args + add_eff eff + @@ E.call + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } + fn args | Js_module_as_fn {external_module_name; splice} -> let fn = external_var external_module_name ~dynamic_import in if splice then let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + add_eff eff + (E.call + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } + fn args) else let args, eff = assemble_args_no_splice arg_types args in (* TODO: fix in rest calling convention *) - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + add_eff eff + (E.call + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } + fn args) | Js_new {external_module_name = module_name; name = fn; splice; scopes} -> (* handle [@@new]*) (* This has some side effect, it will @@ -362,14 +402,24 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types add_eff eff (let self = translate_scoped_access js_send_scopes self in E.call - ~info:{arity = Full; call_info = Call_na} + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } (E.dot self name) args) else let args, eff = assemble_args_no_splice arg_types args in add_eff eff (let self = translate_scoped_access js_send_scopes self in E.call - ~info:{arity = Full; call_info = Call_na} + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } (E.dot self name) args) | _ -> assert false) | Js_module_as_var module_name -> external_var module_name ~dynamic_import @@ -384,7 +434,15 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types ~dynamic_import in if args = [] then e - else E.call ~info:{arity = Full; call_info = Call_na} e args + else + E.call + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } + e args | Js_module_as_class module_name -> let fn = external_var module_name ~dynamic_import in let args, eff = assemble_args_no_splice arg_types args in diff --git a/compiler/core/lam_compile_external_call.mli b/compiler/core/lam_compile_external_call.mli index e8c974f10a..29e05c96f9 100644 --- a/compiler/core/lam_compile_external_call.mli +++ b/compiler/core/lam_compile_external_call.mli @@ -30,6 +30,7 @@ val ocaml_to_js_eff : (** Compile ocaml external function call to JS IR. *) val translate_ffi : + ?transformed_jsx:bool -> Lam_compile_context.t -> External_arg_spec.params -> External_ffi_types.external_spec -> diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index aac979d926..ae17cd8077 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -56,14 +56,14 @@ let get_module_system () = let import_of_path path = E.call - ~info:{arity = Full; call_info = Call_na} + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} (E.js_global "import") [E.str path] let wrap_then import value = let arg = Ident.create "m" in E.call - ~info:{arity = Full; call_info = Call_na} + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} (E.dot import "then") [ E.ocaml_fun ~return_unit:false ~async:false ~one_unit_arg:false [arg] @@ -88,7 +88,10 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | _ -> assert false) | Pjs_apply -> ( match args with - | fn :: rest -> E.call ~info:{arity = Full; call_info = Call_na} fn rest + | fn :: rest -> + E.call + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} + fn rest | _ -> assert false) | Pnull_to_opt -> ( match args with @@ -594,9 +597,9 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) (* Lam_compile_external_call.translate loc cxt prim args *) (* Test if the argument is a block or an immediate integer *) | Pjs_object_create _ -> assert false - | Pjs_call {arg_types; ffi; dynamic_import} -> + | Pjs_call {arg_types; ffi; dynamic_import; transformed_jsx} -> Lam_compile_external_call.translate_ffi cxt arg_types ffi args - ~dynamic_import + ~dynamic_import ~transformed_jsx (* FIXME, this can be removed later *) | Pisint -> E.is_type_number (Ext_list.singleton_exn args) | Pis_poly_var_block -> E.is_type_object (Ext_list.singleton_exn args) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 3f252011ef..9bac6891f4 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -348,8 +348,8 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = value_kind, id, Lifthenelse - ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc), - Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc), + ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc, p_tj), + Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc, x_tj), f ), rest ) when Ident.same opt opt2 && List.mem opt params -> @@ -361,8 +361,8 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = value_kind, id, Lifthenelse - ( Lprim (p, [Lvar new_id], p_loc), - Lprim (p1, [Lvar new_id], x_loc), + ( Lprim (p, [Lvar new_id], p_loc, p_tj), + Lprim (p1, [Lvar new_id], x_loc, x_tj), f ), rest ) ) | _ -> (map, body) @@ -373,8 +373,9 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in - let rec convert_ccall (a_prim : Primitive.description) - (args : Lambda.lambda list) loc ~dynamic_import : Lam.t = + let rec convert_ccall ?(transformed_jsx = false) + (a_prim : Primitive.description) (args : Lambda.lambda list) loc + ~dynamic_import : Lam.t = let prim_name = a_prim.prim_name in match External_ffi_types.from_string a_prim.prim_native_name with | Ffi_obj_create labels -> @@ -387,8 +388,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) in let args = Ext_list.map args convert_aux in - Lam.handle_bs_non_obj_ffi arg_types result_type ffi args loc prim_name - ~dynamic_import + Lam.handle_bs_non_obj_ffi ~transformed_jsx arg_types result_type ffi args + loc prim_name ~dynamic_import | Ffi_inline_const i -> Lam.const i | Ffi_normal -> Location.raise_errorf ~loc @@ -414,11 +415,19 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let setter = Ext_string.ends_with name Literals.setter_suffix in let _ = assert (not setter) in prim ~primitive:(Pjs_unsafe_downgrade {name; setter}) ~args loc - | Lapply {ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined} -> + | Lapply + { + ap_func = fn; + ap_args = args; + ap_loc = loc; + ap_inlined; + ap_transformed_jsx; + } -> (* we need do this eargly in case [aux fn] add some wrapper *) Lam.apply (convert_aux fn) (Ext_list.map args convert_aux) {ap_loc = loc; ap_inlined; ap_status = App_uncurry} + ~ap_transformed_jsx | Lfunction {params; body; attr} -> let new_map, body = rename_optional_parameters Map_ident.empty params body @@ -439,20 +448,21 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let lam = Lam.letrec bindings body in Lam_scc.scc bindings lam body (* inlining will affect how mututal recursive behave *) - | Lprim (Prevapply, [x; f], outer_loc) | Lprim (Pdirapply, [f; x], outer_loc) - -> + | Lprim (Prevapply, [x; f], outer_loc, _) + | Lprim (Pdirapply, [f; x], outer_loc, _) -> convert_pipe f x outer_loc - | Lprim (Prevapply, _, _) -> assert false - | Lprim (Pdirapply, _, _) -> assert false - | Lprim (Pccall a, args, loc) -> convert_ccall a args loc ~dynamic_import - | Lprim (Pjs_raw_expr, args, loc) -> ( + | Lprim (Prevapply, _, _, _) -> assert false + | Lprim (Pdirapply, _, _, _) -> assert false + | Lprim (Pccall a, args, loc, transformed_jsx) -> + convert_ccall ~transformed_jsx a args loc ~dynamic_import + | Lprim (Pjs_raw_expr, args, loc, _) -> ( match args with | [Lconst (Const_base (Const_string (code, _)))] -> (* js parsing here *) let kind = Classify_function.classify code in prim ~primitive:(Praw_js_code {code; code_info = Exp kind}) ~args:[] loc | _ -> assert false) - | Lprim (Pjs_raw_stmt, args, loc) -> ( + | Lprim (Pjs_raw_stmt, args, loc, _) -> ( match args with | [Lconst (Const_base (Const_string (code, _)))] -> let kind = Classify_function.classify_stmt code in @@ -460,7 +470,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : ~primitive:(Praw_js_code {code; code_info = Stmt kind}) ~args:[] loc | _ -> assert false) - | Lprim (Pgetglobal id, args, _) -> + | Lprim (Pgetglobal id, args, _, _) -> let args = Ext_list.map args convert_aux in if Ident.is_predef_exn id then Lam.const (Const_string {s = id.name; unicode = false}) @@ -468,10 +478,10 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : may_depend may_depends (Lam_module_ident.of_ml ~dynamic_import id); assert (args = []); Lam.global_module ~dynamic_import id) - | Lprim (Pimport, args, loc) -> + | Lprim (Pimport, args, loc, _) -> let args = Ext_list.map args (convert_aux ~dynamic_import:true) in lam_prim ~primitive:Pimport ~args loc - | Lprim (primitive, args, loc) -> + | Lprim (primitive, args, loc, tj) -> let args = Ext_list.map args (convert_aux ~dynamic_import) in lam_prim ~primitive ~args loc | Lswitch (e, s, _loc) -> convert_switch e s @@ -571,8 +581,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : when Ext_list.for_all2_no_exn inner_args params lam_is_var && Ext_list.length_larger_than_n inner_args args 1 -> Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc - | Lapply {ap_func; ap_args; ap_info} -> - Lam.apply ap_func + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + Lam.apply ~ap_transformed_jsx ap_func (Ext_list.append_one ap_args x) { ap_loc = outer_loc; diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index 3beadbeb0e..1d80ae16ed 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -23,14 +23,17 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populate_apply_info (args_arity : int list) (len : int) (fn : Lam.t) - (args : Lam.t list) ap_info : Lam.t = + let rec populate_apply_info ?(ap_transformed_jsx = false) + (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) + ap_info : Lam.t = match args_arity with - | 0 :: _ | [] -> Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info + | 0 :: _ | [] -> + Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info ~ap_transformed_jsx | x :: _ -> if x = len then Lam.apply (simpl fn) (Ext_list.map args simpl) {ap_info with ap_status = App_infer_full} + ~ap_transformed_jsx else if x > len then let fn = simpl fn in let args = Ext_list.map args simpl in @@ -39,7 +42,7 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = fn args else let first, rest = Ext_list.split_at args x in - Lam.apply + Lam.apply ~ap_transformed_jsx (Lam.apply (simpl fn) (Ext_list.map first simpl) {ap_info with ap_status = App_infer_full}) (Ext_list.map rest simpl) ap_info @@ -48,13 +51,14 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match lam with | Lconst _ -> lam | Lvar _ -> lam - | Lapply {ap_func; ap_args; ap_info} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> (* detect functor application *) let args_arity = Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) in let len = List.length ap_args in - populate_apply_info args_arity len ap_func ap_args ap_info + populate_apply_info ~ap_transformed_jsx args_arity len ap_func ap_args + ap_info | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> let bindings = Ext_list.map_snd bindings simpl in diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index c55aeec841..0eddcb1a9d 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -224,8 +224,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* can we switch to the tupled backend? *\) *) (* when List.length params = List.length args -> *) (* aux (beta_reduce params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info + | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> + Lam.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx (* This kind of simple optimizations should be done each time and as early as possible *) | Lglobal_module _ -> lam diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 4a251c1877..eb54fb2067 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -52,8 +52,10 @@ let rec eliminate_ref id (lam : Lam.t) = Lam.assign id (Lam.prim ~primitive:(Poffsetint delta) ~args:[Lam.var id] loc) | Lconst _ -> lam - | Lapply {ap_func = e1; ap_args = el; ap_info} -> - Lam.apply (eliminate_ref id e1) (Ext_list.map el (eliminate_ref id)) ap_info + | Lapply {ap_func = e1; ap_args = el; ap_info; ap_transformed_jsx} -> + Lam.apply ~ap_transformed_jsx (eliminate_ref id e1) + (Ext_list.map el (eliminate_ref id)) + ap_info | Llet (str, v, e1, e2) -> Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) | Lletrec (idel, e2) -> diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index ceba4af6e5..2eb6295699 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -199,8 +199,10 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t Lam.let_ Strict y l r) | None -> Lam.staticraise i ls) | Lvar _ | Lconst _ -> lam - | Lapply {ap_func; ap_args; ap_info} -> - Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + Lam.apply (simplif ap_func) + (Ext_list.map ap_args simplif) + ap_info ~ap_transformed_jsx | Lfunction {arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index ca6e32bc7c..04ab02d4bc 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -144,8 +144,9 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (* *\) *) (* when Ext_list.same_length params args -> *) (* simplif (Lam_beta_reduce.beta_reduce params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info} -> + | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info + ~ap_transformed_jsx | Lfunction {arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Lconst _ -> lam diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 065ea65edf..67472564fe 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -140,19 +140,23 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | _ -> true) && Lam_analysis.lfunction_can_be_inlined lfunction -> simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) - | _ -> Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info) + | _ -> + Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info + ?ap_transformed_jsx:None) (* Function inlining interact with other optimizations... - parameter attributes - scope issues - code bloat *) - | Lapply {ap_func = Lvar v as fn; ap_args; ap_info} -> ( + | Lapply {ap_func = Lvar v as fn; ap_args; ap_info; ap_transformed_jsx} -> ( (* Check info for always inlining *) (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) let ap_args = Ext_list.map ap_args simpl in - let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in + let[@local] normal () = + Lam.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx + in match Hash_ident.find_opt meta.ident_tbl v with | Some (FunctionId @@ -221,8 +225,8 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* *\) *) (* when Ext_list.same_length params args -> *) (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info + | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> + Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info ~ap_transformed_jsx | Lfunction {arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simpl body) ~attr | Lswitch diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index e28c652cd9..f07b5aa024 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -46,6 +46,7 @@ type t = arg_types: External_arg_spec.params; ffi: External_ffi_types.external_spec; dynamic_import: bool; + transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params (* Exceptions *) @@ -250,7 +251,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) = | Pmakeblock (i1, info1, flag1) -> i0 = i1 && flag0 = flag1 && eq_tag_info info0 info1 | _ -> false) - | Pjs_call {prim_name; arg_types; ffi; dynamic_import} -> ( + | Pjs_call {prim_name; arg_types; ffi; dynamic_import; _} -> ( match rhs with | Pjs_call rhs -> prim_name = rhs.prim_name && arg_types = rhs.arg_types && ffi = rhs.ffi diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 460ef392c4..19b10cf964 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -42,6 +42,7 @@ type t = arg_types: External_arg_spec.params; ffi: External_ffi_types.external_spec; dynamic_import: bool; + transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params | Praise diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 7ea859f6be..f85cdc0f41 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -66,7 +66,7 @@ let refine_let (* let v= subst_lambda (Map_ident.singleton param arg ) l in *) (* Ext_log.err "@[substitution << @]@."; *) (* v *) - | _, _, Lapply {ap_func=fn; ap_args = [Lvar w]; ap_info} when + | _, _, Lapply {ap_func=fn; ap_args = [Lvar w]; ap_info; ap_transformed_jsx} when Ident.same w param && (not (Lam_hit.hit_variable param fn )) -> @@ -79,7 +79,7 @@ let refine_let ]} #1667 make sure body does not hit k *) - Lam.apply fn [arg] ap_info + Lam.apply fn [arg] ap_info ~ap_transformed_jsx | (Strict | StrictOpt ), ( Lvar _ | Lconst _ | Lprim {primitive = Pfield (_ , Fld_module _) ; diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index fea0b53f1d..0fd5bd585d 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -65,7 +65,8 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none ) + Location.none, + false ) in Ext_list.fold_left rest init (fun acc (hash, name) -> Lambda.Lprim @@ -75,9 +76,11 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none ); + Location.none, + false ); ], - Location.none )) + Location.none, + false )) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -111,5 +114,5 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, false), call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index 04a1be4f4a..0610abb015 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -44,6 +44,7 @@ let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) funct = fn; args = Ext_list.map args (fun x -> (Asttypes.Nolabel, x)); partial = false; + transformed_jsx = false; }; } @@ -52,7 +53,13 @@ let app1 ?(loc = default_loc) ?(attrs = []) fn arg1 : expression = pexp_loc = loc; pexp_attributes = attrs; pexp_desc = - Pexp_apply {funct = fn; args = [(Nolabel, arg1)]; partial = false}; + Pexp_apply + { + funct = fn; + args = [(Nolabel, arg1)]; + partial = false; + transformed_jsx = false; + }; } let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = @@ -61,7 +68,12 @@ let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = pexp_attributes = attrs; pexp_desc = Pexp_apply - {funct = fn; args = [(Nolabel, arg1); (Nolabel, arg2)]; partial = false}; + { + funct = fn; + args = [(Nolabel, arg1); (Nolabel, arg2)]; + partial = false; + transformed_jsx = false; + }; } let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = @@ -74,6 +86,7 @@ let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = funct = fn; args = [(Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3)]; partial = false; + transformed_jsx = false; }; } @@ -121,6 +134,7 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn Ext_list.map args (fun (l, a) -> (Asttypes.Labelled {txt = l; loc = Location.none}, a)); partial = false; + transformed_jsx = false; }; } diff --git a/compiler/frontend/ast_exp_apply.ml b/compiler/frontend/ast_exp_apply.ml index fb5b500db9..afffea4e3c 100644 --- a/compiler/frontend/ast_exp_apply.ml +++ b/compiler/frontend/ast_exp_apply.ml @@ -88,11 +88,12 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) : exp = {f with pexp_desc = Pexp_variant (label, Some a); pexp_loc = e.pexp_loc} | Pexp_construct (ctor, None) -> {f with pexp_desc = Pexp_construct (ctor, Some a); pexp_loc = e.pexp_loc} - | Pexp_apply {funct = fn1; args; partial} -> + | Pexp_apply {funct = fn1; args; partial; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes fn1.pexp_attributes; { pexp_desc = - Pexp_apply {funct = fn1; args = (Nolabel, a) :: args; partial}; + Pexp_apply + {funct = fn1; args = (Nolabel, a) :: args; partial; transformed_jsx}; pexp_loc = e.pexp_loc; pexp_attributes = e.pexp_attributes @ f.pexp_attributes; } @@ -108,7 +109,7 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) : exp = fn with pexp_desc = Pexp_construct (ctor, Some bounded_obj_arg); } - | Pexp_apply {funct = fn; args} -> + | Pexp_apply {funct = fn; args; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes fn.pexp_attributes; { @@ -118,6 +119,7 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) : exp = funct = fn; args = (Nolabel, bounded_obj_arg) :: args; partial = false; + transformed_jsx; }; pexp_attributes = []; pexp_loc = fn.pexp_loc; diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index 70e4e2d550..9e0a43fe37 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -75,4 +75,5 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label [Typ.any ~loc ()]) ); ]; partial = false; + transformed_jsx = false; } diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 72799db97b..cf684bdd30 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -330,8 +330,8 @@ module E = struct fun_ ~loc ~attrs ~arity ~async lab (map_opt (sub.expr sub) def) (sub.pat sub p) (sub.expr sub e) - | Pexp_apply {funct = e; args = l; partial} -> - apply ~loc ~attrs ~partial (sub.expr sub e) + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> + apply ~loc ~attrs ~partial ~transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index d4de7ff0e9..121bea0c1f 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -154,8 +154,9 @@ module Exp = struct let fun_ ?loc ?attrs ?(async = false) ~arity a b c d = mk ?loc ?attrs (Pexp_fun {arg_label = a; default = b; lhs = c; rhs = d; arity; async}) - let apply ?loc ?attrs ?(partial = false) funct args = - mk ?loc ?attrs (Pexp_apply {funct; args; partial}) + let apply ?loc ?attrs ?(partial = false) ?(transformed_jsx = false) funct args + = + mk ?loc ?attrs (Pexp_apply {funct; args; partial; transformed_jsx}) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 10677c31b2..bbcf4471a3 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -149,6 +149,7 @@ module Exp : sig ?loc:loc -> ?attrs:attrs -> ?partial:bool -> + ?transformed_jsx:bool -> expression -> (arg_label * expression) list -> expression diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 992d1a9816..67c757d685 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -293,8 +293,8 @@ module E = struct fun_ ~loc ~attrs ~arity ~async lab (map_opt (sub.expr sub) def) (sub.pat sub p) (sub.expr sub e) - | Pexp_apply {funct = e; args = l; partial} -> - apply ~loc ~attrs ~partial (sub.expr sub e) + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> + apply ~loc ~attrs ~partial ~transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 26aa8a8c74..0692f0aedb 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -357,7 +357,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t + | Lprim of primitive * lambda list * Location.t * bool | Lswitch of lambda * lambda_switch * Location.t | Lstringswitch of lambda * (string * lambda) list * lambda option * Location.t @@ -383,6 +383,7 @@ and lambda_apply = { ap_args: lambda list; ap_loc: Location.t; ap_inlined: inline_attribute; + ap_transformed_jsx: bool; } and lambda_switch = { @@ -461,7 +462,7 @@ let make_key e = let ex = tr_rec env ex in let y = make_key x in Llet (str, k, y, ex, tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p, es, _) -> Lprim (p, tr_recs env es, Location.none) + | Lprim (p, es, _, tj) -> Lprim (p, tr_recs env es, Location.none, tj) | Lswitch (e, sw, loc) -> Lswitch (tr_rec env e, tr_sw env sw, loc) | Lstringswitch (e, sw, d, _) -> Lstringswitch @@ -519,7 +520,7 @@ let iter f = function | Lletrec (decl, body) -> f body; List.iter (fun (_id, exp) -> f exp) decl - | Lprim (_p, args, _loc) -> List.iter f args + | Lprim (_p, args, _loc, _tj) -> List.iter f args | Lswitch (arg, sw, _) -> f arg; List.iter (fun (_key, case) -> f case) sw.sw_consts; @@ -617,13 +618,14 @@ let rec patch_guarded patch = function let rec transl_normal_path = function | Path.Pident id -> - if Ident.global id then Lprim (Pgetglobal id, [], Location.none) + if Ident.global id then Lprim (Pgetglobal id, [], Location.none, false) else Lvar id | Pdot (p, s, pos) -> Lprim ( Pfield (pos, Fld_module {name = s}), [transl_normal_path p], - Location.none ) + Location.none, + false ) | Papply _ -> assert false (* Translation of identifiers *) @@ -657,7 +659,7 @@ let subst_lambda s lam = Lfunction {params; body = subst body; attr; loc} | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) - | Lprim (p, args, loc) -> Lprim (p, List.map subst args, loc) + | Lprim (p, args, loc, tj) -> Lprim (p, List.map subst args, loc, tj) | Lswitch (arg, sw, loc) -> Lswitch ( subst arg, diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 9e1c9b9d7c..12ff51c086 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -324,7 +324,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t + | Lprim of primitive * lambda list * Location.t * bool | Lswitch of lambda * lambda_switch * Location.t (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) @@ -352,6 +352,7 @@ and lambda_apply = { ap_args: lambda list; ap_loc: Location.t; ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) + ap_transformed_jsx: bool; } and lambda_switch = { diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index fd90f38535..dde5d74a62 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1194,7 +1194,7 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl else - (Lprim (Pfield (pos, fld_info), [arg], loc), binding_kind) + (Lprim (Pfield (pos, fld_info), [arg], loc, false), binding_kind) :: make_args (pos + 1) in make_args first_pos @@ -1277,7 +1277,7 @@ let make_constr_matching p def ctx = function Pval_from_option_not_nest | _ -> Pval_from_option in - (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl + (Lprim (from_option, [arg], p.pat_loc, false), Alias) :: argl | Cstr_constant _ | Cstr_block _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) @@ -1336,7 +1336,8 @@ let make_variant_matching_nonconst p lab def ctx = function { cases = []; args = - (Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) + ( Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc, false), + Alias ) :: argl; default = def; }; @@ -1426,8 +1427,9 @@ let get_mod_field modname field = in Lprim ( Pfield (p, Fld_module {name = field}), - [Lprim (Pgetglobal mod_ident, [], Location.none)], - Location.none ) + [Lprim (Pgetglobal mod_ident, [], Location.none, false)], + Location.none, + false ) with Not_found -> fatal_error ("Module " ^ modname ^ " unavailable.")) let code_force = get_mod_field Primitive_modules.lazy_ "force" @@ -1449,6 +1451,7 @@ let inline_lazy_force arg loc = ap_inlined = Default_inline; ap_args = [arg]; ap_loc = loc; + ap_transformed_jsx = false; } let make_lazy_matching def = function | [] -> fatal_error "Matching.make_lazy_matching" @@ -1483,7 +1486,7 @@ let make_tuple_matching loc arity def = function let rec make_args pos = if pos >= arity then argl else - (Lprim (Pfield (pos, Fld_tuple), [arg], loc), Alias) + (Lprim (Pfield (pos, Fld_tuple), [arg], loc, false), Alias) :: make_args (pos + 1) in { @@ -1532,16 +1535,21 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc, false) | Record_inlined _ -> Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) + ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), + [arg], + loc, + false ) | Record_unboxed _ -> arg | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], - loc ) + loc, + false ) in let str = match lbl.lbl_mut with @@ -1586,7 +1594,10 @@ let make_array_matching p def ctx = function if pos >= len then argl else ( Lprim - (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc), + ( Parrayrefu, + [arg; Lconst (Const_base (Const_int pos))], + p.pat_loc, + false ), StrictOpt ) :: make_args (pos + 1) in @@ -1638,7 +1649,8 @@ let make_string_test_sequence loc arg sw d = List.fold_right (fun (s, lam) k -> Lifthenelse - ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc), + ( Lprim + (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc, false), k, lam )) sw d) @@ -1656,9 +1668,9 @@ let zero_lam = Lconst (Const_base (Const_int 0)) let tree_way_test loc arg lt eq gt = Lifthenelse - ( Lprim (Pintcomp Clt, [arg; zero_lam], loc), + ( Lprim (Pintcomp Clt, [arg; zero_lam], loc, false), lt, - Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc), gt, eq) ) + Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc, false), gt, eq) ) (* Dichotomic tree *) @@ -1669,7 +1681,7 @@ let rec do_make_string_test_tree loc arg sw delta d = else let lt, (s, act), gt = split len sw in bind_sw - (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc)) + (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc, false)) (fun r -> tree_way_test loc r (do_make_string_test_tree loc arg lt delta d) @@ -1756,7 +1768,7 @@ let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc, false), do_tests_fail loc fail tst arg rem, act ) @@ -1765,7 +1777,7 @@ let rec do_tests_nofail loc tst arg = function | [(_, act)] -> act | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc, false), do_tests_nofail loc tst arg rem, act ) @@ -1785,7 +1797,8 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse - ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc), + ( Lprim + (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc, false), make_test_sequence list1, make_test_sequence list2 ) in @@ -1803,11 +1816,11 @@ module SArg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p, args, Location.none) + let make_prim p args = Lprim (p, args, Location.none, false) let make_offset arg n = match n with | 0 -> arg - | _ -> Lprim (Poffsetint n, [arg], Location.none) + | _ -> Lprim (Poffsetint n, [arg], Location.none, false) let bind arg body = let newvar, newarg = @@ -1819,8 +1832,8 @@ module SArg = struct in bind Alias newvar arg (body newarg) let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) - let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) + let make_isout h arg = Lprim (Pisout, [h; arg], Location.none, false) + let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none, false) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch loc arg cases acts ~offset sw_names = let l = ref [] in @@ -2215,7 +2228,9 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in Lifthenelse - (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc), act, rem)) + ( Lprim (Pextension_slot_eq, [Lvar tag; ext], loc, false), + act, + rem )) extension_cases default in Llet (Alias, Pgenval, tag, arg, tests) @@ -2245,9 +2260,13 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def case *) let arg = if Datarepr.constructor_has_optional_shape cstr then - Lprim (Pis_not_none, [arg], loc) + Lprim (Pis_not_none, [arg], loc, false) else - Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) + Lprim + ( Pjscomp Cneq, + [arg; Lconst (Const_base (Const_int 0))], + loc, + false ) in Lifthenelse (arg, act2, act1) | 2, 0, [(i1, act1); (_, act2)], [] @@ -2271,7 +2290,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def match act0 with | Some act when false (* relies on tag being an int *) -> Lifthenelse - ( Lprim (Pisint, [arg], loc), + ( Lprim (Pisint, [arg], loc, false), call_switcher loc fail_opt arg 0 (n - 1) consts sw_names, act ) (* Emit a switch, as bytecode implements this sophisticated instruction *) @@ -2310,7 +2329,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list names = ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, false), call_switcher loc fail (Lvar v) min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) names ) @@ -2356,7 +2375,7 @@ let combine_variant names loc row arg partial ctx def row.row_fields else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) + Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc, false), if_block, if_int) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in @@ -2406,7 +2425,7 @@ let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats) let switch = call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list names in - bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch + bind Alias newvar (Lprim (Parraylength, [arg], loc, false)) switch in (lambda1, jumps_union local_jumps total1) @@ -2487,7 +2506,7 @@ let compile_test compile_fun partial divide combine ctx to_match = let rec approx_present v = function | Lconst _ -> false | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args - | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args + | Lprim (_, args, _, _) -> List.exists (fun lam -> approx_present v lam) args | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2834,9 +2853,11 @@ let partial_function loc () = Const_base (Const_int char); ] )); ], - loc ); + loc, + false ); ], - loc ) + loc, + false ) let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2844,7 +2865,7 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = compile_matching None - (fun () -> Lprim (Praise Raise_reraise, [param], Location.none)) + (fun () -> Lprim (Praise Raise_reraise, [param], Location.none, false)) param pat_act_list Partial let simple_for_let loc param pat body = @@ -3011,14 +3032,14 @@ let do_for_multiple_match loc paraml pat_act_list partial = ( raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, false), Strict)]; default = [([[omega]], raise_num)]; } ) | _ -> ( -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, false), Strict)]; default = []; } ) in diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 5c47210630..5184b9f674 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -244,6 +244,7 @@ and expression_desc = funct: expression; args: (arg_label * expression) list; partial: bool; + transformed_jsx: bool; } (* E0 ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 380939b15b..48429c34d0 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -251,11 +251,12 @@ and expression i ppf x = option i expression ppf eo; pattern i ppf p; expression i ppf e - | Pexp_apply {funct = e; args = l; partial} -> + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> line i ppf "Pexp_apply\n"; if partial then line i ppf "partial\n"; expression i ppf e; - list i label_x_expression ppf l + list i label_x_expression ppf l; + line i ppf "transformed_jsx: %b\n" transformed_jsx | Pexp_match (e, l) -> line i ppf "Pexp_match\n"; expression i ppf e; diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index f0ad4698bb..e069e7173b 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -319,7 +319,7 @@ let rec lam ppf = function in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim (prim, largs, _) -> + | Lprim (prim, largs, _, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs | Lswitch (larg, sw, _loc) -> diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 8064d65990..c2e33e7b4f 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -199,12 +199,13 @@ let expr sub x = | Texp_function {arg_label; arity; param; case; partial; async} -> Texp_function {arg_label; arity; param; case = sub.case sub case; partial; async} - | Texp_apply {funct = exp; args = list; partial} -> + | Texp_apply {funct = exp; args = list; partial; transformed_jsx} -> Texp_apply { funct = sub.expr sub exp; args = List.map (tuple2 id (opt (sub.expr sub))) list; partial; + transformed_jsx; } | Texp_match (exp, cases, exn_cases, p) -> Texp_match diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 17aa511aa2..8a6acad180 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -151,7 +151,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = ( Strict, Pgenval, id, - Lprim (Pinit_mod, [loc; shape], Location.none), + Lprim (Pinit_mod, [loc; shape], Location.none, false), bind_inits rem acc ) in let rec bind_strict args acc = @@ -167,7 +167,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (_id, None, _rhs) :: rem -> patch_forwards rem | (id, Some (_loc, shape), rhs) :: rem -> Lsequence - ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none), + ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none, false), patch_forwards rem ) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) @@ -178,7 +178,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = *) let rec is_function_or_const_block (lam : Lambda.lambda) acc = match lam with - | Lprim (Pmakeblock _, args, _) -> + | Lprim (Pmakeblock _, args, _, _) -> Ext_list.for_all args (fun x -> match x with | Lvar id -> Set_ident.mem acc id diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index ed63ecbdf1..800d630d0c 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -76,8 +76,8 @@ let rec add_inline_attribute (expr : Lambda.lambda) loc attributes = Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); let attr = {attr with inline} in Lfunction {funct with attr} - | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l), _ -> - Lambda.Lprim (p, [add_inline_attribute e loc attributes], l) + | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l, tj), _ -> + Lambda.Lprim (p, [add_inline_attribute e loc attributes], l, tj) | expr, Always_inline -> Location.prerr_warning loc (Warnings.Misplaced_attribute "inline1"); expr diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 4cdeb34aa5..7c9a50731e 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -44,7 +44,7 @@ let transl_extension_constructor env path ext = in let loc = ext.ext_loc in match ext.ext_kind with - | Text_decl _ -> Lprim (Pcreate_extension name, [], loc) + | Text_decl _ -> Lprim (Pcreate_extension name, [], loc, false) | Text_rebind (path, _lid) -> transl_extension_path ~loc env path (* Translation of primitives *) @@ -460,7 +460,7 @@ let transl_primitive loc p env ty = params = [param]; attr = default_function_attribute; loc; - body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); + body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc, false); } | _ -> assert false) | _ -> @@ -471,7 +471,8 @@ let transl_primitive loc p env ty = :: make_params (n - 1) total in let prim_arity = p.prim_arity in - if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) + if p.prim_from_constructor || prim_arity = 0 then + Lprim (prim, [], loc, false) else let params = if prim_arity = 1 then [Ident.create "prim"] @@ -482,7 +483,7 @@ let transl_primitive loc p env ty = params; attr = default_function_attribute; loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); + body = Lprim (prim, List.map (fun id -> Lvar id) params, loc, false); } let transl_primitive_application loc prim env ty args = @@ -629,9 +630,11 @@ let assert_failed exp = Const_base (Const_int char); ] )); ], - exp.exp_loc ); + exp.exp_loc, + false ); ], - exp.exp_loc ) + exp.exp_loc, + false ) let rec cut n l = if n = 0 then ([], l) @@ -700,7 +703,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim ( prim (* could be replaced with Opaque in the future except arity 0*), [lambda], - loc ) + loc, + false ) | None -> lambda) | Texp_apply { @@ -710,6 +714,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = exp_type = prim_type; } as funct; args = oargs; + transformed_jsx; } when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg) -> arg <> None) oargs -> ( @@ -720,7 +725,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let inlined, _ = Translattribute.get_and_remove_inlined_attribute funct in - transl_apply ~inlined f args' e.exp_loc + transl_apply ~inlined ~transformed_jsx f args' e.exp_loc in let args = List.map @@ -741,16 +746,16 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> Raise_reraise | _ -> k in - wrap (Lprim (Praise k, [targ], e.exp_loc)) + wrap (Lprim (Praise k, [targ], e.exp_loc, transformed_jsx)) | Ploc kind, [] -> lam_of_loc kind e.exp_loc | Ploc kind, [arg1] -> let lam = lam_of_loc kind arg1.exp_loc in - Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) + Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc, transformed_jsx) | Ploc _, _ -> assert false | _, _ -> ( match (prim, argl) with - | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) - | Texp_apply {funct; args = oargs; partial} -> + | _ -> wrap (Lprim (prim, argl, e.exp_loc, transformed_jsx)))) + | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in @@ -766,8 +771,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | None -> None else None in - transl_apply ~inlined ~uncurried_partial_application (transl_exp funct) - oargs e.exp_loc + transl_apply ~inlined ~uncurried_partial_application ~transformed_jsx + (transl_exp funct) oargs e.exp_loc | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) -> transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try (body, pat_expr_list) -> @@ -779,7 +784,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_tuple el -> ( let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) + with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc, false)) | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true | Texp_construct (lid, cstr, args) -> ( @@ -834,12 +839,13 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) + with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc, false)) | Cstr_extension path -> Lprim ( Pmakeblock Blk_extension, transl_extension_path e.exp_env path :: ll, - e.exp_loc )) + e.exp_loc, + false )) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( let tag = Btype.hash_variant l in @@ -856,7 +862,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim ( Pmakeblock tag_info, [Lconst (Const_base (Const_int tag)); lam], - e.exp_loc ))) + e.exp_loc, + false ))) | Texp_record {fields; representation; extended_expression} -> transl_record e.exp_loc e.exp_env fields representation extended_expression | Texp_field (arg, _, lbl) -> ( @@ -864,16 +871,21 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc, false) | Record_inlined _ -> Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc) + ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), + [targ], + e.exp_loc, + false ) | Record_unboxed _ -> targ | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [targ], - e.exp_loc )) + e.exp_loc, + false )) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with @@ -885,10 +897,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc) + Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc, false) | Texp_array expr_list -> let ll = transl_list expr_list in - Lprim (Pmakearray Mutable, ll, e.exp_loc) + Lprim (Pmakearray Mutable, ll, e.exp_loc, false) | Texp_ifthenelse (cond, ifso, Some ifnot) -> Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> @@ -922,7 +934,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would do *) - Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc) + Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc, false) and transl_list expr_list = List.map transl_exp expr_list @@ -948,9 +960,17 @@ and transl_case_try {c_lhs; c_guard; c_rhs} = and transl_cases_try cases = List.map transl_case_try cases and transl_apply ?(inlined = Default_inline) - ?(uncurried_partial_application = None) lam sargs loc = + ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs + loc = let lapply ap_func ap_args = - Lapply {ap_loc = loc; ap_func; ap_args; ap_inlined = inlined} + Lapply + { + ap_loc = loc; + ap_func; + ap_args; + ap_inlined = inlined; + ap_transformed_jsx = transformed_jsx; + } in let rec build_apply lam args = function | (None, optional) :: l -> @@ -1008,7 +1028,14 @@ and transl_apply ?(inlined = Default_inline) let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in let ap_args = args @ extra_args in let l0 = - Lapply {ap_func = lam; ap_args; ap_inlined = inlined; ap_loc = loc} + Lapply + { + ap_func = lam; + ap_args; + ap_inlined = inlined; + ap_loc = loc; + ap_transformed_jsx = transformed_jsx; + } in Lfunction { @@ -1097,7 +1124,8 @@ and transl_record loc env fields repres opt_init_expr = ( Pjs_fn_make arity, (* could be replaced with Opaque in the future except arity 0*) [lambda], - loc ) + loc, + false ) else lambda | _ -> ( let size = Array.length fields in @@ -1134,7 +1162,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lprim (access, [Lvar init_id], loc) + Lprim (access, [Lvar init_id], loc, false) | Overridden (_lid, expr) -> transl_exp expr) fields in @@ -1167,7 +1195,7 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) + Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc, false) | Record_float_unused -> assert false | Record_inlined {tag; name; num_nonconsts; attrs} -> Lprim @@ -1175,7 +1203,8 @@ and transl_record loc env fields repres opt_init_expr = (Lambda.blk_record_inlined fields name num_nonconsts ~tag ~attrs mut), ll, - loc ) + loc, + false ) | Record_unboxed _ -> ( match ll with | [v] -> v @@ -1189,7 +1218,10 @@ and transl_record loc env fields repres opt_init_expr = in let slot = transl_extension_path env path in Lprim - (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc)) + ( Pmakeblock (Lambda.blk_record_ext fields mut), + slot :: ll, + loc, + false )) in match opt_init_expr with | None -> lam @@ -1214,7 +1246,8 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc), cont) + Lsequence + (Lprim (upd, [Lvar copy_id; transl_exp expr], loc, false), cont) in match opt_init_expr with | None -> assert false @@ -1223,7 +1256,7 @@ and transl_record loc env fields repres opt_init_expr = ( Strict, Pgenval, copy_id, - Lprim (Pduprecord, [transl_exp init_expr], loc), + Lprim (Pduprecord, [transl_exp init_expr], loc, false), Array.fold_left update_field (Lvar copy_id) fields )) and transl_match e arg pat_expr_list exn_pat_expr_list partial = diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index f815a536c0..0b06c7b890 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -64,15 +64,17 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> Lambda.name_lambda strict arg (fun id -> let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc) + Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc, false) in let lam = Lambda.Lprim ( Pmakeblock (Blk_module runtime_fields), Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> apply_coercion loc Alias cc - (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc))), - loc ) + (Lprim + (Pfield (pos, Fld_module {name}), [Lvar id], loc, false))), + loc, + false ) in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> @@ -100,6 +102,7 @@ and apply_coercion_result loc strict funct param arg cc_res = ap_func = Lvar id; ap_args = [arg]; ap_inlined = Default_inline; + ap_transformed_jsx = false; }); }) @@ -276,6 +279,7 @@ and transl_module cc rootpath mexp = ap_func = transl_module Tcoerce_none None funct; ap_args = [transl_module ccarg None arg]; ap_inlined = inlined_attribute; + ap_transformed_jsx = false; }) | Tmod_constraint (arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg @@ -304,7 +308,8 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), block_fields, - loc ), + loc, + false ), List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -340,7 +345,8 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module runtime_fields), result, - loc ) + loc, + false ) and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> not (Lambda.IdentSet.mem id ids)) @@ -432,7 +438,8 @@ and transl_structure loc fields cc rootpath final_env = function Lprim ( Pfield (pos, Fld_module {name = Ident.name id}), [Lvar mid], - incl.incl_loc ), + incl.incl_loc, + false ), body ), size ) in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index d1e593607f..a7ac76a341 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2401,7 +2401,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp type_function ?in_function ~arity ~async loc sexp.pexp_attributes env ty_expected l [Ast_helper.Exp.case spat sbody] - | Pexp_apply {funct = sfunct; args = sargs; partial} -> + | Pexp_apply {funct = sfunct; args = sargs; partial; transformed_jsx} -> assert (sargs <> []); begin_def (); (* one more level for non-returning functions *) @@ -2423,7 +2423,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let mk_apply funct args = rue { - exp_desc = Texp_apply {funct; args; partial}; + exp_desc = Texp_apply {funct; args; partial; transformed_jsx}; exp_loc = loc; exp_extra = []; exp_type = ty_res; diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 626950caec..f9769ee13b 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -87,6 +87,7 @@ and expression_desc = funct: expression; args: (Noloc.arg_label * expression option) list; partial: bool; + transformed_jsx: bool; } | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 96da873af0..f3368c9539 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -150,6 +150,7 @@ and expression_desc = funct: expression; args: (Noloc.arg_label * expression option) list; partial: bool; + transformed_jsx: bool; } (** E0 ~l1:E1 ... ~ln:En diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index febc245f21..89bb301f2d 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1208,7 +1208,7 @@ let append_children_prop (config : Jsx_common.jsx_config) mapper Exp.apply (Exp.ident {txt = Ldot (element_binding, "someElement"); loc = Location.none}) - [(Nolabel, child)] + [(Nolabel, mapper.expr mapper child)] in let is_optional = match component_description with @@ -1277,7 +1277,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in - Exp.apply ~loc ~attrs jsx_expr args + Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args (* In most situations, the component name is the make function from a module. However, if the name contains a lowercase letter, it means it probably an external component. diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 03ed02f450..0078dcabc1 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -2188,12 +2188,18 @@ and parse_binary_expr ?(context = OrdinaryExpr) ?a p prec = let loc = mk_loc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in let expr = match (token, b.pexp_desc) with - | BarGreater, Pexp_apply {funct = fun_expr; args; partial} -> + | ( BarGreater, + Pexp_apply {funct = fun_expr; args; partial; transformed_jsx} ) -> { b with pexp_desc = Pexp_apply - {funct = fun_expr; args = args @ [(Nolabel, a)]; partial}; + { + funct = fun_expr; + args = args @ [(Nolabel, a)]; + partial; + transformed_jsx; + }; } | BarGreater, _ -> Ast_helper.Exp.apply ~loc b [(Nolabel, a)] | _ -> diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 5305bd3fc2..8abb4155f9 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -142,7 +142,13 @@ let rewrite_underscore_apply expr = { e with pexp_desc = - Pexp_apply {funct = call_expr; args = new_args; partial = false}; + Pexp_apply + { + funct = call_expr; + args = new_args; + partial = false; + transformed_jsx = false; + }; } | _ -> expr