From eeefa39f0782769070e16e1132f0a2166d565a92 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 2 Feb 2025 12:10:51 +0100 Subject: [PATCH 1/4] Experiment with emitting functors as 1 arg at a time See https://github.com/rescript-lang/rescript/issues/7245 --- compiler/ml/translmod.ml | 18 +++++++-- tests/tests/src/functors.mjs | 40 ++++++++++++------- .../tests/src/functors_one_arg_at_a_time.mjs | 38 ++++++++++++++++++ .../tests/src/functors_one_arg_at_a_time.res | 17 ++++++++ tests/tests/src/recmodule.mjs | 14 ++++--- 5 files changed, 102 insertions(+), 25 deletions(-) create mode 100644 tests/tests/src/functors_one_arg_at_a_time.mjs create mode 100644 tests/tests/src/functors_one_arg_at_a_time.res diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index e3e0ead663..b67c14140a 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -220,7 +220,7 @@ let merge_inline_attributes (attr1 : Lambda.inline_attribute) else raise (Error (loc, Conflicting_inline_attributes)) let merge_functors mexp coercion root_path = - let rec merge mexp coercion path acc inline_attribute = + let merge mexp coercion path acc inline_attribute = let finished = (acc, mexp, path, coercion, inline_attribute) in match mexp.mod_desc with | Tmod_functor (param, _, _, body) -> @@ -239,9 +239,19 @@ let merge_functors mexp coercion root_path = let inline_attribute = merge_inline_attributes inline_attribute inline_attribute' loc in - merge body res_coercion path - ((param, loc, arg_coercion) :: acc) - inline_attribute + let r = + ( (param, loc, arg_coercion) :: acc, + body, + path, + res_coercion, + inline_attribute ) + in + (* let _ = + merge body res_coercion path + ((param, loc, arg_coercion) :: acc) + inline_attribute + in *) + r | _ -> finished in merge mexp coercion root_path [] Default_inline diff --git a/tests/tests/src/functors.mjs b/tests/tests/src/functors.mjs index 3552471b2e..8eb7803621 100644 --- a/tests/tests/src/functors.mjs +++ b/tests/tests/src/functors.mjs @@ -10,32 +10,42 @@ function O(X) { }; } -function F(X, Y) { - let cow = x => Y.foo(X.foo(x)); - let sheep = x => 1 + Y.foo(X.foo(x)) | 0; - return { - cow: cow, - sheep: sheep +function F(X) { + return Y => { + let cow = x => Y.foo(X.foo(x)); + let sheep = x => 1 + Y.foo(X.foo(x)) | 0; + return { + cow: cow, + sheep: sheep + }; }; } -function F1(X, Y) { - let sheep = x => 1 + Y.foo(X.foo(x)) | 0; - return { - sheep: sheep +function F1(X) { + return Y => { + let sheep = x => 1 + Y.foo(X.foo(x)) | 0; + return { + sheep: sheep + }; }; } -function F2(X, Y) { - let sheep = x => 1 + Y.foo(X.foo(x)) | 0; - return { - sheep: sheep +function F2(X) { + return Y => { + let sheep = x => 1 + Y.foo(X.foo(x)) | 0; + return { + sheep: sheep + }; }; } let M = { F: (funarg, funarg$1) => { - let sheep = x => 1 + funarg$1.foo(funarg.foo(x)) | 0; + let Y = { + foo: funarg$1.foo + }; + let cow = x => Y.foo(funarg.foo(x)); + let sheep = x => 1 + cow(x) | 0; return { sheep: sheep }; diff --git a/tests/tests/src/functors_one_arg_at_a_time.mjs b/tests/tests/src/functors_one_arg_at_a_time.mjs new file mode 100644 index 0000000000..a311a0e7f9 --- /dev/null +++ b/tests/tests/src/functors_one_arg_at_a_time.mjs @@ -0,0 +1,38 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function Make(T) { + return Q => { + let Eq = E => (A => ({})); + return { + Eq: Eq + }; + }; +} + +function Eq(E) { + return A => ({}); +} + +let M = { + Eq: Eq +}; + +let EQ = Eq({})({}); + +let MF = { + F: (funarg, funarg$1) => ({}) +}; + +function UseF(X) { + return Y => MF.F(X)(Y); +} + +export { + Make, + M, + EQ, + MF, + UseF, +} +/* EQ Not a pure module */ diff --git a/tests/tests/src/functors_one_arg_at_a_time.res b/tests/tests/src/functors_one_arg_at_a_time.res new file mode 100644 index 0000000000..9d1e3522df --- /dev/null +++ b/tests/tests/src/functors_one_arg_at_a_time.res @@ -0,0 +1,17 @@ +module Make = (T: {}, Q: {}) => { + module Eq = (E: {}, A: {}) => {} +} + +module M = Make((), ()) + +module EQ = M.Eq((), ()) + +module MF: { + module F: (X: {}, Y: {}) => {} +} = { + module F = (X: {}, Y: {}) => { + let c = 12 + } +} + +module UseF = (X: {}, Y: {}) => MF.F(X, Y) diff --git a/tests/tests/src/recmodule.mjs b/tests/tests/src/recmodule.mjs index 1b5fde4180..a7deb81e2f 100644 --- a/tests/tests/src/recmodule.mjs +++ b/tests/tests/src/recmodule.mjs @@ -18,12 +18,14 @@ let UseCase = { MakeLayer: MakeLayer }; -function MakeLayer$1(Deps, UC) { - let presentLight = light => Deps.presentJson(light, 200); - let handleGetLight = req => UC.getLight(req.params.id); - return { - handleGetLight: handleGetLight, - presentLight: presentLight +function MakeLayer$1(Deps) { + return UC => { + let presentLight = light => Deps.presentJson(light, 200); + let handleGetLight = req => UC.getLight(req.params.id); + return { + handleGetLight: handleGetLight, + presentLight: presentLight + }; }; } From aff0dec0bbd878ab9201ca32bcba4f14bee67950 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 2 Feb 2025 12:21:17 +0100 Subject: [PATCH 2/4] Turn off apply nested coercion. --- compiler/ml/translmod.ml | 10 +++++----- tests/tests/src/functors.mjs | 10 +++------- tests/tests/src/functors_one_arg_at_a_time.mjs | 2 +- 3 files changed, 9 insertions(+), 13 deletions(-) diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index b67c14140a..3d7646125a 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -87,11 +87,11 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = and apply_coercion_result loc strict funct params args cc_res = match cc_res with - | Tcoerce_functor (cc_arg, cc_res) -> - let param = Ident.create "funarg" in - let arg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict funct (param :: params) (arg :: args) - cc_res + (* | Tcoerce_functor (cc_arg, cc_res) -> + let param = Ident.create "funarg" in + let arg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict funct (param :: params) (arg :: args) + cc_res *) | _ -> Lambda.name_lambda strict funct (fun id -> Lfunction diff --git a/tests/tests/src/functors.mjs b/tests/tests/src/functors.mjs index 8eb7803621..9bdf8ab895 100644 --- a/tests/tests/src/functors.mjs +++ b/tests/tests/src/functors.mjs @@ -40,16 +40,12 @@ function F2(X) { } let M = { - F: (funarg, funarg$1) => { - let Y = { - foo: funarg$1.foo - }; - let cow = x => Y.foo(funarg.foo(x)); - let sheep = x => 1 + cow(x) | 0; + F: funarg => (funarg$1 => { + let sheep = x => 1 + funarg$1.foo(funarg.foo(x)) | 0; return { sheep: sheep }; - } + }) }; export { diff --git a/tests/tests/src/functors_one_arg_at_a_time.mjs b/tests/tests/src/functors_one_arg_at_a_time.mjs index a311a0e7f9..53ceefd2fe 100644 --- a/tests/tests/src/functors_one_arg_at_a_time.mjs +++ b/tests/tests/src/functors_one_arg_at_a_time.mjs @@ -21,7 +21,7 @@ let M = { let EQ = Eq({})({}); let MF = { - F: (funarg, funarg$1) => ({}) + F: funarg => (funarg => ({})) }; function UseF(X) { From fea4ce3e1a670ff2034fc8428f60ad01c91a4ce2 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 6 Feb 2025 14:33:37 +0100 Subject: [PATCH 3/4] Refactor: simplify functor translation and remove merged functors support Simplify functor translation and remove merged functors support - Remove Conflicting_inline_attributes error type and related checks - Simplify apply_coercion_result to handle single parameters instead of lists - Replace recursive merge_functors with get_functor_params for single-level handling - Streamline compile_functor to process individual functor parameters directly - Remove obsolete code for handling merged functors and inline attribute merging These changes simplify the functor translation logic by eliminating support for merged functors and associated complex coercion handling, focusing on single-level functor processing instead. --- compiler/ml/translmod.ml | 132 +++++++++++++-------------------------- 1 file changed, 45 insertions(+), 87 deletions(-) diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 3d7646125a..f815a536c0 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -18,7 +18,7 @@ open Typedtree -type error = Conflicting_inline_attributes | Fragile_pattern_in_toplevel +type error = Fragile_pattern_in_toplevel exception Error of Location.t * error @@ -78,37 +78,30 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_functor (cc_arg, cc_res) -> let param = Ident.create "funarg" in let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [param] [carg] cc_res + apply_coercion_result loc strict arg param carg cc_res | Tcoerce_primitive {pc_loc; pc_desc; pc_env; pc_type} -> Translcore.transl_primitive pc_loc pc_desc pc_env pc_type | Tcoerce_alias (path, cc) -> Lambda.name_lambda strict arg (fun _ -> apply_coercion loc Alias cc (Lambda.transl_normal_path path)) -and apply_coercion_result loc strict funct params args cc_res = - match cc_res with - (* | Tcoerce_functor (cc_arg, cc_res) -> - let param = Ident.create "funarg" in - let arg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict funct (param :: params) (arg :: args) - cc_res *) - | _ -> - Lambda.name_lambda strict funct (fun id -> - Lfunction - { - params = List.rev params; - attr = {Lambda.default_function_attribute with is_a_functor = true}; - loc; - body = - apply_coercion loc Strict cc_res - (Lapply - { - ap_loc = loc; - ap_func = Lvar id; - ap_args = List.rev args; - ap_inlined = Default_inline; - }); - }) +and apply_coercion_result loc strict funct param arg cc_res = + Lambda.name_lambda strict funct (fun id -> + Lfunction + { + params = [param]; + attr = {Lambda.default_function_attribute with is_a_functor = true}; + loc; + body = + apply_coercion loc Strict cc_res + (Lapply + { + ap_loc = loc; + ap_func = Lvar id; + ap_args = [arg]; + ap_inlined = Default_inline; + }); + }) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = Lambda.free_variables lam in @@ -210,74 +203,41 @@ let rec bound_value_identifiers : Types.signature_item list -> Ident.t list = functor(s) being merged with. Such an attribute will be placed on the resulting merged functor. *) -let merge_inline_attributes (attr1 : Lambda.inline_attribute) - (attr2 : Lambda.inline_attribute) loc = - match (attr1, attr2) with - | Lambda.Default_inline, _ -> attr2 - | _, Lambda.Default_inline -> attr1 - | _, _ -> - if attr1 = attr2 then attr1 - else raise (Error (loc, Conflicting_inline_attributes)) - -let merge_functors mexp coercion root_path = - let merge mexp coercion path acc inline_attribute = - let finished = (acc, mexp, path, coercion, inline_attribute) in - match mexp.mod_desc with - | Tmod_functor (param, _, _, body) -> - let inline_attribute' = - Translattribute.get_inline_attribute mexp.mod_attributes - in - let arg_coercion, res_coercion = - match coercion with - | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) - | Tcoerce_functor (arg_coercion, res_coercion) -> - (arg_coercion, res_coercion) - | _ -> Misc.fatal_error "Translmod.merge_functors: bad coercion" - in - let loc = mexp.mod_loc in - let path = functor_path path param in - let inline_attribute = - merge_inline_attributes inline_attribute inline_attribute' loc - in - let r = - ( (param, loc, arg_coercion) :: acc, - body, - path, - res_coercion, - inline_attribute ) - in - (* let _ = - merge body res_coercion path - ((param, loc, arg_coercion) :: acc) - inline_attribute - in *) - r - | _ -> finished - in - merge mexp coercion root_path [] Default_inline +let get_functor_params mexp coercion root_path = + match mexp.mod_desc with + | Tmod_functor (param, _, _, body) -> + let inline_attribute = + Translattribute.get_inline_attribute mexp.mod_attributes + in + let arg_coercion, res_coercion = + match coercion with + | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) + | Tcoerce_functor (arg_coercion, res_coercion) -> + (arg_coercion, res_coercion) + | _ -> Misc.fatal_error "Translmod.get_functor_params: bad coercion" + in + let loc = mexp.mod_loc in + let path = functor_path root_path param in + ((param, loc, arg_coercion), body, path, res_coercion, inline_attribute) + | _ -> assert false let export_identifiers : Ident.t list ref = ref [] let rec compile_functor mexp coercion root_path loc = - let functor_params_rev, body, body_path, res_coercion, inline_attribute = - merge_functors mexp coercion root_path + let functor_param, body, body_path, res_coercion, inline_attribute = + get_functor_params mexp coercion root_path in - assert (functor_params_rev <> []); (* cf. [transl_module] *) - let params, body = - List.fold_left - (fun (params, body) (param, loc, arg_coercion) -> - let param' = Ident.rename param in - let arg = apply_coercion loc Alias arg_coercion (Lvar param') in - let params = param' :: params in - let body = Lambda.Llet (Alias, Pgenval, param, arg, body) in - (params, body)) - ([], transl_module res_coercion body_path body) - functor_params_rev + let param, loc_, arg_coercion = functor_param in + let param' = Ident.rename param in + let arg = apply_coercion loc_ Alias arg_coercion (Lvar param') in + let body = + Lambda.Llet + (Alias, Pgenval, param, arg, transl_module res_coercion body_path body) in Lambda.Lfunction { - params; + params = [param']; attr = { inline = inline_attribute; @@ -523,8 +483,6 @@ let transl_implementation module_name (str, cc) = (* Error report *) let report_error ppf = function - | Conflicting_inline_attributes -> - Format.fprintf ppf "@[Conflicting ``inline'' attributes@]" | Fragile_pattern_in_toplevel -> Format.fprintf ppf "@[Such fragile pattern not allowed in the toplevel@]" From d47e4327583e635f3e63b3b5d1189d22692468c0 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 7 Feb 2025 15:44:40 +0100 Subject: [PATCH 4/4] Update CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 999a7b82c4..b1f6a4b065 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,7 @@ - Fix issue with type environment for unified ops. https://github.com/rescript-lang/rescript/pull/7277 - Fix completion for application with tagged template. https://github.com/rescript-lang/rescript/pull/7278 - Fix error message for arity in the presence of optional arguments. https://github.com/rescript-lang/rescript/pull/7284 +- Fix issue in functors with more than one argument (which are curried): emit nested function always. https://github.com/rescript-lang/rescript/pull/7273 # 12.0.0-alpha.8