From e984b6f62b9d2fc861267cf4ba2feaffba8e9670 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 25 Apr 2023 10:03:09 +0200 Subject: [PATCH] Fix partial application for uncurried functions with labeled args Partial application for uncurried functions used normal application. There's an issue with the code generated in the presence of labeled arguments, ad the function generated is curried. This PR changes the translation from typed ast to lambda for the uncurried partial application case, by writing a single function with all the leftover arguments. So it correctly represents an uncurried function. Fixex https://github.com/rescript-lang/rescript-compiler/issues/6164 --- CHANGELOG.md | 1 + jscomp/ml/ast_uncurried.ml | 6 ++ jscomp/ml/translcore.ml | 46 ++++++++++++-- jscomp/ml/typecore.ml | 10 +-- jscomp/test/UncurriedAlways.js | 109 +++++++++++++++++++++++++++++++- jscomp/test/UncurriedAlways.res | 33 ++++++++++ 6 files changed, 191 insertions(+), 14 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 699b88bc72..3cf78e3e12 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -27,6 +27,7 @@ #### :bug: Bug Fix - Make "rescript format" work with node 10 again and set minimum required node version to 10 in package.json. https://github.com/rescript-lang/rescript-compiler/pull/6186 +- Fix partial application for uncurried functions with labeled args https://github.com/rescript-lang/rescript-compiler/pull/6198 # 11.0.0-alpha.4 diff --git a/jscomp/ml/ast_uncurried.ml b/jscomp/ml/ast_uncurried.ml index c142c0af04..09341a709a 100644 --- a/jscomp/ml/ast_uncurried.ml +++ b/jscomp/ml/ast_uncurried.ml @@ -106,3 +106,9 @@ let uncurried_type_get_arity ~env typ = | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) -> type_to_arity tArity | _ -> assert false + +let uncurried_type_get_arity_opt ~env typ = + match (Ctype.expand_head env typ).desc with + | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) -> + Some (type_to_arity tArity) + | _ -> None diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml index c2c07b790a..51479622cf 100644 --- a/jscomp/ml/translcore.ml +++ b/jscomp/ml/translcore.ml @@ -762,7 +762,14 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in - transl_apply ~inlined (transl_exp funct) oargs e.exp_loc + let uncurried_partial_application = + let uncurried_partial_app = Ext_list.exists e.exp_attributes (fun ({txt },_) -> txt = "res.partial") in + if uncurried_partial_app then + let arity_opt = Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env funct.exp_type in + arity_opt + else + None in + transl_apply ~inlined ~uncurried_partial_application (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) -> @@ -978,7 +985,7 @@ and transl_cases_try cases = in List.map transl_case_try cases -and transl_apply ?(inlined = Default_inline) lam sargs loc = +and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application=None) lam sargs loc = let lapply funct args = match funct with (* Attention: This may not be what we need to change the application arity*) @@ -1028,11 +1035,36 @@ and transl_apply ?(inlined = Default_inline) lam sargs loc = | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l | [] -> lapply lam (List.rev_map fst args) in - (build_apply lam [] - (List.map - (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l)) - sargs) - : Lambda.lambda) + match uncurried_partial_application with + | Some arity when arity > List.length sargs -> + let extra_arity = arity - List.length sargs in + let none_ids = ref [] in + let args = Ext_list.filter_map sargs (function + | _, Some e -> + Some (transl_exp e) + | _, None -> + let id_arg = Ident.create "none" in + none_ids := id_arg :: !none_ids; + Some (Lvar id_arg)) in + let extra_ids = ref [] in + extra_ids := Ident.create "extra" :: !extra_ids; + let extra_ids = Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list in + 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 } in + Lfunction + { + params = List.rev_append !none_ids extra_ids ; + body = l0; + attr = default_function_attribute; + loc; + } + | _ -> + (build_apply lam [] + (List.map + (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l)) + sargs) + : Lambda.lambda) and transl_function loc partial param cases = match cases with diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index e9aea7c5ff..143aa57bd7 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -3035,7 +3035,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex (fully_applied, newT) | _ -> (false, newT) in - let rec type_unknown_args max_arity (args : lazy_args) omitted ty_fun (syntax_args : sargs) + let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun (syntax_args : sargs) : targs * _ = match syntax_args with | [] -> @@ -3050,14 +3050,14 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex | Tarrow (Optional l,t1,t2,_) -> ignored := (Optional l,t1,ty_fun.level) :: !ignored; let arg = Optional l, Some (fun () -> option_none (instance env t1) Location.none) in - type_unknown_args max_arity (arg::args) omitted t2 [] + type_unknown_args max_arity ~args:(arg::args) omitted t2 [] | _ -> collect_args ()) else collect_args () | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] when uncurried && omitted = [] && args <> [] && List.length args = List.length !ignored -> (* foo(. ) treated as empty application if all args are optional (hence ignored) *) - type_unknown_args max_arity args omitted ty_fun [] + type_unknown_args max_arity ~args omitted ty_fun [] | (l1, sarg1) :: sargl -> let (ty1, ty2) = let ty_fun = expand_head env ty_fun in @@ -3097,7 +3097,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex unify_exp env arg1 (type_option(newvar())); arg1 in - type_unknown_args max_arity ((l1, Some arg1) :: args) omitted ty2 sargl + type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 sargl in let rec type_args max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) = match expand_head env ty_fun, expand_head env ty_fun0 with @@ -3130,7 +3130,7 @@ and type_application uncurried env funct (sargs : sargs) : targs * Types.type_ex in type_args max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs | _ -> - type_unknown_args max_arity args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*) + type_unknown_args max_arity ~args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*) in let () = let ls, tvar = list_labels env funct.exp_type in diff --git a/jscomp/test/UncurriedAlways.js b/jscomp/test/UncurriedAlways.js index ed411950a6..5e05333f89 100644 --- a/jscomp/test/UncurriedAlways.js +++ b/jscomp/test/UncurriedAlways.js @@ -24,8 +24,8 @@ console.log(a); return x + 1 | 0; }); -function ptl(param) { - return foo(10, param); +function ptl(extra) { + return 10 + extra | 0; } function foo2(x, y) { @@ -56,6 +56,108 @@ function inl2(x, y) { return x + y | 0; } +function foo$1(x, y, z) { + return [ + x, + y, + z + ]; +} + +function ptl$1(none, extra) { + return [ + none, + "y", + extra + ]; +} + +var a1 = [ + "x", + "y", + "z" +]; + +console.log("a1:", a1); + +var AllLabels = { + foo: foo$1, + ptl: ptl$1, + a1: a1 +}; + +function foo$2(x, y, z, dOpt) { + var d = dOpt !== undefined ? dOpt : "d=0"; + return [ + x, + y, + z, + d + ]; +} + +function ptl$2(none, extra, extra$1) { + return foo$2(none, "y", extra, extra$1); +} + +var b1 = ptl$2("x", "z", undefined); + +console.log("b1:", b1); + +var b2 = ptl$2("x", "z", "d<-100"); + +console.log("b2:", b2); + +var OptAtEnd = { + foo: foo$2, + ptl: ptl$2, + b1: b1, + b2: b2 +}; + +function foo$3(d1Opt, x, d2Opt, y, d3Opt, z, d4Opt, w, d5Opt) { + var d1 = d1Opt !== undefined ? d1Opt : "d1=0"; + var d2 = d2Opt !== undefined ? d2Opt : "d2=0"; + var d3 = d3Opt !== undefined ? d3Opt : "d3=0"; + var d4 = d4Opt !== undefined ? d4Opt : "d4=0"; + var d5 = d5Opt !== undefined ? d5Opt : "d5=0"; + return [ + d1, + x, + d2, + y, + d3, + z, + d4, + w, + d5 + ]; +} + +function ptl$3(none, none$1, none$2, none$3, none$4, none$5, extra) { + return foo$3(none, none$1, none$2, "y", none$3, none$4, none$5, "w", extra); +} + +var c1 = ptl$3(undefined, "x", undefined, undefined, "z", undefined, undefined); + +console.log("c1:", c1); + +var c2 = ptl$3("d1<-100", "x", undefined, undefined, "z", undefined, undefined); + +console.log("c2:", c2); + +var c3 = ptl$3(undefined, "x", "d2<-200", undefined, "z", "d4<-400", undefined); + +console.log("c3:", c3); + +var OptMixed = { + foo: foo$3, + ptl: ptl$3, + c1: c1, + c2: c2, + c3: c3 +}; + exports.foo = foo; exports.z = z; exports.bar = bar; @@ -70,4 +172,7 @@ exports.bar3 = bar3; exports.q = q; exports.inl = inl; exports.inl2 = inl2; +exports.AllLabels = AllLabels; +exports.OptAtEnd = OptAtEnd; +exports.OptMixed = OptMixed; /* Not a pure module */ diff --git a/jscomp/test/UncurriedAlways.res b/jscomp/test/UncurriedAlways.res index 76f41443d1..a5985bd7cf 100644 --- a/jscomp/test/UncurriedAlways.res +++ b/jscomp/test/UncurriedAlways.res @@ -32,3 +32,36 @@ let inl = () => () @inline let inl2 = (x,y) => x+y + +module AllLabels = { + let foo = (~x, ~y, ~z) => (x, y, z) + + let ptl = foo(~y="y", ...) + + let a1 = ptl(~x="x", ~z="z") + Js.log2("a1:", a1) +} + +module OptAtEnd = { + let foo = (~x, ~y, ~z, ~d="d=0") => (x, y, z, d) + + let ptl = foo(~y="y", ...) + + let b1 = ptl(~x="x", ~z="z") + Js.log2("b1:", b1) + let b2 = ptl(~x="x", ~z="z", ~d="d<-100") + Js.log2("b2:", b2) +} + +module OptMixed = { + let foo = (~d1="d1=0", ~x, ~d2="d2=0", ~y, ~d3="d3=0", ~z, ~d4="d4=0", ~w, ~d5="d5=0") => (d1, x, d2, y, d3, z, d4, w, d5) + + let ptl = foo(~y="y", ~w="w", ...) + + let c1 = ptl(~x="x", ~z="z") + Js.log2("c1:", c1) + let c2 = ptl(~x="x", ~z="z", ~d1="d1<-100") + Js.log2("c2:", c2) + let c3 = ptl(~x="x", ~z="z", ~d2="d2<-200", ~d4="d4<-400") + Js.log2("c3:", c3) +}