From cda8cd64b7a19ead9dd93e6e4a73ccccfa8be44d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 23 Sep 2025 16:00:32 +0200 Subject: [PATCH 1/7] Implement typed Option stdlib optimizations # Conflicts: # packages/@rescript/runtime/Stdlib_DataView.resi --- compiler/frontend/ast_option_optimizations.ml | 126 ------------------ .../frontend/ast_option_optimizations.mli | 1 - compiler/frontend/bs_builtin_ppx.ml | 3 +- compiler/ml/printtyped.ml | 10 ++ compiler/ml/tast_iterator.ml | 7 +- compiler/ml/tast_mapper.ml | 15 +++ compiler/ml/translcore.ml | 80 ++++++++++- compiler/ml/typecore.ml | 99 +++++++++++++- compiler/ml/typedtree.ml | 16 +++ compiler/ml/typedtree.mli | 16 +++ compiler/ml/typedtreeIter.ml | 10 +- tests/tests/src/core/Core_ObjectTests.mjs | 5 +- tests/tests/src/core/intl/Core_IntlTests.mjs | 4 +- .../src/option_stdlib_optimization_test.mjs | 10 +- tests/tests/src/reactTestUtils.mjs | 12 +- 15 files changed, 261 insertions(+), 153 deletions(-) delete mode 100644 compiler/frontend/ast_option_optimizations.ml delete mode 100644 compiler/frontend/ast_option_optimizations.mli diff --git a/compiler/frontend/ast_option_optimizations.ml b/compiler/frontend/ast_option_optimizations.ml deleted file mode 100644 index 4ca14651db..0000000000 --- a/compiler/frontend/ast_option_optimizations.ml +++ /dev/null @@ -1,126 +0,0 @@ -open Parsetree -open Longident - -(* - Optimise calls to Option.forEach/map/flatMap so they produce the same switch - structure as handwritten code. We only rewrite calls whose callback is a - simple literal lambda or identifier; more complex callbacks are left intact - to preserve ReScript's call-by-value semantics. -*) - -let value_name = "__res_option_value" - -type option_call = ForEach | Map | FlatMap - -(* Inlineable callbacks are bare identifiers (possibly wrapped in coercions or - type annotations). Those can be applied directly inside the emitted switch - without introducing a let-binding that might change evaluation behaviour. *) -let rec callback_is_inlineable expr = - match expr.pexp_desc with - | Pexp_ident _ -> true - | Pexp_constraint (inner, _) | Pexp_coerce (inner, _, _) -> - callback_is_inlineable inner - | _ -> false - -(* Detect literal lambdas (ignoring type annotations) so we can reuse their - argument binder in the rewritten switch. *) -let rec inline_lambda expr = - match expr.pexp_desc with - | Pexp_constraint (inner, _) | Pexp_coerce (inner, _, _) -> - inline_lambda inner - | Pexp_fun {arg_label = Asttypes.Nolabel; lhs; rhs; async = false} -> - Some (lhs, rhs) - | _ -> None - -let transform (expr : Parsetree.expression) : Parsetree.expression = - match expr.pexp_desc with - | Pexp_apply - { - funct = - { - pexp_desc = - Pexp_ident - {txt = Ldot (Lident ("Option" | "Stdlib_Option"), fname)}; - }; - args = [(_, opt_expr); (_, func_expr)]; - } -> ( - let call_kind = - match fname with - | "forEach" -> Some ForEach - | "map" -> Some Map - | "flatMap" -> Some FlatMap - | _ -> None - in - match call_kind with - | None -> expr - | Some call_kind -> ( - let loc_ghost = {expr.pexp_loc with loc_ghost = true} in - let emit_option_match value_pat result_expr = - let some_rhs = - match call_kind with - | ForEach | FlatMap -> result_expr - | Map -> - Ast_helper.Exp.construct ~loc:loc_ghost - {txt = Lident "Some"; loc = loc_ghost} - (Some result_expr) - in - let none_rhs = - match call_kind with - | ForEach -> - Ast_helper.Exp.construct ~loc:loc_ghost - {txt = Lident "()"; loc = loc_ghost} - None - | Map | FlatMap -> - Ast_helper.Exp.construct ~loc:loc_ghost - {txt = Lident "None"; loc = loc_ghost} - None - in - let mk_case ctor payload rhs = - { - Parsetree.pc_bar = None; - pc_lhs = - Ast_helper.Pat.construct ~loc:loc_ghost - {txt = Lident ctor; loc = loc_ghost} - payload; - pc_guard = None; - pc_rhs = rhs; - } - in - let some_case = mk_case "Some" (Some value_pat) some_rhs in - let none_case = mk_case "None" None none_rhs in - let transformed = - Ast_helper.Exp.match_ ~loc:loc_ghost opt_expr [some_case; none_case] - in - { - transformed with - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - } - in - match inline_lambda func_expr with - (* Literal lambda with a simple binder: reuse the binder directly inside - the generated switch, so the body runs exactly once with the option's - payload. *) - | Some ({ppat_desc = Parsetree.Ppat_var {txt}}, body) -> - let value_pat = - Ast_helper.Pat.var ~loc:loc_ghost {txt; loc = loc_ghost} - in - emit_option_match value_pat body - (* Callback is a simple identifier (possibly annotated). Apply it inside - the switch so evaluation order matches handwritten code. *) - | _ when callback_is_inlineable func_expr -> - let value_pat = - Ast_helper.Pat.var ~loc:loc_ghost {txt = value_name; loc = loc_ghost} - in - let value_ident = - Ast_helper.Exp.ident ~loc:loc_ghost - {txt = Lident value_name; loc = loc_ghost} - in - let apply_callback = - Ast_helper.Exp.apply ~loc:loc_ghost func_expr - [(Asttypes.Nolabel, value_ident)] - in - emit_option_match value_pat apply_callback - (* Complex callbacks are left as-is so we don't change when they run. *) - | _ -> expr)) - | _ -> expr diff --git a/compiler/frontend/ast_option_optimizations.mli b/compiler/frontend/ast_option_optimizations.mli deleted file mode 100644 index 84ee077695..0000000000 --- a/compiler/frontend/ast_option_optimizations.mli +++ /dev/null @@ -1 +0,0 @@ -val transform : Parsetree.expression -> Parsetree.expression diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 3777aa37c6..08ec91fc62 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -112,8 +112,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) body; pexp_attributes; }) - | Pexp_apply _ -> - Ast_exp_apply.app_exp_mapper e self |> Ast_option_optimizations.transform + | Pexp_apply _ -> Ast_exp_apply.app_exp_mapper e self | Pexp_match ( b, [ diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 064f0ab55c..29b18cc823 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -260,6 +260,16 @@ and expression_extra i ppf x attrs = | Texp_newtype s -> line i ppf "Texp_newtype \"%s\"\n" s; attributes i ppf attrs + | Texp_stdlib_option_call {call_kind; payload_not_nested; _} -> + let kind = + match call_kind with + | Stdlib_option_forEach -> "forEach" + | Stdlib_option_map {result_cannot_contain_undefined = _} -> "map" + | Stdlib_option_flatMap -> "flatMap" + in + line i ppf "Texp_stdlib_option_call %s payload_not_nested=%b\n" kind + payload_not_nested; + attributes i ppf attrs and expression i ppf x = line i ppf "expression %a\n" fmt_location x.exp_loc; diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 5c12d3da4d..b0913a6e61 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -137,11 +137,16 @@ let pat sub {pat_extra; pat_desc; pat_env; _} = | Tpat_alias (p, _, _) -> sub.pat sub p let expr sub {exp_extra; exp_desc; exp_env; _} = - let extra = function + let rec extra = function | Texp_constraint cty -> sub.typ sub cty | Texp_coerce cty2 -> sub.typ sub cty2 | Texp_newtype _ -> () | Texp_open (_, _, _, _) -> () + | Texp_stdlib_option_call info -> stdlib_option_call info + and stdlib_option_call {callback; _} = stdlib_option_callback callback + and stdlib_option_callback = function + | Stdlib_option_inline_lambda {body; _} -> sub.expr sub body + | Stdlib_option_inline_ident expr -> sub.expr sub expr in List.iter (fun (e, _, _) -> extra e) exp_extra; sub.env sub exp_env; diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 54eba02869..27fe9d89c6 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -180,12 +180,27 @@ let pat sub x = {x with pat_extra; pat_desc; pat_env} let expr sub x = + let map_stdlib_option_callback sub = function + | Stdlib_option_inline_lambda {param; body} -> + Stdlib_option_inline_lambda {param; body = sub.expr sub body} + | Stdlib_option_inline_ident expr -> + Stdlib_option_inline_ident (sub.expr sub expr) + in + let map_stdlib_option_call sub {callback; call_kind; payload_not_nested} = + { + callback = map_stdlib_option_callback sub callback; + call_kind; + payload_not_nested; + } + in let extra = function | Texp_constraint cty -> Texp_constraint (sub.typ sub cty) | Texp_coerce cty2 -> Texp_coerce (sub.typ sub cty2) | Texp_open (ovf, path, loc, env) -> Texp_open (ovf, path, loc, sub.env sub env) | Texp_newtype _ as d -> d + | Texp_stdlib_option_call info -> + Texp_stdlib_option_call (map_stdlib_option_call sub info) in let exp_extra = List.map (tuple3 extra id id) x.exp_extra in let exp_env = sub.env sub x.exp_env in diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 078cbf133a..2aa3f286be 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -646,6 +646,16 @@ let rec cut n l = let try_ids = Hashtbl.create 8 +let stdlib_option_call_extra exp = + let rec aux = function + | [] -> None + | (Texp_stdlib_option_call info, _, _) :: _ -> Some info + | _ :: rest -> aux rest + in + aux exp.exp_extra + +let lambda_none = Lconst (Const_pointer (0, Pt_shape_none)) + let extract_directive_for_fn exp = exp.exp_attributes |> List.find_map (fun ({txt}, payload) -> @@ -755,10 +765,11 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (Lprim (Pccall (set_transformed_jsx d ~transformed_jsx), argl, e.exp_loc)) | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) - | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> + | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> ( let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in + let option_call_info = stdlib_option_call_extra e in let uncurried_partial_application = (* In case of partial application foo(args, ...) when some args are missing, get the arity *) @@ -771,8 +782,17 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | None -> None else None in - transl_apply ~inlined ~uncurried_partial_application ~transformed_jsx - (transl_exp funct) oargs e.exp_loc + match option_call_info with + | Some info when not partial -> ( + match oargs with + | (Nolabel, Some opt_expr) :: _ -> + transl_stdlib_option_call e opt_expr info oargs + | _ -> + transl_apply ~inlined ~uncurried_partial_application ~transformed_jsx + (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) -> @@ -924,6 +944,60 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = if !Clflags.noassert then lambda_unit else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) +and bind_option_value ~payload_not_nested opt_var opt_loc callback = + let value_expr = + if payload_not_nested then + Lprim (Pval_from_option_not_nest, [opt_var], opt_loc) + else Lprim (Pval_from_option, [opt_var], opt_loc) + in + match callback with + | Stdlib_option_inline_lambda {param; body} -> + bind Strict param value_expr (transl_exp body) + | Stdlib_option_inline_ident expr -> + let func = transl_exp expr in + let value_id = Ident.create "__res_option_value" in + let apply = + Lapply + { + ap_func = func; + ap_args = [Lvar value_id]; + ap_inlined = Default_inline; + ap_loc = expr.exp_loc; + ap_transformed_jsx = false; + } + in + bind Strict value_id value_expr apply + +and transl_stdlib_option_call exp opt_expr info oargs = + match oargs with + | (Nolabel, Some _) :: (Nolabel, Some _) :: _ | (Nolabel, Some _) :: [] -> + let opt_lam = transl_exp opt_expr in + let opt_id = Ident.create "__res_option_opt" in + let opt_var = Lvar opt_id in + let callback_result = + bind_option_value ~payload_not_nested:info.payload_not_nested opt_var + exp.exp_loc info.callback + in + let some_branch = + match info.call_kind with + | Stdlib_option_forEach -> callback_result + | Stdlib_option_map {result_cannot_contain_undefined} -> + let tag = + if result_cannot_contain_undefined then Blk_some_not_nested + else Blk_some + in + Lprim (Pmakeblock tag, [callback_result], exp.exp_loc) + | Stdlib_option_flatMap -> callback_result + in + let none_branch = + match info.call_kind with + | Stdlib_option_forEach -> lambda_unit + | Stdlib_option_map _ | Stdlib_option_flatMap -> lambda_none + in + let cond = Lprim (Pis_not_none, [opt_var], exp.exp_loc) in + bind Strict opt_id opt_lam (Lifthenelse (cond, some_branch, none_branch)) + | _ -> assert false + and transl_list expr_list = List.map transl_exp expr_list and transl_guard guard rhs = diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 90522f13d2..ff27d237f7 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -143,6 +143,95 @@ type recarg = Allowed | Required | Rejected let case lhs rhs = {c_lhs = lhs; c_guard = None; c_rhs = rhs} +type stdlib_option_fun_kind = + | Stdlib_option_fun_forEach + | Stdlib_option_fun_map + | Stdlib_option_fun_flatMap + +let stdlib_option_fun_of_path env path = + let canonical = Env.normalize_path_prefix None env path in + match Path.flatten canonical with + | `Contains_apply -> None + | `Ok (head, rest) -> + let segments = Ident.name head :: rest in + let matches fname = + match segments with + | ["Stdlib"; "Option"; name] -> String.equal name fname + | ["Stdlib_Option"; name] -> String.equal name fname + | _ -> false + in + if matches "forEach" then Some Stdlib_option_fun_forEach + else if matches "map" then Some Stdlib_option_fun_map + else if matches "flatMap" then Some Stdlib_option_fun_flatMap + else None + +let inline_lambda_callback (expr : expression) : stdlib_option_callback option = + match expr.exp_desc with + | Texp_function {arg_label = Nolabel; case; partial = Total; async = false; _} + when Option.is_none case.c_guard -> ( + match case.c_lhs.pat_desc with + | Tpat_var (param, _) -> + Some (Stdlib_option_inline_lambda {param; body = case.c_rhs}) + | _ -> None) + | _ -> None + +let inline_ident_callback (expr : expression) : stdlib_option_callback option = + match expr.exp_desc with + | Texp_ident _ -> Some (Stdlib_option_inline_ident expr) + | _ -> None + +let callback_return_type env (expr : expression) = + match (expand_head env expr.exp_type).desc with + | Tarrow (_, ret_ty, _, _) -> Some ret_ty + | _ -> None + +let detect_stdlib_option_call env (funct : expression) + (args : (Noloc.arg_label * expression option) list) : + stdlib_option_call option = + match funct.exp_desc with + | Texp_ident (path, _, _) -> ( + match stdlib_option_fun_of_path env path with + | None -> None + | Some fun_kind -> ( + match args with + | [(Nolabel, Some opt_expr); (Nolabel, Some callback_expr)] -> ( + let callback_info = + match inline_lambda_callback callback_expr with + | Some info -> Some info + | None -> inline_ident_callback callback_expr + in + match callback_info with + | None -> None + | Some callback -> + let payload_not_nested = + match (expand_head env opt_expr.exp_type).desc with + | Tconstr (path, [payload_ty], _) + when Path.same path Predef.path_option -> + Typeopt.type_cannot_contain_undefined payload_ty env + | _ -> false + in + let call_kind = + match fun_kind with + | Stdlib_option_fun_forEach -> Stdlib_option_forEach + | Stdlib_option_fun_map -> + let result_cannot_contain_undefined = + match callback with + | Stdlib_option_inline_lambda {body; _} -> + Typeopt.type_cannot_contain_undefined body.exp_type + body.exp_env + | Stdlib_option_inline_ident cb -> ( + match callback_return_type cb.exp_env cb with + | Some ret_ty -> + Typeopt.type_cannot_contain_undefined ret_ty cb.exp_env + | None -> false) + in + Stdlib_option_map {result_cannot_contain_undefined} + | Stdlib_option_fun_flatMap -> Stdlib_option_flatMap + in + Some {callback; call_kind; payload_not_nested}) + | _ -> None)) + | _ -> None + (* Upper approximation of free identifiers on the parse tree *) let iter_expression f e = @@ -2448,12 +2537,20 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected end_def (); unify_var env (newvar ()) funct.exp_type; + let option_call_info = + if fully_applied then detect_stdlib_option_call env funct args else None + in + let exp_extra = + match option_call_info with + | Some info -> [(Texp_stdlib_option_call info, loc, [])] + | None -> [] + in let mk_apply funct args = rue { exp_desc = Texp_apply {funct; args; partial; transformed_jsx}; exp_loc = loc; - exp_extra = []; + exp_extra; exp_type = ty_res; exp_attributes = sexp.pexp_attributes; exp_env = env; diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 9ef328be4a..73794f2319 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -64,11 +64,27 @@ and expression = { exp_attributes: attribute list; } +and stdlib_option_call_kind = + | Stdlib_option_forEach + | Stdlib_option_map of {result_cannot_contain_undefined: bool} + | Stdlib_option_flatMap + +and stdlib_option_callback = + | Stdlib_option_inline_lambda of {param: Ident.t; body: expression} + | Stdlib_option_inline_ident of expression + +and stdlib_option_call = { + callback: stdlib_option_callback; + call_kind: stdlib_option_call_kind; + payload_not_nested: bool; +} + and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type | Texp_open of override_flag * Path.t * Longident.t loc * Env.t | Texp_newtype of string + | Texp_stdlib_option_call of stdlib_option_call and expression_desc = | Texp_ident of Path.t * Longident.t loc * Types.value_description diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 6e6b1c5159..4323a5714e 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -107,6 +107,21 @@ and expression = { exp_attributes: attributes; } +and stdlib_option_call_kind = + | Stdlib_option_forEach + | Stdlib_option_map of {result_cannot_contain_undefined: bool} + | Stdlib_option_flatMap + +and stdlib_option_callback = + | Stdlib_option_inline_lambda of {param: Ident.t; body: expression} + | Stdlib_option_inline_ident of expression + +and stdlib_option_call = { + callback: stdlib_option_callback; + call_kind: stdlib_option_call_kind; + payload_not_nested: bool; +} + and exp_extra = | Texp_constraint of core_type (** E : T *) | Texp_coerce of core_type (** E :> T [Texp_coerce T] @@ -116,6 +131,7 @@ and exp_extra = where [env] is the environment after opening [P] *) | Texp_newtype of string (** fun (type t) -> *) + | Texp_stdlib_option_call of stdlib_option_call and expression_desc = | Texp_ident of Path.t * Longident.t loc * Types.value_description diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index 9a31b9b5b9..cbcfd7e879 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -218,7 +218,8 @@ end = struct | Texp_constraint ct -> iter_core_type ct | Texp_coerce cty2 -> iter_core_type cty2 | Texp_open _ -> () - | Texp_newtype _ -> ())) + | Texp_newtype _ -> () + | Texp_stdlib_option_call info -> iter_stdlib_option_call info)) exp.exp_extra; (match exp.exp_desc with | Texp_ident _ -> () @@ -294,6 +295,13 @@ end = struct | Texp_extension_constructor _ -> ()); Iter.leave_expression exp + and iter_stdlib_option_callback = function + | Stdlib_option_inline_lambda {body; _} -> iter_expression body + | Stdlib_option_inline_ident expr -> iter_expression expr + + and iter_stdlib_option_call {callback; _} = + iter_stdlib_option_callback callback + and iter_package_type pack = Iter.enter_package_type pack; List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; diff --git a/tests/tests/src/core/Core_ObjectTests.mjs b/tests/tests/src/core/Core_ObjectTests.mjs index 31b7c9569d..b711792af3 100644 --- a/tests/tests/src/core/Core_ObjectTests.mjs +++ b/tests/tests/src/core/Core_ObjectTests.mjs @@ -4,7 +4,6 @@ import * as Test from "./Test.mjs"; import * as Stdlib_BigInt from "@rescript/runtime/lib/es6/Stdlib_BigInt.js"; import * as Stdlib_Option from "@rescript/runtime/lib/es6/Stdlib_Option.js"; import * as Primitive_object from "@rescript/runtime/lib/es6/Primitive_object.js"; -import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.js"; let eq = Primitive_object.equal; @@ -532,8 +531,8 @@ runGetTest({ ] }), get: i => { - let i$1 = i["a"]; - return Stdlib_Option.getOr(i$1 !== undefined ? Primitive_option.valFromOption(i$1).concat([ + let __res_option_opt = i["a"]; + return Stdlib_Option.getOr(__res_option_opt !== undefined ? __res_option_opt.concat([ 4, 5 ]) : undefined, []); diff --git a/tests/tests/src/core/intl/Core_IntlTests.mjs b/tests/tests/src/core/intl/Core_IntlTests.mjs index b74bc130f1..69944e7299 100644 --- a/tests/tests/src/core/intl/Core_IntlTests.mjs +++ b/tests/tests/src/core/intl/Core_IntlTests.mjs @@ -57,8 +57,8 @@ try { let e$2 = Primitive_exceptions.internalToException(raw_e$2); if (e$2.RE_EXN_ID === "JsExn") { let e$3 = e$2._1; - let __res_option_value = Stdlib_JsExn.message(e$3); - let message = __res_option_value !== undefined ? __res_option_value.toLowerCase() : undefined; + let __res_option_opt = Stdlib_JsExn.message(e$3); + let message = __res_option_opt !== undefined ? __res_option_opt.toLowerCase() : undefined; let exit = 0; if (message === "invalid key : someinvalidkey") { console.log("Caught expected error"); diff --git a/tests/tests/src/option_stdlib_optimization_test.mjs b/tests/tests/src/option_stdlib_optimization_test.mjs index f32c392916..73ea7a4731 100644 --- a/tests/tests/src/option_stdlib_optimization_test.mjs +++ b/tests/tests/src/option_stdlib_optimization_test.mjs @@ -7,11 +7,11 @@ import * as Belt_MapString from "@rescript/runtime/lib/es6/Belt_MapString.js"; import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.js"; function getIncidentCategoryName(incidents, categories, incidentId) { - let incident = incidentId !== undefined ? Belt_MapString.get(incidents, incidentId) : undefined; - let categoryId = incident !== undefined ? incident.categoryId : undefined; - let category = categoryId !== undefined ? Belt_MapString.get(categories, categoryId) : undefined; - if (category !== undefined) { - return category.name; + let __res_option_opt = incidentId !== undefined ? Belt_MapString.get(incidents, incidentId) : undefined; + let __res_option_opt$1 = __res_option_opt !== undefined ? __res_option_opt.categoryId : undefined; + let __res_option_opt$2 = __res_option_opt$1 !== undefined ? Belt_MapString.get(categories, __res_option_opt$1) : undefined; + if (__res_option_opt$2 !== undefined) { + return __res_option_opt$2.name; } } diff --git a/tests/tests/src/reactTestUtils.mjs b/tests/tests/src/reactTestUtils.mjs index 6c70cb9ce3..287c48bf63 100644 --- a/tests/tests/src/reactTestUtils.mjs +++ b/tests/tests/src/reactTestUtils.mjs @@ -64,18 +64,14 @@ let DOM = { function prepareContainer(container, param) { let containerElement = document.createElement("div"); - let body = document.body; - if (body !== undefined) { - Primitive_option.some(Primitive_option.valFromOption(body).appendChild(containerElement)); - } + Belt_Option.map(document.body, body => body.appendChild(containerElement)); container.contents = Primitive_option.some(containerElement); } function cleanupContainer(container, param) { - let __res_option_value = container.contents; - if (__res_option_value !== undefined) { - Primitive_option.some((Primitive_option.valFromOption(__res_option_value).remove(), undefined)); - } + Belt_Option.map(container.contents, prim => { + prim.remove(); + }); container.contents = undefined; } From 9646b2878f62d8d9fb22946ef135013efda241f3 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 23 Sep 2025 17:48:39 +0200 Subject: [PATCH 2/7] Refine Stdlib.Option metadata handling --- analysis/reanalyze/src/Arnold.ml | 13 +-- analysis/reanalyze/src/Exception.ml | 3 +- analysis/reanalyze/src/SideEffects.ml | 2 +- compiler/ml/printtyped.ml | 15 +--- compiler/ml/rec_check.ml | 6 +- compiler/ml/tast_iterator.ml | 9 +- compiler/ml/tast_mapper.ml | 20 +---- compiler/ml/translcore.ml | 120 ++++++++++++++++++++++++-- compiler/ml/typecore.ml | 90 ++++--------------- compiler/ml/typedtree.ml | 17 +--- compiler/ml/typedtree.mli | 17 +--- compiler/ml/typedtreeIter.ml | 12 +-- 12 files changed, 153 insertions(+), 171 deletions(-) diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index 9eec8d729e..35ce9e8045 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -534,7 +534,7 @@ module FindFunctionsCalled = struct let super = Tast_mapper.default in let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = (match e.exp_desc with - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}} -> + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; _} -> let functionName = Path.name callee in callees := !callees |> StringSet.add functionName | _ -> ()); @@ -579,7 +579,8 @@ module ExtendFunctionTable = struct | Some { exp_desc = - Texp_apply {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args}; + Texp_apply + {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args; _}; } when kindOpt <> None -> let checkArg ((argLabel : Asttypes.Noloc.arg_label), _argOpt) = @@ -620,7 +621,7 @@ module ExtendFunctionTable = struct calls a progress function" functionName printPos id_pos; }))) - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args} + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args; _} when callee |> FunctionTable.isInFunctionInTable ~functionTable -> let functionName = Path.name callee in args @@ -668,8 +669,8 @@ module CheckExpressionWellFormed = struct | Texp_ident (path, {loc}, _) -> checkIdent ~path ~loc; e - | Texp_apply {funct = {exp_desc = Texp_ident (functionPath, _, _)}; args} - -> + | Texp_apply + {funct = {exp_desc = Texp_ident (functionPath, _, _)}; args; _} -> let functionName = Path.name functionPath in args |> List.iter (fun ((argLabel : Asttypes.Noloc.arg_label), argOpt) -> @@ -850,7 +851,7 @@ module Compile = struct and create a function call with the appropriate arguments *) assert false | None -> expr |> expression ~ctx |> evalArgs ~args ~ctx) - | Texp_apply {funct = expr; args} -> + | Texp_apply {funct = expr; args; _} -> expr |> expression ~ctx |> evalArgs ~args ~ctx | Texp_let ( Recursive, diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml index d59516e2dd..18f27ab755 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/Exception.ml @@ -304,7 +304,8 @@ let traverseAst () = let exceptions = [arg] |> raiseArgs in currentEvents := {Event.exceptions; loc; kind = Raises} :: !currentEvents; arg |> snd |> iterExprOpt self - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)} as e; args} -> + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)} as e; args; _} + -> let calleeName = Path.name callee in if calleeName |> isRaise then let exceptions = args |> raiseArgs in diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml index 5aceaf124d..22f4a1e45b 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/SideEffects.ml @@ -26,7 +26,7 @@ let rec exprNoSideEffects (expr : Typedtree.expression) = | Texp_ident _ | Texp_constant _ -> true | Texp_construct (_, _, el) -> el |> List.for_all exprNoSideEffects | Texp_function _ -> true - | Texp_apply {funct = {exp_desc = Texp_ident (path, _, _)}; args} + | Texp_apply {funct = {exp_desc = Texp_ident (path, _, _)}; args; _} when path |> pathIsWhitelistedForSideEffects -> args |> List.for_all (fun (_, eo) -> eo |> exprOptNoSideEffects) | Texp_apply _ -> false diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 29b18cc823..6b41ae6424 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -260,16 +260,6 @@ and expression_extra i ppf x attrs = | Texp_newtype s -> line i ppf "Texp_newtype \"%s\"\n" s; attributes i ppf attrs - | Texp_stdlib_option_call {call_kind; payload_not_nested; _} -> - let kind = - match call_kind with - | Stdlib_option_forEach -> "forEach" - | Stdlib_option_map {result_cannot_contain_undefined = _} -> "map" - | Stdlib_option_flatMap -> "flatMap" - in - line i ppf "Texp_stdlib_option_call %s payload_not_nested=%b\n" kind - payload_not_nested; - attributes i ppf attrs and expression i ppf x = line i ppf "expression %a\n" fmt_location x.exp_loc; @@ -298,11 +288,12 @@ and expression i ppf x = line i ppf "%a" Ident.print param; arg_label i ppf p; case i ppf case_ - | Texp_apply {funct = e; args = l; partial} -> + | Texp_apply {funct = e; args = l; partial; stdlib_option_call; _} -> if partial then line i ppf "partial\n"; line i ppf "Texp_apply\n"; expression i ppf e; - list i label_x_expression ppf l + list i label_x_expression ppf l; + if stdlib_option_call then line i ppf "stdlib_option_call\n" else () | Texp_match (e, l1, l2, _partial) -> line i ppf "Texp_match\n"; expression i ppf e; diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 3d016a7438..fad85b45fa 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -199,7 +199,7 @@ let rec classify_expression : Typedtree.expression -> sd = | Texp_while _ | Texp_pack _ | Texp_function _ | Texp_extension_constructor _ -> Static - | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}} when is_ref vd -> + | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}; _} when is_ref vd -> Static | Texp_apply _ | Texp_match _ | Texp_ifthenelse _ | Texp_send _ | Texp_field _ | Texp_assert _ | Texp_try _ -> @@ -233,10 +233,10 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = (discard (expression env e3))) | Texp_constant _ -> Use.empty | Texp_apply - {funct = {exp_desc = Texp_ident (_, _, vd)}; args = [(_, Some arg)]} + {funct = {exp_desc = Texp_ident (_, _, vd)}; args = [(_, Some arg)]; _} when is_ref vd -> Use.guard (expression env arg) - | Texp_apply {funct = e; args} -> + | Texp_apply {funct = e; args; _} -> let arg env (_, eo) = option expression env eo in Use.(join (inspect (expression env e)) (inspect (list arg env args))) | Texp_tuple exprs -> Use.guard (list expression env exprs) diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index b0913a6e61..6d8ad73db8 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -137,16 +137,11 @@ let pat sub {pat_extra; pat_desc; pat_env; _} = | Tpat_alias (p, _, _) -> sub.pat sub p let expr sub {exp_extra; exp_desc; exp_env; _} = - let rec extra = function + let extra = function | Texp_constraint cty -> sub.typ sub cty | Texp_coerce cty2 -> sub.typ sub cty2 | Texp_newtype _ -> () | Texp_open (_, _, _, _) -> () - | Texp_stdlib_option_call info -> stdlib_option_call info - and stdlib_option_call {callback; _} = stdlib_option_callback callback - and stdlib_option_callback = function - | Stdlib_option_inline_lambda {body; _} -> sub.expr sub body - | Stdlib_option_inline_ident expr -> sub.expr sub expr in List.iter (fun (e, _, _) -> extra e) exp_extra; sub.env sub exp_env; @@ -157,7 +152,7 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = sub.value_bindings sub (rec_flag, list); sub.expr sub exp | Texp_function {case; _} -> sub.case sub case - | Texp_apply {funct = exp; args = list} -> + | Texp_apply {funct = exp; args = list; _} -> sub.expr sub exp; List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list | Texp_match (exp, list1, list2, _) -> diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 27fe9d89c6..6a5b417b68 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -180,27 +180,12 @@ let pat sub x = {x with pat_extra; pat_desc; pat_env} let expr sub x = - let map_stdlib_option_callback sub = function - | Stdlib_option_inline_lambda {param; body} -> - Stdlib_option_inline_lambda {param; body = sub.expr sub body} - | Stdlib_option_inline_ident expr -> - Stdlib_option_inline_ident (sub.expr sub expr) - in - let map_stdlib_option_call sub {callback; call_kind; payload_not_nested} = - { - callback = map_stdlib_option_callback sub callback; - call_kind; - payload_not_nested; - } - in let extra = function | Texp_constraint cty -> Texp_constraint (sub.typ sub cty) | Texp_coerce cty2 -> Texp_coerce (sub.typ sub cty2) | Texp_open (ovf, path, loc, env) -> Texp_open (ovf, path, loc, sub.env sub env) | Texp_newtype _ as d -> d - | Texp_stdlib_option_call info -> - Texp_stdlib_option_call (map_stdlib_option_call sub info) in let exp_extra = List.map (tuple3 extra id id) x.exp_extra in let exp_env = sub.env sub x.exp_env in @@ -213,11 +198,14 @@ 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; transformed_jsx} -> + | Texp_apply + {funct = exp; args = list; partial; transformed_jsx; stdlib_option_call} + -> Texp_apply { funct = sub.expr sub exp; args = List.map (tuple2 id (opt (sub.expr sub))) list; + stdlib_option_call; partial; transformed_jsx; } diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 2aa3f286be..cb8d466792 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -646,13 +646,111 @@ let rec cut n l = let try_ids = Hashtbl.create 8 -let stdlib_option_call_extra exp = - let rec aux = function - | [] -> None - | (Texp_stdlib_option_call info, _, _) :: _ -> Some info - | _ :: rest -> aux rest - in - aux exp.exp_extra +(* Recompute metadata needed for inlining Stdlib.Option helpers at translation + time; the typed tree only marks such applications with a boolean flag. *) +type stdlib_option_call_kind = + | Stdlib_option_forEach + | Stdlib_option_map of {result_cannot_contain_undefined: bool} + | Stdlib_option_flatMap + +type stdlib_option_callback = + | Stdlib_option_inline_lambda of {param: Ident.t; body: expression} + | Stdlib_option_inline_ident of expression + +type stdlib_option_call = { + callback: stdlib_option_callback; + call_kind: stdlib_option_call_kind; + payload_not_nested: bool; +} + +type stdlib_option_fun_kind = + | Stdlib_option_fun_forEach + | Stdlib_option_fun_map + | Stdlib_option_fun_flatMap + +let stdlib_option_fun_of_path env path = + let canonical = Env.normalize_path_prefix None env path in + match Path.flatten canonical with + | `Contains_apply -> None + | `Ok (head, rest) -> + let segments = Ident.name head :: rest in + let matches fname = + match segments with + | ["Stdlib"; "Option"; name] -> String.equal name fname + | ["Stdlib_Option"; name] -> String.equal name fname + | _ -> false + in + if matches "forEach" then Some Stdlib_option_fun_forEach + else if matches "map" then Some Stdlib_option_fun_map + else if matches "flatMap" then Some Stdlib_option_fun_flatMap + else None + +let inline_lambda_callback (expr : expression) : stdlib_option_callback option = + match expr.exp_desc with + | Texp_function {arg_label = Nolabel; case; partial = Total; async = false; _} + when Option.is_none case.c_guard -> ( + match case.c_lhs.pat_desc with + | Tpat_var (param, _) -> + Some (Stdlib_option_inline_lambda {param; body = case.c_rhs}) + | _ -> None) + | _ -> None + +let inline_ident_callback (expr : expression) : stdlib_option_callback option = + match expr.exp_desc with + | Texp_ident _ -> Some (Stdlib_option_inline_ident expr) + | _ -> None + +let callback_return_type env (expr : expression) = + match (Ctype.expand_head env expr.exp_type).desc with + | Tarrow (_, ret_ty, _, _) -> Some ret_ty + | _ -> None + +let detect_stdlib_option_call env (funct : expression) + (args : (Noloc.arg_label * expression option) list) : + stdlib_option_call option = + match funct.exp_desc with + | Texp_ident (path, _, _) -> ( + match stdlib_option_fun_of_path env path with + | None -> None + | Some fun_kind -> ( + match args with + | [(Nolabel, Some opt_expr); (Nolabel, Some callback_expr)] -> ( + let callback_info = + match inline_lambda_callback callback_expr with + | Some info -> Some info + | None -> inline_ident_callback callback_expr + in + match callback_info with + | None -> None + | Some callback -> + let payload_not_nested = + match (Ctype.expand_head env opt_expr.exp_type).desc with + | Tconstr (path, [payload_ty], _) + when Path.same path Predef.path_option -> + Typeopt.type_cannot_contain_undefined payload_ty env + | _ -> false + in + let call_kind = + match fun_kind with + | Stdlib_option_fun_forEach -> Stdlib_option_forEach + | Stdlib_option_fun_map -> + let result_cannot_contain_undefined = + match callback with + | Stdlib_option_inline_lambda {body; _} -> + Typeopt.type_cannot_contain_undefined body.exp_type + body.exp_env + | Stdlib_option_inline_ident cb -> ( + match callback_return_type cb.exp_env cb with + | Some ret_ty -> + Typeopt.type_cannot_contain_undefined ret_ty cb.exp_env + | None -> false) + in + Stdlib_option_map {result_cannot_contain_undefined} + | Stdlib_option_fun_flatMap -> Stdlib_option_flatMap + in + Some {callback; call_kind; payload_not_nested}) + | _ -> None)) + | _ -> None let lambda_none = Lconst (Const_pointer (0, Pt_shape_none)) @@ -765,11 +863,15 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (Lprim (Pccall (set_transformed_jsx d ~transformed_jsx), argl, e.exp_loc)) | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) - | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> ( + | Texp_apply + {funct; args = oargs; partial; transformed_jsx; stdlib_option_call} -> ( let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in - let option_call_info = stdlib_option_call_extra e in + let option_call_info = + if stdlib_option_call then detect_stdlib_option_call e.exp_env funct oargs + else None + in let uncurried_partial_application = (* In case of partial application foo(args, ...) when some args are missing, get the arity *) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index ff27d237f7..82f4875a5e 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -165,72 +165,17 @@ let stdlib_option_fun_of_path env path = else if matches "flatMap" then Some Stdlib_option_fun_flatMap else None -let inline_lambda_callback (expr : expression) : stdlib_option_callback option = - match expr.exp_desc with - | Texp_function {arg_label = Nolabel; case; partial = Total; async = false; _} - when Option.is_none case.c_guard -> ( - match case.c_lhs.pat_desc with - | Tpat_var (param, _) -> - Some (Stdlib_option_inline_lambda {param; body = case.c_rhs}) - | _ -> None) - | _ -> None - -let inline_ident_callback (expr : expression) : stdlib_option_callback option = - match expr.exp_desc with - | Texp_ident _ -> Some (Stdlib_option_inline_ident expr) - | _ -> None - -let callback_return_type env (expr : expression) = - match (expand_head env expr.exp_type).desc with - | Tarrow (_, ret_ty, _, _) -> Some ret_ty - | _ -> None - -let detect_stdlib_option_call env (funct : expression) - (args : (Noloc.arg_label * expression option) list) : - stdlib_option_call option = +let is_stdlib_option_call env (funct : expression) + (args : (Noloc.arg_label * expression option) list) : bool = match funct.exp_desc with | Texp_ident (path, _, _) -> ( match stdlib_option_fun_of_path env path with - | None -> None - | Some fun_kind -> ( + | None -> false + | Some _ -> ( match args with - | [(Nolabel, Some opt_expr); (Nolabel, Some callback_expr)] -> ( - let callback_info = - match inline_lambda_callback callback_expr with - | Some info -> Some info - | None -> inline_ident_callback callback_expr - in - match callback_info with - | None -> None - | Some callback -> - let payload_not_nested = - match (expand_head env opt_expr.exp_type).desc with - | Tconstr (path, [payload_ty], _) - when Path.same path Predef.path_option -> - Typeopt.type_cannot_contain_undefined payload_ty env - | _ -> false - in - let call_kind = - match fun_kind with - | Stdlib_option_fun_forEach -> Stdlib_option_forEach - | Stdlib_option_fun_map -> - let result_cannot_contain_undefined = - match callback with - | Stdlib_option_inline_lambda {body; _} -> - Typeopt.type_cannot_contain_undefined body.exp_type - body.exp_env - | Stdlib_option_inline_ident cb -> ( - match callback_return_type cb.exp_env cb with - | Some ret_ty -> - Typeopt.type_cannot_contain_undefined ret_ty cb.exp_env - | None -> false) - in - Stdlib_option_map {result_cannot_contain_undefined} - | Stdlib_option_fun_flatMap -> Stdlib_option_flatMap - in - Some {callback; call_kind; payload_not_nested}) - | _ -> None)) - | _ -> None + | [(Nolabel, Some _); (Nolabel, Some _)] -> true + | _ -> false)) + | _ -> false (* Upper approximation of free identifiers on the parse tree *) @@ -1893,7 +1838,7 @@ let rec is_nonexpansive exp = List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && is_nonexpansive body | Texp_function _ -> true - | Texp_apply {funct = e; args = (_, None) :: el} -> + | Texp_apply {funct = e; args = (_, None) :: el; _} -> is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) | Texp_match (e, cases, [], _) -> is_nonexpansive e @@ -2537,20 +2482,17 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected end_def (); unify_var env (newvar ()) funct.exp_type; - let option_call_info = - if fully_applied then detect_stdlib_option_call env funct args else None - in - let exp_extra = - match option_call_info with - | Some info -> [(Texp_stdlib_option_call info, loc, [])] - | None -> [] + let stdlib_option_call = + fully_applied && is_stdlib_option_call env funct args in let mk_apply funct args = rue { - exp_desc = Texp_apply {funct; args; partial; transformed_jsx}; + exp_desc = + Texp_apply + {funct; args; partial; transformed_jsx; stdlib_option_call}; exp_loc = loc; - exp_extra; + exp_extra = []; exp_type = ty_res; exp_attributes = sexp.pexp_attributes; exp_env = env; @@ -2563,8 +2505,8 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected | _ -> false in - if fully_applied && not is_primitive then rue (mk_apply funct args) - else rue (mk_apply funct args) + if fully_applied && not is_primitive then mk_apply funct args + else mk_apply funct args | Pexp_match (sarg, caselist) -> begin_def (); let arg = type_exp ~context:None env sarg in diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 73794f2319..b90cb93d10 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -64,27 +64,11 @@ and expression = { exp_attributes: attribute list; } -and stdlib_option_call_kind = - | Stdlib_option_forEach - | Stdlib_option_map of {result_cannot_contain_undefined: bool} - | Stdlib_option_flatMap - -and stdlib_option_callback = - | Stdlib_option_inline_lambda of {param: Ident.t; body: expression} - | Stdlib_option_inline_ident of expression - -and stdlib_option_call = { - callback: stdlib_option_callback; - call_kind: stdlib_option_call_kind; - payload_not_nested: bool; -} - and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type | Texp_open of override_flag * Path.t * Longident.t loc * Env.t | Texp_newtype of string - | Texp_stdlib_option_call of stdlib_option_call and expression_desc = | Texp_ident of Path.t * Longident.t loc * Types.value_description @@ -103,6 +87,7 @@ and expression_desc = args: (Noloc.arg_label * expression option) list; partial: bool; transformed_jsx: bool; + stdlib_option_call: 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 4323a5714e..167d287d52 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -107,21 +107,6 @@ and expression = { exp_attributes: attributes; } -and stdlib_option_call_kind = - | Stdlib_option_forEach - | Stdlib_option_map of {result_cannot_contain_undefined: bool} - | Stdlib_option_flatMap - -and stdlib_option_callback = - | Stdlib_option_inline_lambda of {param: Ident.t; body: expression} - | Stdlib_option_inline_ident of expression - -and stdlib_option_call = { - callback: stdlib_option_callback; - call_kind: stdlib_option_call_kind; - payload_not_nested: bool; -} - and exp_extra = | Texp_constraint of core_type (** E : T *) | Texp_coerce of core_type (** E :> T [Texp_coerce T] @@ -131,7 +116,6 @@ and exp_extra = where [env] is the environment after opening [P] *) | Texp_newtype of string (** fun (type t) -> *) - | Texp_stdlib_option_call of stdlib_option_call and expression_desc = | Texp_ident of Path.t * Longident.t loc * Types.value_description @@ -166,6 +150,7 @@ and expression_desc = args: (Noloc.arg_label * expression option) list; partial: bool; transformed_jsx: bool; + stdlib_option_call: bool; } (** E0 ~l1:E1 ... ~ln:En diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index cbcfd7e879..fe60ceac37 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -218,8 +218,7 @@ end = struct | Texp_constraint ct -> iter_core_type ct | Texp_coerce cty2 -> iter_core_type cty2 | Texp_open _ -> () - | Texp_newtype _ -> () - | Texp_stdlib_option_call info -> iter_stdlib_option_call info)) + | Texp_newtype _ -> ())) exp.exp_extra; (match exp.exp_desc with | Texp_ident _ -> () @@ -228,7 +227,7 @@ end = struct iter_bindings rec_flag list; iter_expression exp | Texp_function {case; _} -> iter_case case - | Texp_apply {funct = exp; args = list} -> + | Texp_apply {funct = exp; args = list; _} -> iter_expression exp; List.iter (fun (_label, expo) -> @@ -295,13 +294,6 @@ end = struct | Texp_extension_constructor _ -> ()); Iter.leave_expression exp - and iter_stdlib_option_callback = function - | Stdlib_option_inline_lambda {body; _} -> iter_expression body - | Stdlib_option_inline_ident expr -> iter_expression expr - - and iter_stdlib_option_call {callback; _} = - iter_stdlib_option_callback callback - and iter_package_type pack = Iter.enter_package_type pack; List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; From 5171806f5fdf6c4b2b11da1201fe8b90b7bcfee6 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Tue, 23 Sep 2025 17:37:39 +0200 Subject: [PATCH 3/7] Keep original var names --- compiler/ml/translcore.ml | 7 ++++++- tests/tests/src/core/Core_ObjectTests.mjs | 4 ++-- tests/tests/src/core/intl/Core_IntlTests.mjs | 4 ++-- tests/tests/src/option_stdlib_optimization_test.mjs | 10 +++++----- 4 files changed, 15 insertions(+), 10 deletions(-) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index cb8d466792..6da84eb048 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1074,7 +1074,12 @@ and transl_stdlib_option_call exp opt_expr info oargs = match oargs with | (Nolabel, Some _) :: (Nolabel, Some _) :: _ | (Nolabel, Some _) :: [] -> let opt_lam = transl_exp opt_expr in - let opt_id = Ident.create "__res_option_opt" in + let opt_id = + match info.callback with + | Stdlib_option_inline_lambda {param; _} -> + Ident.create (Ident.name param) + | _ -> Ident.create "__res_option_value" + in let opt_var = Lvar opt_id in let callback_result = bind_option_value ~payload_not_nested:info.payload_not_nested opt_var diff --git a/tests/tests/src/core/Core_ObjectTests.mjs b/tests/tests/src/core/Core_ObjectTests.mjs index b711792af3..6c788d1009 100644 --- a/tests/tests/src/core/Core_ObjectTests.mjs +++ b/tests/tests/src/core/Core_ObjectTests.mjs @@ -531,8 +531,8 @@ runGetTest({ ] }), get: i => { - let __res_option_opt = i["a"]; - return Stdlib_Option.getOr(__res_option_opt !== undefined ? __res_option_opt.concat([ + let i$1 = i["a"]; + return Stdlib_Option.getOr(i$1 !== undefined ? i$1.concat([ 4, 5 ]) : undefined, []); diff --git a/tests/tests/src/core/intl/Core_IntlTests.mjs b/tests/tests/src/core/intl/Core_IntlTests.mjs index 69944e7299..b74bc130f1 100644 --- a/tests/tests/src/core/intl/Core_IntlTests.mjs +++ b/tests/tests/src/core/intl/Core_IntlTests.mjs @@ -57,8 +57,8 @@ try { let e$2 = Primitive_exceptions.internalToException(raw_e$2); if (e$2.RE_EXN_ID === "JsExn") { let e$3 = e$2._1; - let __res_option_opt = Stdlib_JsExn.message(e$3); - let message = __res_option_opt !== undefined ? __res_option_opt.toLowerCase() : undefined; + let __res_option_value = Stdlib_JsExn.message(e$3); + let message = __res_option_value !== undefined ? __res_option_value.toLowerCase() : undefined; let exit = 0; if (message === "invalid key : someinvalidkey") { console.log("Caught expected error"); diff --git a/tests/tests/src/option_stdlib_optimization_test.mjs b/tests/tests/src/option_stdlib_optimization_test.mjs index 73ea7a4731..f32c392916 100644 --- a/tests/tests/src/option_stdlib_optimization_test.mjs +++ b/tests/tests/src/option_stdlib_optimization_test.mjs @@ -7,11 +7,11 @@ import * as Belt_MapString from "@rescript/runtime/lib/es6/Belt_MapString.js"; import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.js"; function getIncidentCategoryName(incidents, categories, incidentId) { - let __res_option_opt = incidentId !== undefined ? Belt_MapString.get(incidents, incidentId) : undefined; - let __res_option_opt$1 = __res_option_opt !== undefined ? __res_option_opt.categoryId : undefined; - let __res_option_opt$2 = __res_option_opt$1 !== undefined ? Belt_MapString.get(categories, __res_option_opt$1) : undefined; - if (__res_option_opt$2 !== undefined) { - return __res_option_opt$2.name; + let incident = incidentId !== undefined ? Belt_MapString.get(incidents, incidentId) : undefined; + let categoryId = incident !== undefined ? incident.categoryId : undefined; + let category = categoryId !== undefined ? Belt_MapString.get(categories, categoryId) : undefined; + if (category !== undefined) { + return category.name; } } From 9cb5d2ab8ac6b70295ff6d31f0dcb289666ab0ee Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Wed, 24 Sep 2025 18:12:07 +0200 Subject: [PATCH 4/7] Do not add unnecessary underscores to record pattern matches --- AGENTS.md | 2 ++ analysis/reanalyze/src/Arnold.ml | 13 ++++++------- analysis/reanalyze/src/Exception.ml | 3 +-- analysis/reanalyze/src/SideEffects.ml | 2 +- compiler/ml/rec_check.ml | 6 +++--- compiler/ml/tast_iterator.ml | 2 +- compiler/ml/translcore.ml | 5 ++--- compiler/ml/typecore.ml | 2 +- compiler/ml/typedtreeIter.ml | 2 +- 9 files changed, 18 insertions(+), 19 deletions(-) diff --git a/AGENTS.md b/AGENTS.md index 725007dd7b..743b856eef 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -30,6 +30,8 @@ make format && make checkformat - **Do not introduce new keywords unless absolutely necessary** - Try to find ways to implement features without reserving keywords, as seen with the "catch" implementation that avoids making it a keyword. +- **No underscore if not matching on all record fields** - Do not add "; _" to pattern matches in the compiler code. OCaml warning 9 (missing fields in a record pattern) is disabled in this project. + ## Compiler Architecture ### Compilation Pipeline diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index 35ce9e8045..9eec8d729e 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -534,7 +534,7 @@ module FindFunctionsCalled = struct let super = Tast_mapper.default in let expr (self : Tast_mapper.mapper) (e : Typedtree.expression) = (match e.exp_desc with - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; _} -> + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}} -> let functionName = Path.name callee in callees := !callees |> StringSet.add functionName | _ -> ()); @@ -579,8 +579,7 @@ module ExtendFunctionTable = struct | Some { exp_desc = - Texp_apply - {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args; _}; + Texp_apply {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args}; } when kindOpt <> None -> let checkArg ((argLabel : Asttypes.Noloc.arg_label), _argOpt) = @@ -621,7 +620,7 @@ module ExtendFunctionTable = struct calls a progress function" functionName printPos id_pos; }))) - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args; _} + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)}; args} when callee |> FunctionTable.isInFunctionInTable ~functionTable -> let functionName = Path.name callee in args @@ -669,8 +668,8 @@ module CheckExpressionWellFormed = struct | Texp_ident (path, {loc}, _) -> checkIdent ~path ~loc; e - | Texp_apply - {funct = {exp_desc = Texp_ident (functionPath, _, _)}; args; _} -> + | Texp_apply {funct = {exp_desc = Texp_ident (functionPath, _, _)}; args} + -> let functionName = Path.name functionPath in args |> List.iter (fun ((argLabel : Asttypes.Noloc.arg_label), argOpt) -> @@ -851,7 +850,7 @@ module Compile = struct and create a function call with the appropriate arguments *) assert false | None -> expr |> expression ~ctx |> evalArgs ~args ~ctx) - | Texp_apply {funct = expr; args; _} -> + | Texp_apply {funct = expr; args} -> expr |> expression ~ctx |> evalArgs ~args ~ctx | Texp_let ( Recursive, diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml index 18f27ab755..d59516e2dd 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/Exception.ml @@ -304,8 +304,7 @@ let traverseAst () = let exceptions = [arg] |> raiseArgs in currentEvents := {Event.exceptions; loc; kind = Raises} :: !currentEvents; arg |> snd |> iterExprOpt self - | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)} as e; args; _} - -> + | Texp_apply {funct = {exp_desc = Texp_ident (callee, _, _)} as e; args} -> let calleeName = Path.name callee in if calleeName |> isRaise then let exceptions = args |> raiseArgs in diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml index 22f4a1e45b..5aceaf124d 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/SideEffects.ml @@ -26,7 +26,7 @@ let rec exprNoSideEffects (expr : Typedtree.expression) = | Texp_ident _ | Texp_constant _ -> true | Texp_construct (_, _, el) -> el |> List.for_all exprNoSideEffects | Texp_function _ -> true - | Texp_apply {funct = {exp_desc = Texp_ident (path, _, _)}; args; _} + | Texp_apply {funct = {exp_desc = Texp_ident (path, _, _)}; args} when path |> pathIsWhitelistedForSideEffects -> args |> List.for_all (fun (_, eo) -> eo |> exprOptNoSideEffects) | Texp_apply _ -> false diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index fad85b45fa..3d016a7438 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -199,7 +199,7 @@ let rec classify_expression : Typedtree.expression -> sd = | Texp_while _ | Texp_pack _ | Texp_function _ | Texp_extension_constructor _ -> Static - | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}; _} when is_ref vd -> + | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}} when is_ref vd -> Static | Texp_apply _ | Texp_match _ | Texp_ifthenelse _ | Texp_send _ | Texp_field _ | Texp_assert _ | Texp_try _ -> @@ -233,10 +233,10 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = (discard (expression env e3))) | Texp_constant _ -> Use.empty | Texp_apply - {funct = {exp_desc = Texp_ident (_, _, vd)}; args = [(_, Some arg)]; _} + {funct = {exp_desc = Texp_ident (_, _, vd)}; args = [(_, Some arg)]} when is_ref vd -> Use.guard (expression env arg) - | Texp_apply {funct = e; args; _} -> + | Texp_apply {funct = e; args} -> let arg env (_, eo) = option expression env eo in Use.(join (inspect (expression env e)) (inspect (list arg env args))) | Texp_tuple exprs -> Use.guard (list expression env exprs) diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 6d8ad73db8..5c12d3da4d 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -152,7 +152,7 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = sub.value_bindings sub (rec_flag, list); sub.expr sub exp | Texp_function {case; _} -> sub.case sub case - | Texp_apply {funct = exp; args = list; _} -> + | Texp_apply {funct = exp; args = list} -> sub.expr sub exp; List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list | Texp_match (exp, list1, list2, _) -> diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 6da84eb048..f2b10a9474 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -736,7 +736,7 @@ let detect_stdlib_option_call env (funct : expression) | Stdlib_option_fun_map -> let result_cannot_contain_undefined = match callback with - | Stdlib_option_inline_lambda {body; _} -> + | Stdlib_option_inline_lambda {body} -> Typeopt.type_cannot_contain_undefined body.exp_type body.exp_env | Stdlib_option_inline_ident cb -> ( @@ -1076,8 +1076,7 @@ and transl_stdlib_option_call exp opt_expr info oargs = let opt_lam = transl_exp opt_expr in let opt_id = match info.callback with - | Stdlib_option_inline_lambda {param; _} -> - Ident.create (Ident.name param) + | Stdlib_option_inline_lambda {param} -> Ident.create (Ident.name param) | _ -> Ident.create "__res_option_value" in let opt_var = Lvar opt_id in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 82f4875a5e..ffcae708d8 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1838,7 +1838,7 @@ let rec is_nonexpansive exp = List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && is_nonexpansive body | Texp_function _ -> true - | Texp_apply {funct = e; args = (_, None) :: el; _} -> + | Texp_apply {funct = e; args = (_, None) :: el} -> is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) | Texp_match (e, cases, [], _) -> is_nonexpansive e diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index fe60ceac37..9a31b9b5b9 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -227,7 +227,7 @@ end = struct iter_bindings rec_flag list; iter_expression exp | Texp_function {case; _} -> iter_case case - | Texp_apply {funct = exp; args = list; _} -> + | Texp_apply {funct = exp; args = list} -> iter_expression exp; List.iter (fun (_label, expo) -> From 49180431b5bed2a2f7ad39b01bc25299e0572763 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Wed, 24 Sep 2025 18:23:30 +0200 Subject: [PATCH 5/7] Simplify --- compiler/ml/printtyped.ml | 5 ++--- compiler/ml/tast_mapper.ml | 5 +---- compiler/ml/translcore.ml | 29 ++++++++++----------------- compiler/ml/typecore.ml | 41 +------------------------------------- compiler/ml/typedtree.ml | 1 - compiler/ml/typedtree.mli | 1 - 6 files changed, 15 insertions(+), 67 deletions(-) diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 6b41ae6424..064f0ab55c 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -288,12 +288,11 @@ and expression i ppf x = line i ppf "%a" Ident.print param; arg_label i ppf p; case i ppf case_ - | Texp_apply {funct = e; args = l; partial; stdlib_option_call; _} -> + | Texp_apply {funct = e; args = l; partial} -> if partial then line i ppf "partial\n"; line i ppf "Texp_apply\n"; expression i ppf e; - list i label_x_expression ppf l; - if stdlib_option_call then line i ppf "stdlib_option_call\n" else () + list i label_x_expression ppf l | Texp_match (e, l1, l2, _partial) -> line i ppf "Texp_match\n"; expression i ppf e; diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 6a5b417b68..54eba02869 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -198,14 +198,11 @@ 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; transformed_jsx; stdlib_option_call} - -> + | 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; - stdlib_option_call; partial; transformed_jsx; } diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index f2b10a9474..bc6aed352f 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -672,18 +672,15 @@ let stdlib_option_fun_of_path env path = let canonical = Env.normalize_path_prefix None env path in match Path.flatten canonical with | `Contains_apply -> None - | `Ok (head, rest) -> - let segments = Ident.name head :: rest in - let matches fname = - match segments with - | ["Stdlib"; "Option"; name] -> String.equal name fname - | ["Stdlib_Option"; name] -> String.equal name fname - | _ -> false - in - if matches "forEach" then Some Stdlib_option_fun_forEach - else if matches "map" then Some Stdlib_option_fun_map - else if matches "flatMap" then Some Stdlib_option_fun_flatMap - else None + | `Ok (head, rest) -> ( + match (Ident.name head, rest) with + | "Stdlib_Option", [fname] -> ( + match fname with + | "forEach" -> Some Stdlib_option_fun_forEach + | "map" -> Some Stdlib_option_fun_map + | "flatMap" -> Some Stdlib_option_fun_flatMap + | _ -> None) + | _ -> None) let inline_lambda_callback (expr : expression) : stdlib_option_callback option = match expr.exp_desc with @@ -863,15 +860,11 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (Lprim (Pccall (set_transformed_jsx d ~transformed_jsx), argl, e.exp_loc)) | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) - | Texp_apply - {funct; args = oargs; partial; transformed_jsx; stdlib_option_call} -> ( + | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> ( let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in - let option_call_info = - if stdlib_option_call then detect_stdlib_option_call e.exp_env funct oargs - else None - in + let option_call_info = detect_stdlib_option_call e.exp_env funct oargs in let uncurried_partial_application = (* In case of partial application foo(args, ...) when some args are missing, get the arity *) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index ffcae708d8..e93537a8a1 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -143,40 +143,6 @@ type recarg = Allowed | Required | Rejected let case lhs rhs = {c_lhs = lhs; c_guard = None; c_rhs = rhs} -type stdlib_option_fun_kind = - | Stdlib_option_fun_forEach - | Stdlib_option_fun_map - | Stdlib_option_fun_flatMap - -let stdlib_option_fun_of_path env path = - let canonical = Env.normalize_path_prefix None env path in - match Path.flatten canonical with - | `Contains_apply -> None - | `Ok (head, rest) -> - let segments = Ident.name head :: rest in - let matches fname = - match segments with - | ["Stdlib"; "Option"; name] -> String.equal name fname - | ["Stdlib_Option"; name] -> String.equal name fname - | _ -> false - in - if matches "forEach" then Some Stdlib_option_fun_forEach - else if matches "map" then Some Stdlib_option_fun_map - else if matches "flatMap" then Some Stdlib_option_fun_flatMap - else None - -let is_stdlib_option_call env (funct : expression) - (args : (Noloc.arg_label * expression option) list) : bool = - match funct.exp_desc with - | Texp_ident (path, _, _) -> ( - match stdlib_option_fun_of_path env path with - | None -> false - | Some _ -> ( - match args with - | [(Nolabel, Some _); (Nolabel, Some _)] -> true - | _ -> false)) - | _ -> false - (* Upper approximation of free identifiers on the parse tree *) let iter_expression f e = @@ -2482,15 +2448,10 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected end_def (); unify_var env (newvar ()) funct.exp_type; - let stdlib_option_call = - fully_applied && is_stdlib_option_call env funct args - in let mk_apply funct args = rue { - exp_desc = - Texp_apply - {funct; args; partial; transformed_jsx; stdlib_option_call}; + 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 b90cb93d10..9ef328be4a 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -87,7 +87,6 @@ and expression_desc = args: (Noloc.arg_label * expression option) list; partial: bool; transformed_jsx: bool; - stdlib_option_call: 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 167d287d52..6e6b1c5159 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -150,7 +150,6 @@ and expression_desc = args: (Noloc.arg_label * expression option) list; partial: bool; transformed_jsx: bool; - stdlib_option_call: bool; } (** E0 ~l1:E1 ... ~ln:En From 5fb467dde498f380a67425d3affc2a1625ba6ced Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 25 Sep 2025 11:56:17 +0200 Subject: [PATCH 6/7] More efficient matching --- compiler/ml/translcore.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index bc6aed352f..585273be56 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -669,18 +669,19 @@ type stdlib_option_fun_kind = | Stdlib_option_fun_flatMap let stdlib_option_fun_of_path env path = - let canonical = Env.normalize_path_prefix None env path in - match Path.flatten canonical with - | `Contains_apply -> None - | `Ok (head, rest) -> ( - match (Ident.name head, rest) with - | "Stdlib_Option", [fname] -> ( + match Path.last path with + | ("forEach" | "map" | "flatMap") as fname -> ( + let canonical = Env.normalize_path_prefix None env path in + match canonical with + | Path.Pdot (Path.Pident module_ident, _, _) + when Ident.name module_ident = "Stdlib_Option" -> ( match fname with | "forEach" -> Some Stdlib_option_fun_forEach | "map" -> Some Stdlib_option_fun_map | "flatMap" -> Some Stdlib_option_fun_flatMap | _ -> None) | _ -> None) + | _ -> None let inline_lambda_callback (expr : expression) : stdlib_option_callback option = match expr.exp_desc with From ca0af3c2b0227064193af46712f92864f325a810 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 25 Sep 2025 12:05:15 +0200 Subject: [PATCH 7/7] Optimize Belt, too --- compiler/ml/translcore.ml | 3 ++- tests/tests/src/js_string_test.mjs | 12 +++++++----- tests/tests/src/reactTestUtils.mjs | 14 ++++++++++---- 3 files changed, 19 insertions(+), 10 deletions(-) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 585273be56..aa194eaee3 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -674,7 +674,8 @@ let stdlib_option_fun_of_path env path = let canonical = Env.normalize_path_prefix None env path in match canonical with | Path.Pdot (Path.Pident module_ident, _, _) - when Ident.name module_ident = "Stdlib_Option" -> ( + when Ident.name module_ident = "Stdlib_Option" + || Ident.name module_ident = "Belt_Option" -> ( match fname with | "forEach" -> Some Stdlib_option_fun_forEach | "map" -> Some Stdlib_option_fun_map diff --git a/tests/tests/src/js_string_test.mjs b/tests/tests/src/js_string_test.mjs index a5cf627eb9..dda37d7652 100644 --- a/tests/tests/src/js_string_test.mjs +++ b/tests/tests/src/js_string_test.mjs @@ -3,7 +3,6 @@ import * as Mocha from "mocha"; import * as Js_string from "@rescript/runtime/lib/es6/Js_string.js"; import * as Test_utils from "./test_utils.mjs"; -import * as Belt_Option from "@rescript/runtime/lib/es6/Belt_Option.js"; import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.js"; Mocha.describe("Js_string_test", () => { @@ -34,10 +33,13 @@ Mocha.describe("Js_string_test", () => { "na" ], Primitive_option.fromNull("banana".match(/na+/g)))); Mocha.test("match - no match", () => Test_utils.eq("File \"js_string_test.res\", line 34, characters 36-43", undefined, Primitive_option.fromNull("banana".match(/nanana+/g)))); - Mocha.test("match - not found capture groups", () => Test_utils.eq("File \"js_string_test.res\", line 37, characters 6-13", [ - "hello ", - undefined - ], Belt_Option.map(Primitive_option.fromNull("hello word".match(/hello (world)?/)), prim => prim.slice()))); + Mocha.test("match - not found capture groups", () => { + let __res_option_value = "hello word".match(/hello (world)?/); + Test_utils.eq("File \"js_string_test.res\", line 37, characters 6-13", [ + "hello ", + undefined + ], __res_option_value !== null ? __res_option_value.slice() : undefined); + }); Mocha.test("normalize", () => Test_utils.eq("File \"js_string_test.res\", line 43, characters 29-36", "foo", "foo".normalize())); Mocha.test("normalizeByForm", () => Test_utils.eq("File \"js_string_test.res\", line 44, characters 35-42", "foo", "foo".normalize("NFKD"))); Mocha.test("repeat", () => Test_utils.eq("File \"js_string_test.res\", line 46, characters 26-33", "foofoofoo", "foo".repeat(3))); diff --git a/tests/tests/src/reactTestUtils.mjs b/tests/tests/src/reactTestUtils.mjs index 287c48bf63..a4a6b61c45 100644 --- a/tests/tests/src/reactTestUtils.mjs +++ b/tests/tests/src/reactTestUtils.mjs @@ -64,14 +64,20 @@ let DOM = { function prepareContainer(container, param) { let containerElement = document.createElement("div"); - Belt_Option.map(document.body, body => body.appendChild(containerElement)); + let body = document.body; + if (body !== undefined) { + let body$1 = Primitive_option.valFromOption(body); + Primitive_option.some(body$1.appendChild(containerElement)); + } container.contents = Primitive_option.some(containerElement); } function cleanupContainer(container, param) { - Belt_Option.map(container.contents, prim => { - prim.remove(); - }); + let __res_option_value = container.contents; + if (__res_option_value !== undefined) { + let __res_option_value$1 = Primitive_option.valFromOption(__res_option_value); + Primitive_option.some((__res_option_value$1.remove(), undefined)); + } container.contents = undefined; }