From 72050881a4927da5232ac6202ffe0e97bf02e517 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sat, 28 Sep 2024 10:49:11 +0900 Subject: [PATCH 01/16] PoC: generic infix operators --- compiler/core/lam_convert.ml | 11 + compiler/ml/lambda.ml | 4 + compiler/ml/lambda.mli | 4 + compiler/ml/printlambda.ml | 2 + compiler/ml/translcore.ml | 242 +++++---- compiler/ml/typecore.ml | 467 ++++++++++-------- runtime/Pervasives.res | 4 +- runtime/rescript.json | 2 +- .../math_operator_constant.res.expected | 10 +- .../expected/math_operator_int.res.expected | 20 - .../math_operator_string.res.expected | 16 - .../expected/primitives1.res.expected | 18 +- .../super_errors/expected/type1.res.expected | 18 +- tests/tests/src/generic_infix_test.js | 37 ++ tests/tests/src/generic_infix_test.res | 9 + 15 files changed, 470 insertions(+), 394 deletions(-) create mode 100644 tests/tests/src/generic_infix_test.js create mode 100644 tests/tests/src/generic_infix_test.res diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 74131236ab..fcfa102098 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -232,6 +232,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pduprecord -> prim ~primitive:Pduprecord ~args loc | Plazyforce -> prim ~primitive:Plazyforce ~args loc | Praise _ -> prim ~primitive:Praise ~args loc + | Pinfix _ -> assert false | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc | Pobjorder -> prim ~primitive:Pobjorder ~args loc | Pobjmin -> prim ~primitive:Pobjmin ~args loc @@ -475,6 +476,16 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lprim (Pimport, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import:true) in lam_prim ~primitive:Pimport ~args loc + | Lprim (Pinfix (Inf_custom (mod_, op)), args, loc) -> + let fn = Lam.var (Ident.create_persistent op) in + let args = Ext_list.map args (convert_aux ~dynamic_import) in + let ap_info : Lam.ap_info = + {ap_loc = loc; ap_status = App_na; ap_inlined = Lambda.Default_inline} + in + Lam.apply fn args ap_info + | Lprim (Pinfix Inf_invariant, args, loc) -> + (* TODO : invariant *) + assert false | Lprim (primitive, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import) in lam_prim ~primitive ~args loc diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index fcd1dc86ca..857cfa991f 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -175,6 +175,8 @@ type immediate_or_pointer = Immediate | Pointer type is_safe = Safe | Unsafe +type infix_info = Inf_custom of string * string | Inf_invariant + type primitive = | Pidentity | Pignore @@ -198,6 +200,8 @@ type primitive = | Pccall of Primitive.description (* Exceptions *) | Praise of raise_kind + (* Infix *) + | Pinfix of infix_info (* object operations *) | Pobjcomp of comparison | Pobjorder diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 7f506ac62d..e2605c3029 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -138,6 +138,8 @@ type pointer_info = | Pt_shape_none | Pt_assertfalse +type infix_info = Inf_custom of string * string | Inf_invariant + type primitive = | Pidentity | Pignore @@ -161,6 +163,8 @@ type primitive = | Pccall of Primitive.description (* Exceptions *) | Praise of raise_kind + (* Infix *) + | Pinfix of infix_info (* object primitives *) | Pobjcomp of comparison | Pobjorder diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 4512355c34..a01b305dfc 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -125,6 +125,8 @@ let primitive ppf = function | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) + | Pinfix (Inf_custom (mod_, op)) -> fprintf ppf "%s.%s" mod_ op + | Pinfix Inf_invariant -> fprintf ppf "invariant" | Pobjcomp Ceq -> fprintf ppf "==" | Pobjcomp Cneq -> fprintf ppf "!=" | Pobjcomp Clt -> fprintf ppf "<" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 04c80e8e09..b741f5deb7 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -50,157 +50,182 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) type specialized = { - objcomp: Lambda.primitive; - intcomp: Lambda.primitive; - boolcomp: Lambda.primitive; - floatcomp: Lambda.primitive; - stringcomp: Lambda.primitive; - bigintcomp: Lambda.primitive; + obj: Lambda.primitive; + int: Lambda.primitive; + bool: Lambda.primitive; + float: Lambda.primitive; + string: Lambda.primitive; + bigint: Lambda.primitive; simplify_constant_constructor: bool; } +let infix_table = + create_hashtable + [| + ( "%add", + { + obj = Paddint; + int = Paddint; + bool = Pinfix Inf_invariant; + float = Paddfloat; + string = Pstringadd; + bigint = Paddbigint; + simplify_constant_constructor = false; + } ); + ( "%sub", + { + obj = Paddint; + int = Psubint; + bool = Pinfix Inf_invariant; + float = Psubfloat; + string = Pinfix Inf_invariant; + bigint = Psubbigint; + simplify_constant_constructor = false; + } ); + |] + let comparisons_table = create_hashtable [| ( "%equal", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = true; } ); ( "%notequal", { - objcomp = Pobjcomp Cneq; - intcomp = Pintcomp Cneq; - boolcomp = Pboolcomp Cneq; - floatcomp = Pfloatcomp Cneq; - stringcomp = Pstringcomp Cneq; - bigintcomp = Pbigintcomp Cneq; + obj = Pobjcomp Cneq; + int = Pintcomp Cneq; + bool = Pboolcomp Cneq; + float = Pfloatcomp Cneq; + string = Pstringcomp Cneq; + bigint = Pbigintcomp Cneq; simplify_constant_constructor = true; } ); ( "%lessthan", { - objcomp = Pobjcomp Clt; - intcomp = Pintcomp Clt; - boolcomp = Pboolcomp Clt; - floatcomp = Pfloatcomp Clt; - stringcomp = Pstringcomp Clt; - bigintcomp = Pbigintcomp Clt; + obj = Pobjcomp Clt; + int = Pintcomp Clt; + bool = Pboolcomp Clt; + float = Pfloatcomp Clt; + string = Pstringcomp Clt; + bigint = Pbigintcomp Clt; simplify_constant_constructor = false; } ); ( "%greaterthan", { - objcomp = Pobjcomp Cgt; - intcomp = Pintcomp Cgt; - boolcomp = Pboolcomp Cgt; - floatcomp = Pfloatcomp Cgt; - stringcomp = Pstringcomp Cgt; - bigintcomp = Pbigintcomp Cgt; + obj = Pobjcomp Cgt; + int = Pintcomp Cgt; + bool = Pboolcomp Cgt; + float = Pfloatcomp Cgt; + string = Pstringcomp Cgt; + bigint = Pbigintcomp Cgt; simplify_constant_constructor = false; } ); ( "%lessequal", { - objcomp = Pobjcomp Cle; - intcomp = Pintcomp Cle; - boolcomp = Pboolcomp Cle; - floatcomp = Pfloatcomp Cle; - stringcomp = Pstringcomp Cle; - bigintcomp = Pbigintcomp Cle; + obj = Pobjcomp Cle; + int = Pintcomp Cle; + bool = Pboolcomp Cle; + float = Pfloatcomp Cle; + string = Pstringcomp Cle; + bigint = Pbigintcomp Cle; simplify_constant_constructor = false; } ); ( "%greaterequal", { - objcomp = Pobjcomp Cge; - intcomp = Pintcomp Cge; - boolcomp = Pboolcomp Cge; - floatcomp = Pfloatcomp Cge; - stringcomp = Pstringcomp Cge; - bigintcomp = Pbigintcomp Cge; + obj = Pobjcomp Cge; + int = Pintcomp Cge; + bool = Pboolcomp Cge; + float = Pfloatcomp Cge; + string = Pstringcomp Cge; + bigint = Pbigintcomp Cge; simplify_constant_constructor = false; } ); ( "%compare", { - objcomp = Pobjorder; - intcomp = Pintorder; - boolcomp = Pboolorder; - floatcomp = Pfloatorder; - stringcomp = Pstringorder; - bigintcomp = Pbigintorder; + obj = Pobjorder; + int = Pintorder; + bool = Pboolorder; + float = Pfloatorder; + string = Pstringorder; + bigint = Pbigintorder; simplify_constant_constructor = false; } ); ( "%max", { - objcomp = Pobjmax; - intcomp = Pintmax; - boolcomp = Pboolmax; - floatcomp = Pboolmax; - stringcomp = Pstringmax; - bigintcomp = Pbigintmax; + obj = Pobjmax; + int = Pintmax; + bool = Pboolmax; + float = Pboolmax; + string = Pstringmax; + bigint = Pbigintmax; simplify_constant_constructor = false; } ); ( "%min", { - objcomp = Pobjmin; - intcomp = Pintmin; - boolcomp = Pboolmin; - floatcomp = Pfloatmin; - stringcomp = Pstringmin; - bigintcomp = Pbigintmin; + obj = Pobjmin; + int = Pintmin; + bool = Pboolmin; + float = Pfloatmin; + string = Pstringmin; + bigint = Pbigintmin; simplify_constant_constructor = false; } ); ( "%equal_null", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); ( "%equal_undefined", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); ( "%equal_nullable", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); (* FIXME: Core compatibility *) ( "%bs_min", { - objcomp = Pobjmax; - intcomp = Pintmax; - boolcomp = Pboolmax; - floatcomp = Pboolmax; - stringcomp = Pstringmax; - bigintcomp = Pbigintmax; + obj = Pobjmax; + int = Pintmax; + bool = Pboolmax; + float = Pboolmax; + string = Pstringmax; + bigint = Pbigintmax; simplify_constant_constructor = false; } ); ( "%bs_max", { - objcomp = Pobjmin; - intcomp = Pintmin; - boolcomp = Pboolmin; - floatcomp = Pfloatmin; - stringcomp = Pstringmin; - bigintcomp = Pbigintmin; + obj = Pobjmin; + int = Pintmin; + bool = Pboolmin; + float = Pfloatmin; + string = Pstringmin; + bigint = Pbigintmin; simplify_constant_constructor = false; } ); |] @@ -375,31 +400,36 @@ let primitives_table = let find_primitive prim_name = Hashtbl.find primitives_table prim_name -let specialize_comparison - ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} : - specialized) env ty = +let specialize_op ({obj; int; float; string; bigint; bool} : specialized) env ty + = match () with | () when is_base_type env ty Predef.path_int || is_base_type env ty Predef.path_char || maybe_pointer_type env ty = Immediate -> - intcomp - | () when is_base_type env ty Predef.path_float -> floatcomp - | () when is_base_type env ty Predef.path_string -> stringcomp - | () when is_base_type env ty Predef.path_bigint -> bigintcomp - | () when is_base_type env ty Predef.path_bool -> boolcomp - | () -> objcomp + int + | () when is_base_type env ty Predef.path_float -> float + | () when is_base_type env ty Predef.path_string -> string + | () when is_base_type env ty Predef.path_bigint -> bigint + | () when is_base_type env ty Predef.path_bool -> bool + | () -> obj (* Specialize a primitive from available type information, raise Not_found if primitive is unknown *) let specialize_primitive p env ty (* ~has_constant_constructor *) = try - let table = Hashtbl.find comparisons_table p.prim_name in + let table = Hashtbl.find infix_table p.prim_name in match is_function_type env ty with - | Some (lhs, _rhs) -> specialize_comparison table env lhs - | None -> table.objcomp - with Not_found -> find_primitive p.prim_name + | Some (lhs, _rhs) -> specialize_op table env lhs + | None -> table.obj + with Not_found -> ( + try + let table = Hashtbl.find comparisons_table p.prim_name in + match is_function_type env ty with + | Some (lhs, _rhs) -> specialize_op table env lhs + | None -> table.obj + with Not_found -> find_primitive p.prim_name) (* Eta-expand a primitive *) @@ -463,7 +493,9 @@ let transl_primitive_application loc prim env ty args = | [arg1; _] when is_base_type env arg1.exp_type Predef.path_bool && Hashtbl.mem comparisons_table prim_name -> - (Hashtbl.find comparisons_table prim_name).boolcomp + (Hashtbl.find comparisons_table prim_name).bool + | [arg1; _] when Hashtbl.mem infix_table prim_name -> + specialize_op (Hashtbl.find infix_table prim_name) env arg1.exp_type | _ -> let has_constant_constructor = match args with @@ -476,7 +508,7 @@ let transl_primitive_application loc prim env ty args = in if has_constant_constructor then match Hashtbl.find_opt comparisons_table prim_name with - | Some table when table.simplify_constant_constructor -> table.intcomp + | Some table when table.simplify_constant_constructor -> table.int | Some _ | None -> specialize_primitive prim env ty (* ~has_constant_constructor*) else specialize_primitive prim env ty diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index f4334ba9bb..e6d80a2170 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3563,232 +3563,263 @@ and is_automatic_curried_application env funct = and type_application ?type_clash_context uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool = - (* funct.exp_type may be generic *) - let result_type omitted ty_fun = - List.fold_left - (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) - ty_fun omitted - in - let has_label l ty_fun = - let ls, tvar = list_labels env ty_fun in - tvar || List.mem l ls - in - let ignored = ref [] in - let has_uncurried_type t = - match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> - let arity = Ast_uncurried.type_to_arity t_arity in - Some (arity, t) - | _ -> None + let is_generic_infix path = + match Path.name path with + | "Pervasives.+" | "Pervasives.-" -> true + | _ -> false in - let force_uncurried_type funct = - match has_uncurried_type funct.exp_type with - | None -> ( - let arity = List.length sargs in - let uncurried_typ = - Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) - in - match (expand_head env funct.exp_type).desc with - | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ + match (funct.exp_desc, sargs) with + | Texp_ident (path, _, _), [(Nolabel, lhs_expr); (Nolabel, rhs_expr)] + when is_generic_infix path -> + let lhs = type_exp env lhs_expr in + let lhs_type = lhs.exp_type in + let rhs = + match (expand_head env lhs_type).desc with + | Tconstr (path, _, _) when Path.same path Predef.path_int -> + type_expect env rhs_expr Predef.type_int + | Tconstr (path, _, _) when Path.same path Predef.path_float -> + type_expect env rhs_expr Predef.type_float + | Tconstr (path, _, _) when Path.same path Predef.path_bigint -> + type_expect env rhs_expr Predef.type_bigint + | Tconstr (path, _, _) when Path.same path Predef.path_string -> + type_expect env rhs_expr Predef.type_string | _ -> - raise - (Error - ( funct.exp_loc, - env, - Apply_non_function (expand_head env funct.exp_type) ))) - | Some _ -> () - in - let extract_uncurried_type t = - match has_uncurried_type t with - | Some (arity, t1) -> - if List.length sargs > arity then - raise - (Error - ( funct.exp_loc, - env, - Uncurried_arity_mismatch (t, arity, List.length sargs) )); - (t1, arity) - | None -> (t, max_int) - in - let update_uncurried_arity ~nargs t new_t = - match has_uncurried_type t with - | Some (arity, _) -> - let newarity = arity - nargs in - let fully_applied = newarity <= 0 in - if uncurried && not fully_applied then - raise - (Error - ( funct.exp_loc, - env, - Uncurried_arity_mismatch (t, arity, List.length sargs) )); - let new_t = - if fully_applied then new_t - else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t - in - (fully_applied, new_t) - | _ -> (false, new_t) - in - let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun - (syntax_args : sargs) : targs * _ = - match syntax_args with - | [] -> - let collect_args () = - ( List.map - (function - | l, None -> (l, None) - | l, Some f -> (l, Some (f ()))) - (List.rev args), - instance env (result_type omitted ty_fun) ) - in - if List.length args < max_arity && uncurried then - match (expand_head env ty_fun).desc with - | 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 ~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 [] - | (l1, sarg1) :: sargl -> - let ty1, ty2 = - let ty_fun = expand_head env ty_fun in - let arity_ok = List.length args < max_arity in - match ty_fun.desc with - | Tvar _ -> - let t1 = newvar () and t2 = newvar () in - if ty_fun.level >= t1.level && not_identity funct.exp_desc then - Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); - (t1, t2) - | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok -> - (t1, t2) - | td -> ( - let ty_fun = - match td with - | Tarrow _ -> newty td - | _ -> ty_fun - in - let ty_res = result_type (omitted @ !ignored) ty_fun in - match ty_res.desc with - | Tarrow _ -> - if not arity_ok then + unify env lhs_type Predef.type_int; + type_expect env rhs_expr Predef.type_int + in + let result_type = lhs_type in + let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in + (targs, result_type, true) + | _ -> ( + (* funct.exp_type may be generic *) + let result_type omitted ty_fun = + List.fold_left + (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) + ty_fun omitted + in + let has_label l ty_fun = + let ls, tvar = list_labels env ty_fun in + tvar || List.mem l ls + in + let ignored = ref [] in + let has_uncurried_type t = + match (expand_head env t).desc with + | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> + let arity = Ast_uncurried.type_to_arity t_arity in + Some (arity, t) + | _ -> None + in + let force_uncurried_type funct = + match has_uncurried_type funct.exp_type with + | None -> ( + let arity = List.length sargs in + let uncurried_typ = + Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) + in + match (expand_head env funct.exp_type).desc with + | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ + | _ -> + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + | Some _ -> () + in + let extract_uncurried_type t = + match has_uncurried_type t with + | Some (arity, t1) -> + if List.length sargs > arity then + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + (t1, arity) + | None -> (t, max_int) + in + let update_uncurried_arity ~nargs t new_t = + match has_uncurried_type t with + | Some (arity, _) -> + let newarity = arity - nargs in + let fully_applied = newarity <= 0 in + if uncurried && not fully_applied then + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + let new_t = + if fully_applied then new_t + else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t + in + (fully_applied, new_t) + | _ -> (false, new_t) + in + let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun + (syntax_args : sargs) : targs * _ = + match syntax_args with + | [] -> + let collect_args () = + ( List.map + (function + | l, None -> (l, None) + | l, Some f -> (l, Some (f ()))) + (List.rev args), + instance env (result_type omitted ty_fun) ) + in + if List.length args < max_arity && uncurried then + match (expand_head env ty_fun).desc with + | 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 ~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 [] + | (l1, sarg1) :: sargl -> + let ty1, ty2 = + let ty_fun = expand_head env ty_fun in + let arity_ok = List.length args < max_arity in + match ty_fun.desc with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if ty_fun.level >= t1.level && not_identity funct.exp_desc then + Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; + unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); + (t1, t2) + | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok + -> + (t1, t2) + | td -> ( + let ty_fun = + match td with + | Tarrow _ -> newty td + | _ -> ty_fun + in + let ty_res = result_type (omitted @ !ignored) ty_fun in + match ty_res.desc with + | Tarrow _ -> + if not arity_ok then + raise + (Error + ( sarg1.pexp_loc, + env, + Apply_wrong_label (l1, funct.exp_type) )) + else if not (has_label l1 ty_fun) then + raise + (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) + else raise (Error (funct.exp_loc, env, Incoherent_label_order)) + | _ -> raise (Error - (sarg1.pexp_loc, env, Apply_wrong_label (l1, funct.exp_type))) - else if not (has_label l1 ty_fun) then - raise - (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) - else raise (Error (funct.exp_loc, env, Incoherent_label_order)) - | _ -> - raise - (Error - ( funct.exp_loc, - env, - Apply_non_function (expand_head env funct.exp_type) ))) - in - let optional = is_optional l1 in - let arg1 () = - let arg1 = type_expect env sarg1 ty1 in - if optional then unify_exp env arg1 (type_option (newvar ())); - arg1 - in - type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 - sargl - in - let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 - ~(sargs : sargs) = - match (expand_head env ty_fun, expand_head env ty_fun0) with - | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, - {desc = Tarrow (_, ty0, ty_fun0, _)} ) - when sargs <> [] && commu_repr com = Cok && List.length args < max_arity - -> - let name = label_name l and optional = is_optional l in - let sargs, omitted, arg = - match extract_label name sargs with - | None -> - if optional && (uncurried || label_assoc Nolabel sargs) then ( - ignored := (l, ty, lv) :: !ignored; + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + in + let optional = is_optional l1 in + let arg1 () = + let arg1 = type_expect env sarg1 ty1 in + if optional then unify_exp env arg1 (type_option (newvar ())); + arg1 + in + type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 + sargl + in + let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 + ~(sargs : sargs) = + match (expand_head env ty_fun, expand_head env ty_fun0) with + | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, + {desc = Tarrow (_, ty0, ty_fun0, _)} ) + when sargs <> [] && commu_repr com = Cok && List.length args < max_arity + -> + let name = label_name l and optional = is_optional l in + let sargs, omitted, arg = + match extract_label name sargs with + | None -> + if optional && (uncurried || label_assoc Nolabel sargs) then ( + ignored := (l, ty, lv) :: !ignored; + ( sargs, + omitted, + Some (fun () -> option_none (instance env ty) Location.none) )) + else (sargs, (l, ty, lv) :: omitted, None) + | Some (l', sarg0, sargs) -> + if (not optional) && is_optional l' then + Location.prerr_warning sarg0.pexp_loc + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); ( sargs, omitted, - Some (fun () -> option_none (instance env ty) Location.none) )) - else (sargs, (l, ty, lv) :: omitted, None) - | Some (l', sarg0, sargs) -> - if (not optional) && is_optional l' then - Location.prerr_warning sarg0.pexp_loc - (Warnings.Nonoptional_label (Printtyp.string_of_label l)); - ( sargs, - omitted, - Some - (if (not optional) || is_optional l' then fun () -> - type_argument - ?type_clash_context: - (type_clash_context_for_function_argument - type_clash_context sarg0) - env sarg0 ty ty0 - else fun () -> - option_some - (type_argument ?type_clash_context env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0))) ) - in - type_args ?type_clash_context 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*) - in - let () = - let ls, tvar = list_labels env funct.exp_type in - if not tvar then - let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in - if - Ext_list.same_length labels sargs - && List.for_all (fun (l, _) -> l = Nolabel) sargs - && List.exists (fun l -> l <> Nolabel) labels - then - raise - (Error - ( funct.exp_loc, - env, - Labels_omitted - (List.map Printtyp.string_of_label - (Ext_list.filter labels (fun x -> x <> Nolabel))) )) - in - match sargs with - (* Special case for ignore: avoid discarding warning *) - | [(Nolabel, sarg)] when is_ignore funct env -> - let ty_arg, ty_res = - filter_arrow env (instance env funct.exp_type) Nolabel - in - let exp = type_expect env sarg ty_arg in - (match (expand_head env exp.exp_type).desc with - | Tarrow _ -> - Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar _ -> - Delayed_checks.add_delayed_check (fun () -> - check_application_result env false exp) - | _ -> ()); - ([(Nolabel, Some exp)], ty_res, false) - | _ -> - if uncurried then force_uncurried_type funct; - let ty, max_arity = extract_uncurried_type funct.exp_type in - let targs, ret_t = - type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) - ~sargs + Some + (if (not optional) || is_optional l' then fun () -> + type_argument + ?type_clash_context: + (type_clash_context_for_function_argument + type_clash_context sarg0) + env sarg0 ty ty0 + else fun () -> + option_some + (type_argument ?type_clash_context env sarg0 + (extract_option_type env ty) + (extract_option_type env ty0))) ) + in + type_args ?type_clash_context 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*) in - let fully_applied, ret_t = - update_uncurried_arity funct.exp_type - ~nargs:(List.length !ignored + List.length sargs) - ret_t + let () = + let ls, tvar = list_labels env funct.exp_type in + if not tvar then + let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in + if + Ext_list.same_length labels sargs + && List.for_all (fun (l, _) -> l = Nolabel) sargs + && List.exists (fun l -> l <> Nolabel) labels + then + raise + (Error + ( funct.exp_loc, + env, + Labels_omitted + (List.map Printtyp.string_of_label + (Ext_list.filter labels (fun x -> x <> Nolabel))) )) in - (targs, ret_t, fully_applied) + match sargs with + (* Special case for ignore: avoid discarding warning *) + | [(Nolabel, sarg)] when is_ignore funct env -> + let ty_arg, ty_res = + filter_arrow env (instance env funct.exp_type) Nolabel + in + let exp = type_expect env sarg ty_arg in + (match (expand_head env exp.exp_type).desc with + | Tarrow _ -> + Location.prerr_warning exp.exp_loc Warnings.Partial_application + | Tvar _ -> + Delayed_checks.add_delayed_check (fun () -> + check_application_result env false exp) + | _ -> ()); + ([(Nolabel, Some exp)], ty_res, false) + | _ -> + if uncurried then force_uncurried_type funct; + let ty, max_arity = extract_uncurried_type funct.exp_type in + let targs, ret_t = + type_args ?type_clash_context max_arity [] [] ~ty_fun:ty + (instance env ty) ~sargs + in + let fully_applied, ret_t = + update_uncurried_arity funct.exp_type + ~nargs:(List.length !ignored + List.length sargs) + ret_t + in + (targs, ret_t, fully_applied)) and type_construct env loc lid sarg ty_expected attrs = let opath = diff --git a/runtime/Pervasives.res b/runtime/Pervasives.res index 8f05695ddc..8da9c474ae 100644 --- a/runtime/Pervasives.res +++ b/runtime/Pervasives.res @@ -68,8 +68,8 @@ external \"~-": int => int = "%negint" external \"~+": int => int = "%identity" external succ: int => int = "%succint" external pred: int => int = "%predint" -external \"+": (int, int) => int = "%addint" -external \"-": (int, int) => int = "%subint" +external \"+": ('a, 'a) => 'a = "%add" +external \"-": ('a, 'a) => 'a = "%sub" external \"*": (int, int) => int = "%mulint" external \"/": (int, int) => int = "%divint" external mod: (int, int) => int = "%modint" diff --git a/runtime/rescript.json b/runtime/rescript.json index abb683bc73..b39c522cb5 100644 --- a/runtime/rescript.json +++ b/runtime/rescript.json @@ -19,4 +19,4 @@ "-w -3+50", "-warn-error A" ] -} \ No newline at end of file +} diff --git a/tests/build_tests/super_errors/expected/math_operator_constant.res.expected b/tests/build_tests/super_errors/expected/math_operator_constant.res.expected index f2251eee15..741b07af7a 100644 --- a/tests/build_tests/super_errors/expected/math_operator_constant.res.expected +++ b/tests/build_tests/super_errors/expected/math_operator_constant.res.expected @@ -7,14 +7,8 @@ 3 │ let x = num + 12. 4 │ - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 12. an int by removing the dot or explicitly converting to int + This has type: float + But it's expected to have type: int You can convert float to int with Belt.Float.toInt. If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/math_operator_int.res.expected b/tests/build_tests/super_errors/expected/math_operator_int.res.expected index ebccfbecb7..e69de29bb2 100644 --- a/tests/build_tests/super_errors/expected/math_operator_int.res.expected +++ b/tests/build_tests/super_errors/expected/math_operator_int.res.expected @@ -1,20 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_int.res:3:9-11 - - 1 │ let num = 0. - 2 │ - 3 │ let x = num + 12. - 4 │ - - This has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Change the operator to +., which works on float - - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/math_operator_string.res.expected b/tests/build_tests/super_errors/expected/math_operator_string.res.expected index cb03dfac3a..e69de29bb2 100644 --- a/tests/build_tests/super_errors/expected/math_operator_string.res.expected +++ b/tests/build_tests/super_errors/expected/math_operator_string.res.expected @@ -1,16 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_string.res:1:9-15 - - 1 │ let x = "hello" + "what" - 2 │ - - This has type: string - But it's being used with the + operator, which works on: int - - Are you looking to concatenate strings? Use the operator ++, which concatenates strings. - - Possible solutions: - - Change the + operator to ++ to concatenate strings instead. - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/primitives1.res.expected b/tests/build_tests/super_errors/expected/primitives1.res.expected index b1a303eccb..cc2946f160 100644 --- a/tests/build_tests/super_errors/expected/primitives1.res.expected +++ b/tests/build_tests/super_errors/expected/primitives1.res.expected @@ -1,19 +1,13 @@ We've found a bug for you! - /.../fixtures/primitives1.res:2:1-2 + /.../fixtures/primitives1.res:2:6 1 │ /* got float, wanted int */ - 2 │ 2. + 2 + 2 │ 2. + 2 3 │ - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 2. an int by removing the dot or explicitly converting to int + This has type: int + But it's expected to have type: float - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file + You can convert int to float with Belt.Int.toFloat. + If this is a literal, try a number with a trailing dot (e.g. 20.). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/type1.res.expected b/tests/build_tests/super_errors/expected/type1.res.expected index 036daa2550..6bc3692c57 100644 --- a/tests/build_tests/super_errors/expected/type1.res.expected +++ b/tests/build_tests/super_errors/expected/type1.res.expected @@ -1,18 +1,12 @@ We've found a bug for you! - /.../fixtures/type1.res:1:9-10 + /.../fixtures/type1.res:1:14 - 1 │ let x = 2. + 2 + 1 │ let x = 2. + 2 2 │ - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 2. an int by removing the dot or explicitly converting to int + This has type: int + But it's expected to have type: float - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file + You can convert int to float with Belt.Int.toFloat. + If this is a literal, try a number with a trailing dot (e.g. 20.). \ No newline at end of file diff --git a/tests/tests/src/generic_infix_test.js b/tests/tests/src/generic_infix_test.js new file mode 100644 index 0000000000..bffccc60d4 --- /dev/null +++ b/tests/tests/src/generic_infix_test.js @@ -0,0 +1,37 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE +'use strict'; + + +let float = 1 + 2; + +let string = "12"; + +let bigint = 1n + 2n; + +function addint(a, b) { + return a + b | 0; +} + +function addfloat(a, b) { + return a + b; +} + +function addbigint(a, b) { + return a + b; +} + +function addstring(a, b) { + return a + b; +} + +let int = 3; + +exports.int = int; +exports.float = float; +exports.string = string; +exports.bigint = bigint; +exports.addint = addint; +exports.addfloat = addfloat; +exports.addbigint = addbigint; +exports.addstring = addstring; +/* No side effect */ diff --git a/tests/tests/src/generic_infix_test.res b/tests/tests/src/generic_infix_test.res new file mode 100644 index 0000000000..fccf697ab7 --- /dev/null +++ b/tests/tests/src/generic_infix_test.res @@ -0,0 +1,9 @@ +let int = 1 + 2 +let float = 1. + 2. +let string = "1" + "2" +let bigint = 1n + 2n + +let addint = (a, b) => a + b +let addfloat = (a: float, b) => a + b +let addbigint = (a: bigint, b) => a + b +let addstring = (a: string, b) => a + b From 0005e2f39679637fbcb80e6a5db13185bf2154e0 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sat, 12 Oct 2024 04:17:03 +0900 Subject: [PATCH 02/16] try less diff --- compiler/ml/typecore.ml | 458 ++++++++++++++++++++-------------------- 1 file changed, 230 insertions(+), 228 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index e6d80a2170..0bd5869600 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2458,7 +2458,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp in let type_clash_context = type_clash_context_from_function sexp sfunct in let args, ty_res, fully_applied = - type_application ?type_clash_context uncurried env funct sargs + match specialized_infix_type_application env funct sargs with + | Some application -> application + | None -> type_application ?type_clash_context uncurried env funct sargs in end_def (); unify_var env (newvar ()) funct.exp_type; @@ -3561,8 +3563,8 @@ and is_automatic_curried_application env funct = | Tarrow _ -> true | _ -> false -and type_application ?type_clash_context uncurried env funct (sargs : sargs) : - targs * Types.type_expr * bool = +and specialized_infix_type_application env funct (sargs : sargs) : + (targs * Types.type_expr * bool) option = let is_generic_infix path = match Path.name path with | "Pervasives.+" | "Pervasives.-" -> true @@ -3589,237 +3591,237 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : in let result_type = lhs_type in let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in - (targs, result_type, true) - | _ -> ( - (* funct.exp_type may be generic *) - let result_type omitted ty_fun = - List.fold_left - (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) - ty_fun omitted - in - let has_label l ty_fun = - let ls, tvar = list_labels env ty_fun in - tvar || List.mem l ls - in - let ignored = ref [] in - let has_uncurried_type t = - match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> - let arity = Ast_uncurried.type_to_arity t_arity in - Some (arity, t) - | _ -> None - in - let force_uncurried_type funct = - match has_uncurried_type funct.exp_type with - | None -> ( - let arity = List.length sargs in - let uncurried_typ = - Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) - in - match (expand_head env funct.exp_type).desc with - | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ - | _ -> - raise - (Error - ( funct.exp_loc, - env, - Apply_non_function (expand_head env funct.exp_type) ))) - | Some _ -> () - in - let extract_uncurried_type t = - match has_uncurried_type t with - | Some (arity, t1) -> - if List.length sargs > arity then - raise - (Error - ( funct.exp_loc, - env, - Uncurried_arity_mismatch (t, arity, List.length sargs) )); - (t1, arity) - | None -> (t, max_int) - in - let update_uncurried_arity ~nargs t new_t = - match has_uncurried_type t with - | Some (arity, _) -> - let newarity = arity - nargs in - let fully_applied = newarity <= 0 in - if uncurried && not fully_applied then - raise - (Error - ( funct.exp_loc, - env, - Uncurried_arity_mismatch (t, arity, List.length sargs) )); - let new_t = - if fully_applied then new_t - else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t - in - (fully_applied, new_t) - | _ -> (false, new_t) - in - let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun - (syntax_args : sargs) : targs * _ = - match syntax_args with - | [] -> - let collect_args () = - ( List.map - (function - | l, None -> (l, None) - | l, Some f -> (l, Some (f ()))) - (List.rev args), - instance env (result_type omitted ty_fun) ) - in - if List.length args < max_arity && uncurried then - match (expand_head env ty_fun).desc with - | 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 ~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 [] - | (l1, sarg1) :: sargl -> - let ty1, ty2 = - let ty_fun = expand_head env ty_fun in - let arity_ok = List.length args < max_arity in - match ty_fun.desc with - | Tvar _ -> - let t1 = newvar () and t2 = newvar () in - if ty_fun.level >= t1.level && not_identity funct.exp_desc then - Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); - (t1, t2) - | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok - -> - (t1, t2) - | td -> ( - let ty_fun = - match td with - | Tarrow _ -> newty td - | _ -> ty_fun - in - let ty_res = result_type (omitted @ !ignored) ty_fun in - match ty_res.desc with - | Tarrow _ -> - if not arity_ok then - raise - (Error - ( sarg1.pexp_loc, - env, - Apply_wrong_label (l1, funct.exp_type) )) - else if not (has_label l1 ty_fun) then - raise - (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) - else raise (Error (funct.exp_loc, env, Incoherent_label_order)) - | _ -> + Some (targs, result_type, true) + | _ -> None + +and type_application ?type_clash_context uncurried env funct (sargs : sargs) : + targs * Types.type_expr * bool = + (* funct.exp_type may be generic *) + let result_type omitted ty_fun = + List.fold_left + (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) + ty_fun omitted + in + let has_label l ty_fun = + let ls, tvar = list_labels env ty_fun in + tvar || List.mem l ls + in + let ignored = ref [] in + let has_uncurried_type t = + match (expand_head env t).desc with + | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> + let arity = Ast_uncurried.type_to_arity t_arity in + Some (arity, t) + | _ -> None + in + let force_uncurried_type funct = + match has_uncurried_type funct.exp_type with + | None -> ( + let arity = List.length sargs in + let uncurried_typ = + Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) + in + match (expand_head env funct.exp_type).desc with + | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ + | _ -> + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + | Some _ -> () + in + let extract_uncurried_type t = + match has_uncurried_type t with + | Some (arity, t1) -> + if List.length sargs > arity then + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + (t1, arity) + | None -> (t, max_int) + in + let update_uncurried_arity ~nargs t new_t = + match has_uncurried_type t with + | Some (arity, _) -> + let newarity = arity - nargs in + let fully_applied = newarity <= 0 in + if uncurried && not fully_applied then + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + let new_t = + if fully_applied then new_t + else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t + in + (fully_applied, new_t) + | _ -> (false, new_t) + in + let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun + (syntax_args : sargs) : targs * _ = + match syntax_args with + | [] -> + let collect_args () = + ( List.map + (function + | l, None -> (l, None) + | l, Some f -> (l, Some (f ()))) + (List.rev args), + instance env (result_type omitted ty_fun) ) + in + if List.length args < max_arity && uncurried then + match (expand_head env ty_fun).desc with + | 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 ~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 [] + | (l1, sarg1) :: sargl -> + let ty1, ty2 = + let ty_fun = expand_head env ty_fun in + let arity_ok = List.length args < max_arity in + match ty_fun.desc with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if ty_fun.level >= t1.level && not_identity funct.exp_desc then + Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; + unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); + (t1, t2) + | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok -> + (t1, t2) + | td -> ( + let ty_fun = + match td with + | Tarrow _ -> newty td + | _ -> ty_fun + in + let ty_res = result_type (omitted @ !ignored) ty_fun in + match ty_res.desc with + | Tarrow _ -> + if not arity_ok then raise (Error - ( funct.exp_loc, - env, - Apply_non_function (expand_head env funct.exp_type) ))) - in - let optional = is_optional l1 in - let arg1 () = - let arg1 = type_expect env sarg1 ty1 in - if optional then unify_exp env arg1 (type_option (newvar ())); - arg1 - in - type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 - sargl - in - let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 - ~(sargs : sargs) = - match (expand_head env ty_fun, expand_head env ty_fun0) with - | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, - {desc = Tarrow (_, ty0, ty_fun0, _)} ) - when sargs <> [] && commu_repr com = Cok && List.length args < max_arity - -> - let name = label_name l and optional = is_optional l in - let sargs, omitted, arg = - match extract_label name sargs with - | None -> - if optional && (uncurried || label_assoc Nolabel sargs) then ( - ignored := (l, ty, lv) :: !ignored; - ( sargs, - omitted, - Some (fun () -> option_none (instance env ty) Location.none) )) - else (sargs, (l, ty, lv) :: omitted, None) - | Some (l', sarg0, sargs) -> - if (not optional) && is_optional l' then - Location.prerr_warning sarg0.pexp_loc - (Warnings.Nonoptional_label (Printtyp.string_of_label l)); + (sarg1.pexp_loc, env, Apply_wrong_label (l1, funct.exp_type))) + else if not (has_label l1 ty_fun) then + raise + (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) + else raise (Error (funct.exp_loc, env, Incoherent_label_order)) + | _ -> + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + in + let optional = is_optional l1 in + let arg1 () = + let arg1 = type_expect env sarg1 ty1 in + if optional then unify_exp env arg1 (type_option (newvar ())); + arg1 + in + type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 + sargl + in + let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 + ~(sargs : sargs) = + match (expand_head env ty_fun, expand_head env ty_fun0) with + | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, + {desc = Tarrow (_, ty0, ty_fun0, _)} ) + when sargs <> [] && commu_repr com = Cok && List.length args < max_arity + -> + let name = label_name l and optional = is_optional l in + let sargs, omitted, arg = + match extract_label name sargs with + | None -> + if optional && (uncurried || label_assoc Nolabel sargs) then ( + ignored := (l, ty, lv) :: !ignored; ( sargs, omitted, - Some - (if (not optional) || is_optional l' then fun () -> - type_argument - ?type_clash_context: - (type_clash_context_for_function_argument - type_clash_context sarg0) - env sarg0 ty ty0 - else fun () -> - option_some - (type_argument ?type_clash_context env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0))) ) - in - type_args ?type_clash_context 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*) - in - let () = - let ls, tvar = list_labels env funct.exp_type in - if not tvar then - let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in - if - Ext_list.same_length labels sargs - && List.for_all (fun (l, _) -> l = Nolabel) sargs - && List.exists (fun l -> l <> Nolabel) labels - then - raise - (Error - ( funct.exp_loc, - env, - Labels_omitted - (List.map Printtyp.string_of_label - (Ext_list.filter labels (fun x -> x <> Nolabel))) )) - in - match sargs with - (* Special case for ignore: avoid discarding warning *) - | [(Nolabel, sarg)] when is_ignore funct env -> - let ty_arg, ty_res = - filter_arrow env (instance env funct.exp_type) Nolabel + Some (fun () -> option_none (instance env ty) Location.none) )) + else (sargs, (l, ty, lv) :: omitted, None) + | Some (l', sarg0, sargs) -> + if (not optional) && is_optional l' then + Location.prerr_warning sarg0.pexp_loc + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); + ( sargs, + omitted, + Some + (if (not optional) || is_optional l' then fun () -> + type_argument + ?type_clash_context: + (type_clash_context_for_function_argument + type_clash_context sarg0) + env sarg0 ty ty0 + else fun () -> + option_some + (type_argument ?type_clash_context env sarg0 + (extract_option_type env ty) + (extract_option_type env ty0))) ) in - let exp = type_expect env sarg ty_arg in - (match (expand_head env exp.exp_type).desc with - | Tarrow _ -> - Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar _ -> - Delayed_checks.add_delayed_check (fun () -> - check_application_result env false exp) - | _ -> ()); - ([(Nolabel, Some exp)], ty_res, false) + type_args ?type_clash_context max_arity ((l, arg) :: args) omitted ~ty_fun + ty_fun0 ~sargs | _ -> - if uncurried then force_uncurried_type funct; - let ty, max_arity = extract_uncurried_type funct.exp_type in - let targs, ret_t = - type_args ?type_clash_context max_arity [] [] ~ty_fun:ty - (instance env ty) ~sargs - in - let fully_applied, ret_t = - update_uncurried_arity funct.exp_type - ~nargs:(List.length !ignored + List.length sargs) - ret_t - in - (targs, ret_t, fully_applied)) + 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 + if not tvar then + let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in + if + Ext_list.same_length labels sargs + && List.for_all (fun (l, _) -> l = Nolabel) sargs + && List.exists (fun l -> l <> Nolabel) labels + then + raise + (Error + ( funct.exp_loc, + env, + Labels_omitted + (List.map Printtyp.string_of_label + (Ext_list.filter labels (fun x -> x <> Nolabel))) )) + in + match sargs with + (* Special case for ignore: avoid discarding warning *) + | [(Nolabel, sarg)] when is_ignore funct env -> + let ty_arg, ty_res = + filter_arrow env (instance env funct.exp_type) Nolabel + in + let exp = type_expect env sarg ty_arg in + (match (expand_head env exp.exp_type).desc with + | Tarrow _ -> + Location.prerr_warning exp.exp_loc Warnings.Partial_application + | Tvar _ -> + Delayed_checks.add_delayed_check (fun () -> + check_application_result env false exp) + | _ -> ()); + ([(Nolabel, Some exp)], ty_res, false) + | _ -> + if uncurried then force_uncurried_type funct; + let ty, max_arity = extract_uncurried_type funct.exp_type in + let targs, ret_t = + type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) + ~sargs + in + let fully_applied, ret_t = + update_uncurried_arity funct.exp_type + ~nargs:(List.length !ignored + List.length sargs) + ret_t + in + (targs, ret_t, fully_applied) and type_construct env loc lid sarg ty_expected attrs = let opath = From 4bc812d95664aad66c3a4f7342aee2e282e5d2c1 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Thu, 24 Oct 2024 22:16:30 +0900 Subject: [PATCH 03/16] wip: unified ops --- compiler/ml/unified_ops.ml | 47 ++++++++++++++++++++++++++++++++++++++ runtime/Pervasives.res | 8 +++++-- 2 files changed, 53 insertions(+), 2 deletions(-) create mode 100644 compiler/ml/unified_ops.ml diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml new file mode 100644 index 0000000000..5f09ce28e6 --- /dev/null +++ b/compiler/ml/unified_ops.ml @@ -0,0 +1,47 @@ +open Btype +open Types +open Misc + +(* + Unified_ops is for specialization of some primitive operators. + + For example adding two values. We have `+` for ints, `+.` for floats, and `++` for strings. + That because we don't use implicit type conversion or overloading. + + It is a fundamental property of the ReScript language, but at the same time it is far from the best DX we can think of, and it became a problem when introducing new primitives like bigint. + + See discussion: https://github.com/rescript-lang/rescript-compiler/issues/6525 + + 1. Type level translation + + 2. IR level translation +*) + +type args = (Asttypes.arg_label * Parsetree.expression) list +type targs = (Asttypes.arg_label * Typedtree.expression option) list + +type specialized_type = { + int: Path.t; + bool: Path.t option; + float: Path.t option; + bigint: Path.t option; + string: Path.t option; +} + +let specialized_types = create_hashtable [||] + +type specialized_primitive = { + int: Lambda.primitive; + bool: Lambda.primitive option; + float: Lambda.primitive option; + bigint: Lambda.primitive option; + string: Lambda.primitive option; +} + +let translate_type_application (env : Env.t) (funct : Parsetree.expression) + (args : args) : (targs * type_expr) option = + None + +let translate_primitive_application (env : Env.t) (prim : Primitive.description) + (args : args) : Lambda.primitive option = + None diff --git a/runtime/Pervasives.res b/runtime/Pervasives.res index 8da9c474ae..857a2cea38 100644 --- a/runtime/Pervasives.res +++ b/runtime/Pervasives.res @@ -40,7 +40,13 @@ external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC" external __LINE_OF__: 'a => (int, 'a) = "%loc_LINE" external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" +/* Unified operations */ + +external \"+": ('a, 'a) => 'a = "%add" +external \"-": ('a, 'a) => 'a = "%sub" + /* Comparisons */ +/* Note: Later comparisons will be converted to unified operations too */ external \"=": ('a, 'a) => bool = "%equal" external \"<>": ('a, 'a) => bool = "%notequal" @@ -68,8 +74,6 @@ external \"~-": int => int = "%negint" external \"~+": int => int = "%identity" external succ: int => int = "%succint" external pred: int => int = "%predint" -external \"+": ('a, 'a) => 'a = "%add" -external \"-": ('a, 'a) => 'a = "%sub" external \"*": (int, int) => int = "%mulint" external \"/": (int, int) => int = "%divint" external mod: (int, int) => int = "%modint" From 755104558bb76f508defb12509328891cf52408c Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Tue, 5 Nov 2024 00:11:18 +0900 Subject: [PATCH 04/16] rewrite type translation --- compiler/ml/translcore.ml | 9 ++ compiler/ml/typecore.ml | 123 +++++++++++++----- compiler/ml/unified_ops.ml | 94 +++++++++---- compiler/ml/unified_ops.mli | 20 +++ ...c_infix_test.js => generic_infix_test.mjs} | 19 +-- 5 files changed, 201 insertions(+), 64 deletions(-) create mode 100644 compiler/ml/unified_ops.mli rename tests/tests/src/{generic_infix_test.js => generic_infix_test.mjs} (59%) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index b741f5deb7..59c01cfb16 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -49,6 +49,15 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) +(* +type sargs = (Asttypes.arg_label * Parsetree.expression) list + +let translate_unified_application (env : Env.t) (prim : Primitive.description) + (sargs : sargs) : Lambda.primitive option = + (* TODO *) + None +*) + type specialized = { obj: Lambda.primitive; int: Lambda.primitive; diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 0bd5869600..444f5dadd9 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2458,8 +2458,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp in let type_clash_context = type_clash_context_from_function sexp sfunct in let args, ty_res, fully_applied = - match specialized_infix_type_application env funct sargs with - | Some application -> application + match translate_unified_application env funct sargs with + | Some (targs, result_type) -> (targs, result_type, true) | None -> type_application ?type_clash_context uncurried env funct sargs in end_def (); @@ -3563,35 +3563,96 @@ and is_automatic_curried_application env funct = | Tarrow _ -> true | _ -> false -and specialized_infix_type_application env funct (sargs : sargs) : - (targs * Types.type_expr * bool) option = - let is_generic_infix path = - match Path.name path with - | "Pervasives.+" | "Pervasives.-" -> true - | _ -> false - in - match (funct.exp_desc, sargs) with - | Texp_ident (path, _, _), [(Nolabel, lhs_expr); (Nolabel, rhs_expr)] - when is_generic_infix path -> - let lhs = type_exp env lhs_expr in - let lhs_type = lhs.exp_type in - let rhs = - match (expand_head env lhs_type).desc with - | Tconstr (path, _, _) when Path.same path Predef.path_int -> - type_expect env rhs_expr Predef.type_int - | Tconstr (path, _, _) when Path.same path Predef.path_float -> - type_expect env rhs_expr Predef.type_float - | Tconstr (path, _, _) when Path.same path Predef.path_bigint -> - type_expect env rhs_expr Predef.type_bigint - | Tconstr (path, _, _) when Path.same path Predef.path_string -> - type_expect env rhs_expr Predef.type_string - | _ -> - unify env lhs_type Predef.type_int; - type_expect env rhs_expr Predef.type_int - in - let result_type = lhs_type in - let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in - Some (targs, result_type, true) +and translate_unified_application (env : Env.t) (funct : Typedtree.expression) + (sargs : sargs) : (targs * Types.type_expr) option = + match funct.exp_desc with + | Texp_ident (path, _, _) -> ( + let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in + match (entry, sargs) with + | Some {form = Unary; specialization; _}, [(Nolabel, lhs_expr)] -> + let lhs = type_exp env lhs_expr in + let lhs_type = expand_head env lhs.exp_type in + let result_type = + match (lhs_type.desc, specialization) with + | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> + Predef.type_int + | Tconstr (path, _, _), {bool = Some _} + when Path.same path Predef.path_bool -> + Predef.type_bool + | Tconstr (path, _, _), {float = Some _} + when Path.same path Predef.path_float -> + Predef.type_float + | Tconstr (path, _, _), {bigint = Some _} + when Path.same path Predef.path_bigint -> + Predef.type_bigint + | Tconstr (path, _, _), {string = Some _} + when Path.same path Predef.path_string -> + Predef.type_string + | _ -> + unify env lhs_type Predef.type_int; + Predef.type_int + in + let targs = [(Nolabel, Some lhs)] in + Some (targs, result_type) + | ( Some {form = Binary; specialization; _}, + [(Nolabel, lhs_expr); (Nolabel, rhs_expr)] ) -> + let lhs = type_exp env lhs_expr in + let lhs_type = expand_head env lhs.exp_type in + let rhs = type_exp env rhs_expr in + let rhs_type = expand_head env rhs.exp_type in + let lhs, rhs, result_type = + (* rule 1. *) + match (lhs_type.desc, specialization) with + | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> + let rhs = type_expect env rhs_expr Predef.type_int in + (lhs, rhs, Predef.type_int) + | Tconstr (path, _, _), {bool = Some _} + when Path.same path Predef.path_bool -> + let rhs = type_expect env rhs_expr Predef.type_bool in + (lhs, rhs, Predef.type_bool) + | Tconstr (path, _, _), {float = Some _} + when Path.same path Predef.path_float -> + let rhs = type_expect env rhs_expr Predef.type_float in + (lhs, rhs, Predef.type_float) + | Tconstr (path, _, _), {bigint = Some _} + when Path.same path Predef.path_bigint -> + let rhs = type_expect env rhs_expr Predef.type_bigint in + (lhs, rhs, Predef.type_bigint) + | Tconstr (path, _, _), {string = Some _} + when Path.same path Predef.path_string -> + let rhs = type_expect env rhs_expr Predef.type_string in + (lhs, rhs, Predef.type_string) + | _ -> ( + (* rule 2. *) + match (rhs_type.desc, specialization) with + | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> + let lhs = type_expect env lhs_expr Predef.type_int in + (lhs, rhs, Predef.type_int) + | Tconstr (path, _, _), {bool = Some _} + when Path.same path Predef.path_bool -> + let lhs = type_expect env lhs_expr Predef.type_bool in + (lhs, rhs, Predef.type_bool) + | Tconstr (path, _, _), {float = Some _} + when Path.same path Predef.path_float -> + let lhs = type_expect env lhs_expr Predef.type_float in + (lhs, rhs, Predef.type_float) + | Tconstr (path, _, _), {bigint = Some _} + when Path.same path Predef.path_bigint -> + let lhs = type_expect env lhs_expr Predef.type_bigint in + (lhs, rhs, Predef.type_bigint) + | Tconstr (path, _, _), {string = Some _} + when Path.same path Predef.path_string -> + let lhs = type_expect env lhs_expr Predef.type_string in + (lhs, rhs, Predef.type_string) + | _ -> + (* rule 3. *) + let lhs = type_expect env lhs_expr Predef.type_int in + let rhs = type_expect env rhs_expr Predef.type_int in + (lhs, rhs, Predef.type_int)) + in + let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in + Some (targs, result_type) + | _ -> None) | _ -> None and type_application ?type_clash_context uncurried env funct (sargs : sargs) : diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml index 5f09ce28e6..b276d5831a 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -1,36 +1,34 @@ -open Btype -open Types open Misc (* Unified_ops is for specialization of some primitive operators. For example adding two values. We have `+` for ints, `+.` for floats, and `++` for strings. - That because we don't use implicit type conversion or overloading. + That because we don't allow implicit conversion or overloading for operations. - It is a fundamental property of the ReScript language, but at the same time it is far from the best DX we can think of, and it became a problem when introducing new primitives like bigint. + It is a fundamental property of the ReScript language, but it is far from the best DX we can think of, + and it became a problem when new primitives like bigint were introduced. See discussion: https://github.com/rescript-lang/rescript-compiler/issues/6525 - 1. Type level translation + Unified ops mitigate the problem by adding ad-hoc translation rules on applications of the core built-in operators + which have form of binary infix ('a -> 'a -> 'a) or unary ('a -> 'a) - 2. IR level translation -*) + Translation rules should be applied in its application, in both type-level and IR(lambda)-level. -type args = (Asttypes.arg_label * Parsetree.expression) list -type targs = (Asttypes.arg_label * Typedtree.expression option) list + The rules: -type specialized_type = { - int: Path.t; - bool: Path.t option; - float: Path.t option; - bigint: Path.t option; - string: Path.t option; -} + 1. If the lhs type is a primitive type, unify the rhs and the result type to the lhs type. + 2. If the lhs type is not a primitive type but the rhs type is, unify lhs and the result type to the rhs type. + 3. If both lhs type and rhs type is not a primitive type, unify the whole types to the int. + + Since these are simple ad-hoc translations for primitive applications, we cannot use the result type defined in other contexts. + So falling back to int type is the simplest behavior that ensures backwards compatibility. +*) -let specialized_types = create_hashtable [||] +type form = Unary | Binary -type specialized_primitive = { +type specialization = { int: Lambda.primitive; bool: Lambda.primitive option; float: Lambda.primitive option; @@ -38,10 +36,58 @@ type specialized_primitive = { string: Lambda.primitive option; } -let translate_type_application (env : Env.t) (funct : Parsetree.expression) - (args : args) : (targs * type_expr) option = - None +type entry = { + path: string; + (** TODO: Maybe it can be a Path.t in Predef instead of string *) + name: string; + form: form; + specialization: specialization; +} + +let builtin x = Primitive_modules.pervasives ^ "." ^ x + +let entries = + [| + { + path = builtin "+"; + name = "%add"; + form = Binary; + specialization = + { + int = Paddint; + bool = None; + float = Some Paddfloat; + bigint = Some Paddbigint; + string = Some Pstringadd; + }; + }; + { + path = builtin "-"; + name = "%sub"; + form = Binary; + specialization = + { + int = Psubint; + bool = None; + float = Some Psubfloat; + bigint = Some Psubbigint; + string = None; + }; + }; + |] -let translate_primitive_application (env : Env.t) (prim : Primitive.description) - (args : args) : Lambda.primitive option = - None +let index_by_path = + entries |> Array.map (fun entry -> (entry.path, entry)) |> create_hashtable + +let index_by_name = + entries |> Array.map (fun entry -> (entry.name, entry)) |> create_hashtable + +(* + Actual implementations of translation are colocated into core modules + + You can find it in: + - Type-level : ml/typecore.ml + - IR-level : ml/translcore.ml + + With function name "translate_unified_application" +*) diff --git a/compiler/ml/unified_ops.mli b/compiler/ml/unified_ops.mli new file mode 100644 index 0000000000..b52e052a55 --- /dev/null +++ b/compiler/ml/unified_ops.mli @@ -0,0 +1,20 @@ +type form = Unary | Binary + +type specialization = { + int: Lambda.primitive; + bool: Lambda.primitive option; + float: Lambda.primitive option; + bigint: Lambda.primitive option; + string: Lambda.primitive option; +} + +type entry = { + path: string; + name: string; + form: form; + specialization: specialization; +} + +val index_by_path : (string, entry) Hashtbl.t + +val index_by_name : (string, entry) Hashtbl.t diff --git a/tests/tests/src/generic_infix_test.js b/tests/tests/src/generic_infix_test.mjs similarity index 59% rename from tests/tests/src/generic_infix_test.js rename to tests/tests/src/generic_infix_test.mjs index bffccc60d4..19fde3ce35 100644 --- a/tests/tests/src/generic_infix_test.js +++ b/tests/tests/src/generic_infix_test.mjs @@ -1,5 +1,4 @@ // Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; let float = 1 + 2; @@ -26,12 +25,14 @@ function addstring(a, b) { let int = 3; -exports.int = int; -exports.float = float; -exports.string = string; -exports.bigint = bigint; -exports.addint = addint; -exports.addfloat = addfloat; -exports.addbigint = addbigint; -exports.addstring = addstring; +export { + int, + float, + string, + bigint, + addint, + addfloat, + addbigint, + addstring, +} /* No side effect */ From 64d4e155702ac828889ce0657a0c410c7e87f1f3 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Tue, 5 Nov 2024 00:19:53 +0900 Subject: [PATCH 05/16] revert changes on comparison --- compiler/ml/translcore.ml | 242 +++++++++++++++++--------------------- 1 file changed, 105 insertions(+), 137 deletions(-) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 59c01cfb16..f4009c3d6d 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -59,182 +59,157 @@ let translate_unified_application (env : Env.t) (prim : Primitive.description) *) type specialized = { - obj: Lambda.primitive; - int: Lambda.primitive; - bool: Lambda.primitive; - float: Lambda.primitive; - string: Lambda.primitive; - bigint: Lambda.primitive; + objcomp: Lambda.primitive; + intcomp: Lambda.primitive; + boolcomp: Lambda.primitive; + floatcomp: Lambda.primitive; + stringcomp: Lambda.primitive; + bigintcomp: Lambda.primitive; simplify_constant_constructor: bool; } -let infix_table = - create_hashtable - [| - ( "%add", - { - obj = Paddint; - int = Paddint; - bool = Pinfix Inf_invariant; - float = Paddfloat; - string = Pstringadd; - bigint = Paddbigint; - simplify_constant_constructor = false; - } ); - ( "%sub", - { - obj = Paddint; - int = Psubint; - bool = Pinfix Inf_invariant; - float = Psubfloat; - string = Pinfix Inf_invariant; - bigint = Psubbigint; - simplify_constant_constructor = false; - } ); - |] - let comparisons_table = create_hashtable [| ( "%equal", { - obj = Pobjcomp Ceq; - int = Pintcomp Ceq; - bool = Pboolcomp Ceq; - float = Pfloatcomp Ceq; - string = Pstringcomp Ceq; - bigint = Pbigintcomp Ceq; + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; simplify_constant_constructor = true; } ); ( "%notequal", { - obj = Pobjcomp Cneq; - int = Pintcomp Cneq; - bool = Pboolcomp Cneq; - float = Pfloatcomp Cneq; - string = Pstringcomp Cneq; - bigint = Pbigintcomp Cneq; + objcomp = Pobjcomp Cneq; + intcomp = Pintcomp Cneq; + boolcomp = Pboolcomp Cneq; + floatcomp = Pfloatcomp Cneq; + stringcomp = Pstringcomp Cneq; + bigintcomp = Pbigintcomp Cneq; simplify_constant_constructor = true; } ); ( "%lessthan", { - obj = Pobjcomp Clt; - int = Pintcomp Clt; - bool = Pboolcomp Clt; - float = Pfloatcomp Clt; - string = Pstringcomp Clt; - bigint = Pbigintcomp Clt; + objcomp = Pobjcomp Clt; + intcomp = Pintcomp Clt; + boolcomp = Pboolcomp Clt; + floatcomp = Pfloatcomp Clt; + stringcomp = Pstringcomp Clt; + bigintcomp = Pbigintcomp Clt; simplify_constant_constructor = false; } ); ( "%greaterthan", { - obj = Pobjcomp Cgt; - int = Pintcomp Cgt; - bool = Pboolcomp Cgt; - float = Pfloatcomp Cgt; - string = Pstringcomp Cgt; - bigint = Pbigintcomp Cgt; + objcomp = Pobjcomp Cgt; + intcomp = Pintcomp Cgt; + boolcomp = Pboolcomp Cgt; + floatcomp = Pfloatcomp Cgt; + stringcomp = Pstringcomp Cgt; + bigintcomp = Pbigintcomp Cgt; simplify_constant_constructor = false; } ); ( "%lessequal", { - obj = Pobjcomp Cle; - int = Pintcomp Cle; - bool = Pboolcomp Cle; - float = Pfloatcomp Cle; - string = Pstringcomp Cle; - bigint = Pbigintcomp Cle; + objcomp = Pobjcomp Cle; + intcomp = Pintcomp Cle; + boolcomp = Pboolcomp Cle; + floatcomp = Pfloatcomp Cle; + stringcomp = Pstringcomp Cle; + bigintcomp = Pbigintcomp Cle; simplify_constant_constructor = false; } ); ( "%greaterequal", { - obj = Pobjcomp Cge; - int = Pintcomp Cge; - bool = Pboolcomp Cge; - float = Pfloatcomp Cge; - string = Pstringcomp Cge; - bigint = Pbigintcomp Cge; + objcomp = Pobjcomp Cge; + intcomp = Pintcomp Cge; + boolcomp = Pboolcomp Cge; + floatcomp = Pfloatcomp Cge; + stringcomp = Pstringcomp Cge; + bigintcomp = Pbigintcomp Cge; simplify_constant_constructor = false; } ); ( "%compare", { - obj = Pobjorder; - int = Pintorder; - bool = Pboolorder; - float = Pfloatorder; - string = Pstringorder; - bigint = Pbigintorder; + objcomp = Pobjorder; + intcomp = Pintorder; + boolcomp = Pboolorder; + floatcomp = Pfloatorder; + stringcomp = Pstringorder; + bigintcomp = Pbigintorder; simplify_constant_constructor = false; } ); ( "%max", { - obj = Pobjmax; - int = Pintmax; - bool = Pboolmax; - float = Pboolmax; - string = Pstringmax; - bigint = Pbigintmax; + objcomp = Pobjmax; + intcomp = Pintmax; + boolcomp = Pboolmax; + floatcomp = Pboolmax; + stringcomp = Pstringmax; + bigintcomp = Pbigintmax; simplify_constant_constructor = false; } ); ( "%min", { - obj = Pobjmin; - int = Pintmin; - bool = Pboolmin; - float = Pfloatmin; - string = Pstringmin; - bigint = Pbigintmin; + objcomp = Pobjmin; + intcomp = Pintmin; + boolcomp = Pboolmin; + floatcomp = Pfloatmin; + stringcomp = Pstringmin; + bigintcomp = Pbigintmin; simplify_constant_constructor = false; } ); ( "%equal_null", { - obj = Pobjcomp Ceq; - int = Pintcomp Ceq; - bool = Pboolcomp Ceq; - float = Pfloatcomp Ceq; - string = Pstringcomp Ceq; - bigint = Pbigintcomp Ceq; + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); ( "%equal_undefined", { - obj = Pobjcomp Ceq; - int = Pintcomp Ceq; - bool = Pboolcomp Ceq; - float = Pfloatcomp Ceq; - string = Pstringcomp Ceq; - bigint = Pbigintcomp Ceq; + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); ( "%equal_nullable", { - obj = Pobjcomp Ceq; - int = Pintcomp Ceq; - bool = Pboolcomp Ceq; - float = Pfloatcomp Ceq; - string = Pstringcomp Ceq; - bigint = Pbigintcomp Ceq; + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); (* FIXME: Core compatibility *) ( "%bs_min", { - obj = Pobjmax; - int = Pintmax; - bool = Pboolmax; - float = Pboolmax; - string = Pstringmax; - bigint = Pbigintmax; + objcomp = Pobjmax; + intcomp = Pintmax; + boolcomp = Pboolmax; + floatcomp = Pboolmax; + stringcomp = Pstringmax; + bigintcomp = Pbigintmax; simplify_constant_constructor = false; } ); ( "%bs_max", { - obj = Pobjmin; - int = Pintmin; - bool = Pboolmin; - float = Pfloatmin; - string = Pstringmin; - bigint = Pbigintmin; + objcomp = Pobjmin; + intcomp = Pintmin; + boolcomp = Pboolmin; + floatcomp = Pfloatmin; + stringcomp = Pstringmin; + bigintcomp = Pbigintmin; simplify_constant_constructor = false; } ); |] @@ -409,36 +384,31 @@ let primitives_table = let find_primitive prim_name = Hashtbl.find primitives_table prim_name -let specialize_op ({obj; int; float; string; bigint; bool} : specialized) env ty - = +let specialize_comparison + ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} : + specialized) env ty = match () with | () when is_base_type env ty Predef.path_int || is_base_type env ty Predef.path_char || maybe_pointer_type env ty = Immediate -> - int - | () when is_base_type env ty Predef.path_float -> float - | () when is_base_type env ty Predef.path_string -> string - | () when is_base_type env ty Predef.path_bigint -> bigint - | () when is_base_type env ty Predef.path_bool -> bool - | () -> obj + intcomp + | () when is_base_type env ty Predef.path_float -> floatcomp + | () when is_base_type env ty Predef.path_string -> stringcomp + | () when is_base_type env ty Predef.path_bigint -> bigintcomp + | () when is_base_type env ty Predef.path_bool -> boolcomp + | () -> objcomp (* Specialize a primitive from available type information, raise Not_found if primitive is unknown *) let specialize_primitive p env ty (* ~has_constant_constructor *) = try - let table = Hashtbl.find infix_table p.prim_name in + let table = Hashtbl.find comparisons_table p.prim_name in match is_function_type env ty with - | Some (lhs, _rhs) -> specialize_op table env lhs - | None -> table.obj - with Not_found -> ( - try - let table = Hashtbl.find comparisons_table p.prim_name in - match is_function_type env ty with - | Some (lhs, _rhs) -> specialize_op table env lhs - | None -> table.obj - with Not_found -> find_primitive p.prim_name) + | Some (lhs, _rhs) -> specialize_comparison table env lhs + | None -> table.objcomp + with Not_found -> find_primitive p.prim_name (* Eta-expand a primitive *) @@ -502,9 +472,7 @@ let transl_primitive_application loc prim env ty args = | [arg1; _] when is_base_type env arg1.exp_type Predef.path_bool && Hashtbl.mem comparisons_table prim_name -> - (Hashtbl.find comparisons_table prim_name).bool - | [arg1; _] when Hashtbl.mem infix_table prim_name -> - specialize_op (Hashtbl.find infix_table prim_name) env arg1.exp_type + (Hashtbl.find comparisons_table prim_name).boolcomp | _ -> let has_constant_constructor = match args with @@ -517,7 +485,7 @@ let transl_primitive_application loc prim env ty args = in if has_constant_constructor then match Hashtbl.find_opt comparisons_table prim_name with - | Some table when table.simplify_constant_constructor -> table.int + | Some table when table.simplify_constant_constructor -> table.intcomp | Some _ | None -> specialize_primitive prim env ty (* ~has_constant_constructor*) else specialize_primitive prim env ty From 19e01b702a04c2f82f90ab76bb29e05ce6b53de7 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Tue, 5 Nov 2024 02:32:26 +0900 Subject: [PATCH 06/16] done implement unified_ops translation --- compiler/core/lam_convert.ml | 11 ---- compiler/ml/lambda.ml | 4 -- compiler/ml/lambda.mli | 4 -- compiler/ml/printlambda.ml | 2 - compiler/ml/translcore.ml | 115 +++++++++++++++++++++++------------ compiler/ml/typecore.ml | 4 +- compiler/ml/unified_ops.ml | 18 +++--- 7 files changed, 86 insertions(+), 72 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index fcfa102098..74131236ab 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -232,7 +232,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pduprecord -> prim ~primitive:Pduprecord ~args loc | Plazyforce -> prim ~primitive:Plazyforce ~args loc | Praise _ -> prim ~primitive:Praise ~args loc - | Pinfix _ -> assert false | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc | Pobjorder -> prim ~primitive:Pobjorder ~args loc | Pobjmin -> prim ~primitive:Pobjmin ~args loc @@ -476,16 +475,6 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lprim (Pimport, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import:true) in lam_prim ~primitive:Pimport ~args loc - | Lprim (Pinfix (Inf_custom (mod_, op)), args, loc) -> - let fn = Lam.var (Ident.create_persistent op) in - let args = Ext_list.map args (convert_aux ~dynamic_import) in - let ap_info : Lam.ap_info = - {ap_loc = loc; ap_status = App_na; ap_inlined = Lambda.Default_inline} - in - Lam.apply fn args ap_info - | Lprim (Pinfix Inf_invariant, args, loc) -> - (* TODO : invariant *) - assert false | Lprim (primitive, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import) in lam_prim ~primitive ~args loc diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 857cfa991f..fcd1dc86ca 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -175,8 +175,6 @@ type immediate_or_pointer = Immediate | Pointer type is_safe = Safe | Unsafe -type infix_info = Inf_custom of string * string | Inf_invariant - type primitive = | Pidentity | Pignore @@ -200,8 +198,6 @@ type primitive = | Pccall of Primitive.description (* Exceptions *) | Praise of raise_kind - (* Infix *) - | Pinfix of infix_info (* object operations *) | Pobjcomp of comparison | Pobjorder diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index e2605c3029..7f506ac62d 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -138,8 +138,6 @@ type pointer_info = | Pt_shape_none | Pt_assertfalse -type infix_info = Inf_custom of string * string | Inf_invariant - type primitive = | Pidentity | Pignore @@ -163,8 +161,6 @@ type primitive = | Pccall of Primitive.description (* Exceptions *) | Praise of raise_kind - (* Infix *) - | Pinfix of infix_info (* object primitives *) | Pobjcomp of comparison | Pobjorder diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index a01b305dfc..4512355c34 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -125,8 +125,6 @@ let primitive ppf = function | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) - | Pinfix (Inf_custom (mod_, op)) -> fprintf ppf "%s.%s" mod_ op - | Pinfix Inf_invariant -> fprintf ppf "invariant" | Pobjcomp Ceq -> fprintf ppf "==" | Pobjcomp Cneq -> fprintf ppf "!=" | Pobjcomp Clt -> fprintf ppf "<" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index f4009c3d6d..0f0dc1b04a 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -49,14 +49,30 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) -(* -type sargs = (Asttypes.arg_label * Parsetree.expression) list - -let translate_unified_application (env : Env.t) (prim : Primitive.description) - (sargs : sargs) : Lambda.primitive option = - (* TODO *) - None -*) +let translate_unified_ops (prim : Primitive.description) (env : Env.t) + (lhs_type : type_expr) : Lambda.primitive option = + (* lhs_type is already unified in type-level *) + let entry = Hashtbl.find_opt Unified_ops.index_by_name prim.prim_name in + match entry with + | Some {specialization} -> ( + match specialization with + | {int} + when is_base_type env lhs_type Predef.path_int + || is_base_type env lhs_type Predef.path_char + || maybe_pointer_type env lhs_type = Immediate -> + Some int + | {float = Some float} when is_base_type env lhs_type Predef.path_float -> + Some float + | {bigint = Some bigint} when is_base_type env lhs_type Predef.path_bigint + -> + Some bigint + | {string = Some string} when is_base_type env lhs_type Predef.path_string + -> + Some string + | {bool = Some bool} when is_base_type env lhs_type Predef.path_bool -> + Some bool + | {int} -> Some int) + | _ -> None type specialized = { objcomp: Lambda.primitive; @@ -403,12 +419,21 @@ let specialize_comparison raise Not_found if primitive is unknown *) let specialize_primitive p env ty (* ~has_constant_constructor *) = - try - let table = Hashtbl.find comparisons_table p.prim_name in - match is_function_type env ty with - | Some (lhs, _rhs) -> specialize_comparison table env lhs - | None -> table.objcomp - with Not_found -> find_primitive p.prim_name + let fn_expr = is_function_type env ty in + let unified = + match fn_expr with + | Some (lhs, _) -> translate_unified_ops p env lhs + | None -> None + in + match unified with + | Some primitive -> primitive + | None -> ( + try + let table = Hashtbl.find comparisons_table p.prim_name in + match fn_expr with + | Some (lhs, _rhs) -> specialize_comparison table env lhs + | None -> table.objcomp + with Not_found -> find_primitive p.prim_name) (* Eta-expand a primitive *) @@ -467,32 +492,44 @@ let transl_primitive loc p env ty = let transl_primitive_application loc prim env ty args = let prim_name = prim.prim_name in - try + let unified = match args with - | [arg1; _] - when is_base_type env arg1.exp_type Predef.path_bool - && Hashtbl.mem comparisons_table prim_name -> - (Hashtbl.find comparisons_table prim_name).boolcomp - | _ -> - let has_constant_constructor = - match args with - | [_; {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}] - | [{exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; _] - | [_; {exp_desc = Texp_variant (_, None)}] - | [{exp_desc = Texp_variant (_, None)}; _] -> - true - | _ -> false - in - if has_constant_constructor then - match Hashtbl.find_opt comparisons_table prim_name with - | Some table when table.simplify_constant_constructor -> table.intcomp - | Some _ | None -> specialize_primitive prim env ty - (* ~has_constant_constructor*) - else specialize_primitive prim env ty - with Not_found -> - if String.length prim_name > 0 && prim_name.[0] = '%' then - raise (Error (loc, Unknown_builtin_primitive prim_name)); - Pccall prim + | [arg1] | [arg1; _] -> translate_unified_ops prim env arg1.exp_type + | _ -> None + in + match unified with + | Some primitive -> primitive + | None -> ( + try + match args with + | [arg1; _] + when is_base_type env arg1.exp_type Predef.path_bool + && Hashtbl.mem comparisons_table prim_name -> + (Hashtbl.find comparisons_table prim_name).boolcomp + | _ -> + let has_constant_constructor = + match args with + | [ + _; {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; + ] + | [ + {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; _; + ] + | [_; {exp_desc = Texp_variant (_, None)}] + | [{exp_desc = Texp_variant (_, None)}; _] -> + true + | _ -> false + in + if has_constant_constructor then + match Hashtbl.find_opt comparisons_table prim_name with + | Some table when table.simplify_constant_constructor -> table.intcomp + | Some _ | None -> specialize_primitive prim env ty + (* ~has_constant_constructor*) + else specialize_primitive prim env ty + with Not_found -> + if String.length prim_name > 0 && prim_name.[0] = '%' then + raise (Error (loc, Unknown_builtin_primitive prim_name)); + Pccall prim) (* To propagate structured constants *) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 444f5dadd9..a3daf429f4 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2458,7 +2458,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp in let type_clash_context = type_clash_context_from_function sexp sfunct in let args, ty_res, fully_applied = - match translate_unified_application env funct sargs with + match translate_unified_ops env funct sargs with | Some (targs, result_type) -> (targs, result_type, true) | None -> type_application ?type_clash_context uncurried env funct sargs in @@ -3563,7 +3563,7 @@ and is_automatic_curried_application env funct = | Tarrow _ -> true | _ -> false -and translate_unified_application (env : Env.t) (funct : Typedtree.expression) +and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) (sargs : sargs) : (targs * Types.type_expr) option = match funct.exp_desc with | Texp_ident (path, _, _) -> ( diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml index b276d5831a..01cfb620c5 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -24,6 +24,14 @@ open Misc Since these are simple ad-hoc translations for primitive applications, we cannot use the result type defined in other contexts. So falling back to int type is the simplest behavior that ensures backwards compatibility. + + Actual implementations of translation are colocated into core modules + + You can find it in: + - Type-level : ml/typecore.ml + - IR-level : ml/translcore.ml + + With function name "translate_unified_ops" *) type form = Unary | Binary @@ -81,13 +89,3 @@ let index_by_path = let index_by_name = entries |> Array.map (fun entry -> (entry.name, entry)) |> create_hashtable - -(* - Actual implementations of translation are colocated into core modules - - You can find it in: - - Type-level : ml/typecore.ml - - IR-level : ml/translcore.ml - - With function name "translate_unified_application" -*) From 2c05e5ac0edc6e6c8e1661b34c1e00af4f412bd4 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Tue, 5 Nov 2024 02:45:52 +0900 Subject: [PATCH 07/16] migrate other arithmetic operators --- compiler/ml/unified_ops.ml | 65 ++++++++++++++++++++++++++++++++++++++ runtime/Pervasives.res | 11 ++++--- 2 files changed, 71 insertions(+), 5 deletions(-) diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml index 01cfb620c5..f09ab5c064 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -56,6 +56,32 @@ let builtin x = Primitive_modules.pervasives ^ "." ^ x let entries = [| + { + path = builtin "~+"; + name = "%pos"; + form = Unary; + specialization = + { + int = Pidentity; + bool = None; + float = Some Pidentity; + bigint = Some Pidentity; + string = None; + }; + }; + { + path = builtin "~-"; + name = "%neg"; + form = Unary; + specialization = + { + int = Pnegint; + bool = None; + float = Some Pnegfloat; + bigint = Some Pnegbigint; + string = None; + }; + }; { path = builtin "+"; name = "%add"; @@ -82,6 +108,45 @@ let entries = string = None; }; }; + { + path = builtin "*"; + name = "%mul"; + form = Binary; + specialization = + { + int = Pmulint; + bool = None; + float = Some Pmulfloat; + bigint = Some Pmulbigint; + string = None; + }; + }; + { + path = builtin "/"; + name = "%div"; + form = Binary; + specialization = + { + int = Pdivint Safe; + bool = None; + float = Some Pdivfloat; + bigint = Some Pdivbigint; + string = None; + }; + }; + { + path = builtin "mod"; + name = "%mod"; + form = Binary; + specialization = + { + int = Pmodint Safe; + bool = None; + float = Some Pmodfloat; + bigint = Some Pmodbigint; + string = None; + }; + }; |] let index_by_path = diff --git a/runtime/Pervasives.res b/runtime/Pervasives.res index 857a2cea38..dcdb420114 100644 --- a/runtime/Pervasives.res +++ b/runtime/Pervasives.res @@ -42,8 +42,14 @@ external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" /* Unified operations */ +external \"~+": 'a => 'a = "%pos" +external \"~-": 'a => 'a = "%neg" + external \"+": ('a, 'a) => 'a = "%add" external \"-": ('a, 'a) => 'a = "%sub" +external \"*": ('a, 'a) => 'a = "%mul" +external \"/": ('a, 'a) => 'a = "%div" +external mod: ('a, 'a) => 'a = "%mod" /* Comparisons */ /* Note: Later comparisons will be converted to unified operations too */ @@ -70,13 +76,8 @@ external \"||": (bool, bool) => bool = "%sequor" /* Integer operations */ -external \"~-": int => int = "%negint" -external \"~+": int => int = "%identity" external succ: int => int = "%succint" external pred: int => int = "%predint" -external \"*": (int, int) => int = "%mulint" -external \"/": (int, int) => int = "%divint" -external mod: (int, int) => int = "%modint" @deprecated("Use Core instead. This will be removed in v13") let abs = x => From 66079739c1e1b975f9cf8e1db70c316427126c22 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Tue, 5 Nov 2024 02:54:36 +0900 Subject: [PATCH 08/16] rename test and more cases --- tests/tests/src/generic_infix_test.mjs | 38 -------------- tests/tests/src/generic_infix_test.res | 9 ---- tests/tests/src/unified_ops_test.mjs | 73 ++++++++++++++++++++++++++ tests/tests/src/unified_ops_test.res | 19 +++++++ 4 files changed, 92 insertions(+), 47 deletions(-) delete mode 100644 tests/tests/src/generic_infix_test.mjs delete mode 100644 tests/tests/src/generic_infix_test.res create mode 100644 tests/tests/src/unified_ops_test.mjs create mode 100644 tests/tests/src/unified_ops_test.res diff --git a/tests/tests/src/generic_infix_test.mjs b/tests/tests/src/generic_infix_test.mjs deleted file mode 100644 index 19fde3ce35..0000000000 --- a/tests/tests/src/generic_infix_test.mjs +++ /dev/null @@ -1,38 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -let float = 1 + 2; - -let string = "12"; - -let bigint = 1n + 2n; - -function addint(a, b) { - return a + b | 0; -} - -function addfloat(a, b) { - return a + b; -} - -function addbigint(a, b) { - return a + b; -} - -function addstring(a, b) { - return a + b; -} - -let int = 3; - -export { - int, - float, - string, - bigint, - addint, - addfloat, - addbigint, - addstring, -} -/* No side effect */ diff --git a/tests/tests/src/generic_infix_test.res b/tests/tests/src/generic_infix_test.res deleted file mode 100644 index fccf697ab7..0000000000 --- a/tests/tests/src/generic_infix_test.res +++ /dev/null @@ -1,9 +0,0 @@ -let int = 1 + 2 -let float = 1. + 2. -let string = "1" + "2" -let bigint = 1n + 2n - -let addint = (a, b) => a + b -let addfloat = (a: float, b) => a + b -let addbigint = (a: bigint, b) => a + b -let addstring = (a: string, b) => a + b diff --git a/tests/tests/src/unified_ops_test.mjs b/tests/tests/src/unified_ops_test.mjs new file mode 100644 index 0000000000..03f68c97fd --- /dev/null +++ b/tests/tests/src/unified_ops_test.mjs @@ -0,0 +1,73 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +let float = 1 + 2; + +let string = "12"; + +let bigint = 1n + 2n; + +function unknown(a, b) { + return a + b | 0; +} + +function lhsint(a, b) { + return a + b | 0; +} + +function lhsfloat(a, b) { + return a + b; +} + +function lhsbigint(a, b) { + return a + b; +} + +function lhsstring(a, b) { + return a + b; +} + +function rhsint(a, b) { + return a + b | 0; +} + +function rhsfloat(a, b) { + return a + b; +} + +function rhsbigint(a, b) { + return a + b; +} + +function rhsstring(a, b) { + return a + b; +} + +function case1(a) { + return 1 + a | 0; +} + +function case2(a, b) { + return a + "test" + b; +} + +let int = 3; + +export { + int, + float, + string, + bigint, + unknown, + lhsint, + lhsfloat, + lhsbigint, + lhsstring, + rhsint, + rhsfloat, + rhsbigint, + rhsstring, + case1, + case2, +} +/* No side effect */ diff --git a/tests/tests/src/unified_ops_test.res b/tests/tests/src/unified_ops_test.res new file mode 100644 index 0000000000..610a527a97 --- /dev/null +++ b/tests/tests/src/unified_ops_test.res @@ -0,0 +1,19 @@ +let int = 1 + 2 +let float = 1. + 2. +let string = "1" + "2" +let bigint = 1n + 2n + +let unknown = (a, b) => a + b + +let lhsint = (a: int, b) => a + b +let lhsfloat = (a: float, b) => a + b +let lhsbigint = (a: bigint, b) => a + b +let lhsstring = (a: string, b) => a + b + +let rhsint = (a, b: int) => a + b +let rhsfloat = (a, b: float) => a + b +let rhsbigint = (a, b: bigint) => a + b +let rhsstring = (a, b: string) => a + b + +let case1 = a => 1 + a +let case2 = (a, b) => a + "test" + b From cd7aa380fc4d5ec91433d7d5a700674a4442a777 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Wed, 6 Nov 2024 00:44:20 +0900 Subject: [PATCH 09/16] link comments --- compiler/ml/translcore.ml | 3 +++ compiler/ml/typecore.ml | 9 ++++++--- compiler/ml/unified_ops.ml | 1 + 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 0f0dc1b04a..ed0ebb6b56 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -49,6 +49,9 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) +(** This is ad-hoc translation for unifying specific primitive operations + See [Unified_ops] module for detailed explanation. + *) let translate_unified_ops (prim : Primitive.description) (env : Env.t) (lhs_type : type_expr) : Lambda.primitive option = (* lhs_type is already unified in type-level *) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index a3daf429f4..bd9928b31b 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3563,6 +3563,9 @@ and is_automatic_curried_application env funct = | Tarrow _ -> true | _ -> false +(** This is ad-hoc translation for unifying specific primitive operations + See [Unified_ops] module for detailed explanation. + *) and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) (sargs : sargs) : (targs * Types.type_expr) option = match funct.exp_desc with @@ -3601,7 +3604,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) let rhs = type_exp env rhs_expr in let rhs_type = expand_head env rhs.exp_type in let lhs, rhs, result_type = - (* rule 1. *) + (* Rule 1. Try unifying to lhs *) match (lhs_type.desc, specialization) with | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> let rhs = type_expect env rhs_expr Predef.type_int in @@ -3623,7 +3626,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) let rhs = type_expect env rhs_expr Predef.type_string in (lhs, rhs, Predef.type_string) | _ -> ( - (* rule 2. *) + (* Rule 2. Try unifying to rhs *) match (rhs_type.desc, specialization) with | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> let lhs = type_expect env lhs_expr Predef.type_int in @@ -3645,7 +3648,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) let lhs = type_expect env lhs_expr Predef.type_string in (lhs, rhs, Predef.type_string) | _ -> - (* rule 3. *) + (* Rule 2. Fallback to int *) let lhs = type_expect env lhs_expr Predef.type_int in let rhs = type_expect env rhs_expr Predef.type_int in (lhs, rhs, Predef.type_int)) diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml index f09ab5c064..c6d4759a8c 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -36,6 +36,7 @@ open Misc type form = Unary | Binary +(* Note: unified op must support int type *) type specialization = { int: Lambda.primitive; bool: Lambda.primitive option; From bcccd7616a6c0fd6a1e7ce71915afe78d83cec8a Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Wed, 6 Nov 2024 00:45:21 +0900 Subject: [PATCH 10/16] remove unused clause --- compiler/ml/translcore.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index ed0ebb6b56..a3f61e8990 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -61,7 +61,6 @@ let translate_unified_ops (prim : Primitive.description) (env : Env.t) match specialization with | {int} when is_base_type env lhs_type Predef.path_int - || is_base_type env lhs_type Predef.path_char || maybe_pointer_type env lhs_type = Immediate -> Some int | {float = Some float} when is_base_type env lhs_type Predef.path_float -> From 68fa0dc22866dd02aef1300a0050a9ad82a8cb37 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Wed, 6 Nov 2024 02:07:13 +0900 Subject: [PATCH 11/16] rename primitive --- compiler/ml/unified_ops.ml | 2 +- runtime/Pervasives.res | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml index c6d4759a8c..3aaa4dd021 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -59,7 +59,7 @@ let entries = [| { path = builtin "~+"; - name = "%pos"; + name = "%plus"; form = Unary; specialization = { diff --git a/runtime/Pervasives.res b/runtime/Pervasives.res index dcdb420114..f3552aae89 100644 --- a/runtime/Pervasives.res +++ b/runtime/Pervasives.res @@ -42,7 +42,7 @@ external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" /* Unified operations */ -external \"~+": 'a => 'a = "%pos" +external \"~+": 'a => 'a = "%plus" external \"~-": 'a => 'a = "%neg" external \"+": ('a, 'a) => 'a = "%add" From adc65bf688c3a562ad4ff6b756afd2901b0a0b9f Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Wed, 6 Nov 2024 02:10:13 +0900 Subject: [PATCH 12/16] sync Pervasives_mini --- runtime/Pervasives_mini.res | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/runtime/Pervasives_mini.res b/runtime/Pervasives_mini.res index 9c62e80ffe..43dcd6cc3e 100644 --- a/runtime/Pervasives_mini.res +++ b/runtime/Pervasives_mini.res @@ -13,7 +13,19 @@ external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC" external __LINE_OF__: 'a => (int, 'a) = "%loc_LINE" external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" +/* Unified operations */ + +external \"~+": 'a => 'a = "%plus" +external \"~-": 'a => 'a = "%neg" + +external \"+": ('a, 'a) => 'a = "%add" +external \"-": ('a, 'a) => 'a = "%sub" +external \"*": ('a, 'a) => 'a = "%mul" +external \"/": ('a, 'a) => 'a = "%div" +external mod: ('a, 'a) => 'a = "%mod" + /* Comparisons */ +/* Note: Later comparisons will be converted to unified operations too */ external \"=": ('a, 'a) => bool = "%equal" external \"<>": ('a, 'a) => bool = "%notequal" @@ -37,15 +49,8 @@ external \"||": (bool, bool) => bool = "%sequor" /* Integer operations */ -external \"~-": int => int = "%negint" -external \"~+": int => int = "%identity" external succ: int => int = "%succint" external pred: int => int = "%predint" -external \"+": (int, int) => int = "%addint" -external \"-": (int, int) => int = "%subint" -external \"*": (int, int) => int = "%mulint" -external \"/": (int, int) => int = "%divint" -external mod: (int, int) => int = "%modint" external land: (int, int) => int = "%andint" external lor: (int, int) => int = "%orint" From efa0058a2d557a836a52b9f7c2c4e7a3e0f27b3d Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Wed, 6 Nov 2024 02:50:34 +0900 Subject: [PATCH 13/16] keep arg labels --- compiler/ml/typecore.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index bd9928b31b..ae6e81b0ca 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3572,7 +3572,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) | Texp_ident (path, _, _) -> ( let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in match (entry, sargs) with - | Some {form = Unary; specialization; _}, [(Nolabel, lhs_expr)] -> + | Some {form = Unary; specialization; _}, [(lhs_label, lhs_expr)] -> let lhs = type_exp env lhs_expr in let lhs_type = expand_head env lhs.exp_type in let result_type = @@ -3595,10 +3595,10 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) unify env lhs_type Predef.type_int; Predef.type_int in - let targs = [(Nolabel, Some lhs)] in + let targs = [(lhs_label, Some lhs)] in Some (targs, result_type) | ( Some {form = Binary; specialization; _}, - [(Nolabel, lhs_expr); (Nolabel, rhs_expr)] ) -> + [(lhs_label, lhs_expr); (rhs_label, rhs_expr)] ) -> let lhs = type_exp env lhs_expr in let lhs_type = expand_head env lhs.exp_type in let rhs = type_exp env rhs_expr in @@ -3648,12 +3648,12 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) let lhs = type_expect env lhs_expr Predef.type_string in (lhs, rhs, Predef.type_string) | _ -> - (* Rule 2. Fallback to int *) + (* Rule 3. Fallback to int *) let lhs = type_expect env lhs_expr Predef.type_int in let rhs = type_expect env rhs_expr Predef.type_int in (lhs, rhs, Predef.type_int)) in - let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in + let targs = [(lhs_label, Some lhs); (rhs_label, Some rhs)] in Some (targs, result_type) | _ -> None) | _ -> None From 15595d266dd543f801b7753bebf473cf96d1b12d Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Wed, 6 Nov 2024 03:09:03 +0900 Subject: [PATCH 14/16] format --- compiler/ml/typecore.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index ae6e81b0ca..404bb70f7c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3572,7 +3572,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) | Texp_ident (path, _, _) -> ( let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in match (entry, sargs) with - | Some {form = Unary; specialization; _}, [(lhs_label, lhs_expr)] -> + | Some {form = Unary; specialization}, [(lhs_label, lhs_expr)] -> let lhs = type_exp env lhs_expr in let lhs_type = expand_head env lhs.exp_type in let result_type = @@ -3597,7 +3597,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) in let targs = [(lhs_label, Some lhs)] in Some (targs, result_type) - | ( Some {form = Binary; specialization; _}, + | ( Some {form = Binary; specialization}, [(lhs_label, lhs_expr); (rhs_label, rhs_expr)] ) -> let lhs = type_exp env lhs_expr in let lhs_type = expand_head env lhs.exp_type in From 1791379138e815c9e24402ef288ccae3ac502a41 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Thu, 7 Nov 2024 03:05:18 +0900 Subject: [PATCH 15/16] note on pervasives_mini --- runtime/Pervasives_mini.res | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/runtime/Pervasives_mini.res b/runtime/Pervasives_mini.res index 43dcd6cc3e..d38b877a32 100644 --- a/runtime/Pervasives_mini.res +++ b/runtime/Pervasives_mini.res @@ -14,15 +14,21 @@ external __LINE_OF__: 'a => (int, 'a) = "%loc_LINE" external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" /* Unified operations */ +/* + Note: -external \"~+": 'a => 'a = "%plus" -external \"~-": 'a => 'a = "%neg" + Unified operations only work on `Pervasives`. + That means we can't rely on it when building stdlib until we remove the `Pervasives_mini`. +*/ -external \"+": ('a, 'a) => 'a = "%add" -external \"-": ('a, 'a) => 'a = "%sub" -external \"*": ('a, 'a) => 'a = "%mul" -external \"/": ('a, 'a) => 'a = "%div" -external mod: ('a, 'a) => 'a = "%mod" +external \"~+": int => int = "%identity" +external \"~-": int => int = "%negint" + +external \"+": (int, int) => int = "%addint" +external \"-": (int, int) => int = "%subint" +external \"*": (int, int) => int = "%mulint" +external \"/": (int, int) => int = "%divint" +external mod: (int, int) => int = "%modint" /* Comparisons */ /* Note: Later comparisons will be converted to unified operations too */ From 1ef4469f5e7c80ad3c8ef7cef1958ae5a4c7697a Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Thu, 7 Nov 2024 03:08:27 +0900 Subject: [PATCH 16/16] add changelog --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 977198bd4c..bf761eae4c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,10 @@ # 12.0.0-alpha.5 (Unreleased) +#### :rocket: New Feature + +- Introduce "Unified operators" for arithmetic operators (`+`, `-`, `*`, `/`, `mod`). See https://github.com/rescript-lang/rescript-compiler/pull/7057 + # 12.0.0-alpha.4 #### :boom: Breaking Change