Skip to content

Commit f8a673e

Browse files
cometkimcometkim
committedNov 4, 2024
rewrite type translation
1 parent 99ffa6c commit f8a673e

File tree

5 files changed

+201
-64
lines changed

5 files changed

+201
-64
lines changed
 

‎compiler/ml/translcore.ml

+9
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,15 @@ let transl_extension_constructor env path ext =
4949

5050
(* Translation of primitives *)
5151

52+
(*
53+
type sargs = (Asttypes.arg_label * Parsetree.expression) list
54+
55+
let translate_unified_application (env : Env.t) (prim : Primitive.description)
56+
(sargs : sargs) : Lambda.primitive option =
57+
(* TODO *)
58+
None
59+
*)
60+
5261
type specialized = {
5362
obj: Lambda.primitive;
5463
int: Lambda.primitive;

‎compiler/ml/typecore.ml

+92-31
Original file line numberDiff line numberDiff line change
@@ -2458,8 +2458,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
24582458
in
24592459
let type_clash_context = type_clash_context_from_function sexp sfunct in
24602460
let args, ty_res, fully_applied =
2461-
match specialized_infix_type_application env funct sargs with
2462-
| Some application -> application
2461+
match translate_unified_application env funct sargs with
2462+
| Some (targs, result_type) -> (targs, result_type, true)
24632463
| None -> type_application ?type_clash_context uncurried env funct sargs
24642464
in
24652465
end_def ();
@@ -3563,35 +3563,96 @@ and is_automatic_curried_application env funct =
35633563
| Tarrow _ -> true
35643564
| _ -> false
35653565
3566-
and specialized_infix_type_application env funct (sargs : sargs) :
3567-
(targs * Types.type_expr * bool) option =
3568-
let is_generic_infix path =
3569-
match Path.name path with
3570-
| "Pervasives.+" | "Pervasives.-" -> true
3571-
| _ -> false
3572-
in
3573-
match (funct.exp_desc, sargs) with
3574-
| Texp_ident (path, _, _), [(Nolabel, lhs_expr); (Nolabel, rhs_expr)]
3575-
when is_generic_infix path ->
3576-
let lhs = type_exp env lhs_expr in
3577-
let lhs_type = lhs.exp_type in
3578-
let rhs =
3579-
match (expand_head env lhs_type).desc with
3580-
| Tconstr (path, _, _) when Path.same path Predef.path_int ->
3581-
type_expect env rhs_expr Predef.type_int
3582-
| Tconstr (path, _, _) when Path.same path Predef.path_float ->
3583-
type_expect env rhs_expr Predef.type_float
3584-
| Tconstr (path, _, _) when Path.same path Predef.path_bigint ->
3585-
type_expect env rhs_expr Predef.type_bigint
3586-
| Tconstr (path, _, _) when Path.same path Predef.path_string ->
3587-
type_expect env rhs_expr Predef.type_string
3588-
| _ ->
3589-
unify env lhs_type Predef.type_int;
3590-
type_expect env rhs_expr Predef.type_int
3591-
in
3592-
let result_type = lhs_type in
3593-
let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in
3594-
Some (targs, result_type, true)
3566+
and translate_unified_application (env : Env.t) (funct : Typedtree.expression)
3567+
(sargs : sargs) : (targs * Types.type_expr) option =
3568+
match funct.exp_desc with
3569+
| Texp_ident (path, _, _) -> (
3570+
let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in
3571+
match (entry, sargs) with
3572+
| Some {form = Unary; specialization; _}, [(Nolabel, lhs_expr)] ->
3573+
let lhs = type_exp env lhs_expr in
3574+
let lhs_type = expand_head env lhs.exp_type in
3575+
let result_type =
3576+
match (lhs_type.desc, specialization) with
3577+
| Tconstr (path, _, _), _ when Path.same path Predef.path_int ->
3578+
Predef.type_int
3579+
| Tconstr (path, _, _), {bool = Some _}
3580+
when Path.same path Predef.path_bool ->
3581+
Predef.type_bool
3582+
| Tconstr (path, _, _), {float = Some _}
3583+
when Path.same path Predef.path_float ->
3584+
Predef.type_float
3585+
| Tconstr (path, _, _), {bigint = Some _}
3586+
when Path.same path Predef.path_bigint ->
3587+
Predef.type_bigint
3588+
| Tconstr (path, _, _), {string = Some _}
3589+
when Path.same path Predef.path_string ->
3590+
Predef.type_string
3591+
| _ ->
3592+
unify env lhs_type Predef.type_int;
3593+
Predef.type_int
3594+
in
3595+
let targs = [(Nolabel, Some lhs)] in
3596+
Some (targs, result_type)
3597+
| ( Some {form = Binary; specialization; _},
3598+
[(Nolabel, lhs_expr); (Nolabel, rhs_expr)] ) ->
3599+
let lhs = type_exp env lhs_expr in
3600+
let lhs_type = expand_head env lhs.exp_type in
3601+
let rhs = type_exp env rhs_expr in
3602+
let rhs_type = expand_head env rhs.exp_type in
3603+
let lhs, rhs, result_type =
3604+
(* rule 1. *)
3605+
match (lhs_type.desc, specialization) with
3606+
| Tconstr (path, _, _), _ when Path.same path Predef.path_int ->
3607+
let rhs = type_expect env rhs_expr Predef.type_int in
3608+
(lhs, rhs, Predef.type_int)
3609+
| Tconstr (path, _, _), {bool = Some _}
3610+
when Path.same path Predef.path_bool ->
3611+
let rhs = type_expect env rhs_expr Predef.type_bool in
3612+
(lhs, rhs, Predef.type_bool)
3613+
| Tconstr (path, _, _), {float = Some _}
3614+
when Path.same path Predef.path_float ->
3615+
let rhs = type_expect env rhs_expr Predef.type_float in
3616+
(lhs, rhs, Predef.type_float)
3617+
| Tconstr (path, _, _), {bigint = Some _}
3618+
when Path.same path Predef.path_bigint ->
3619+
let rhs = type_expect env rhs_expr Predef.type_bigint in
3620+
(lhs, rhs, Predef.type_bigint)
3621+
| Tconstr (path, _, _), {string = Some _}
3622+
when Path.same path Predef.path_string ->
3623+
let rhs = type_expect env rhs_expr Predef.type_string in
3624+
(lhs, rhs, Predef.type_string)
3625+
| _ -> (
3626+
(* rule 2. *)
3627+
match (rhs_type.desc, specialization) with
3628+
| Tconstr (path, _, _), _ when Path.same path Predef.path_int ->
3629+
let lhs = type_expect env lhs_expr Predef.type_int in
3630+
(lhs, rhs, Predef.type_int)
3631+
| Tconstr (path, _, _), {bool = Some _}
3632+
when Path.same path Predef.path_bool ->
3633+
let lhs = type_expect env lhs_expr Predef.type_bool in
3634+
(lhs, rhs, Predef.type_bool)
3635+
| Tconstr (path, _, _), {float = Some _}
3636+
when Path.same path Predef.path_float ->
3637+
let lhs = type_expect env lhs_expr Predef.type_float in
3638+
(lhs, rhs, Predef.type_float)
3639+
| Tconstr (path, _, _), {bigint = Some _}
3640+
when Path.same path Predef.path_bigint ->
3641+
let lhs = type_expect env lhs_expr Predef.type_bigint in
3642+
(lhs, rhs, Predef.type_bigint)
3643+
| Tconstr (path, _, _), {string = Some _}
3644+
when Path.same path Predef.path_string ->
3645+
let lhs = type_expect env lhs_expr Predef.type_string in
3646+
(lhs, rhs, Predef.type_string)
3647+
| _ ->
3648+
(* rule 3. *)
3649+
let lhs = type_expect env lhs_expr Predef.type_int in
3650+
let rhs = type_expect env rhs_expr Predef.type_int in
3651+
(lhs, rhs, Predef.type_int))
3652+
in
3653+
let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in
3654+
Some (targs, result_type)
3655+
| _ -> None)
35953656
| _ -> None
35963657
35973658
and type_application ?type_clash_context uncurried env funct (sargs : sargs) :

‎compiler/ml/unified_ops.ml

+70-24
Original file line numberDiff line numberDiff line change
@@ -1,47 +1,93 @@
1-
open Btype
2-
open Types
31
open Misc
42

53
(*
64
Unified_ops is for specialization of some primitive operators.
75
86
For example adding two values. We have `+` for ints, `+.` for floats, and `++` for strings.
9-
That because we don't use implicit type conversion or overloading.
7+
That because we don't allow implicit conversion or overloading for operations.
108
11-
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.
9+
It is a fundamental property of the ReScript language, but it is far from the best DX we can think of,
10+
and it became a problem when new primitives like bigint were introduced.
1211
1312
See discussion: https://github.com/rescript-lang/rescript-compiler/issues/6525
1413
15-
1. Type level translation
14+
Unified ops mitigate the problem by adding ad-hoc translation rules on applications of the core built-in operators
15+
which have form of binary infix ('a -> 'a -> 'a) or unary ('a -> 'a)
1616
17-
2. IR level translation
18-
*)
17+
Translation rules should be applied in its application, in both type-level and IR(lambda)-level.
1918
20-
type args = (Asttypes.arg_label * Parsetree.expression) list
21-
type targs = (Asttypes.arg_label * Typedtree.expression option) list
19+
The rules:
2220
23-
type specialized_type = {
24-
int: Path.t;
25-
bool: Path.t option;
26-
float: Path.t option;
27-
bigint: Path.t option;
28-
string: Path.t option;
29-
}
21+
1. If the lhs type is a primitive type, unify the rhs and the result type to the lhs type.
22+
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.
23+
3. If both lhs type and rhs type is not a primitive type, unify the whole types to the int.
24+
25+
Since these are simple ad-hoc translations for primitive applications, we cannot use the result type defined in other contexts.
26+
So falling back to int type is the simplest behavior that ensures backwards compatibility.
27+
*)
3028

31-
let specialized_types = create_hashtable [||]
29+
type form = Unary | Binary
3230

33-
type specialized_primitive = {
31+
type specialization = {
3432
int: Lambda.primitive;
3533
bool: Lambda.primitive option;
3634
float: Lambda.primitive option;
3735
bigint: Lambda.primitive option;
3836
string: Lambda.primitive option;
3937
}
4038

41-
let translate_type_application (env : Env.t) (funct : Parsetree.expression)
42-
(args : args) : (targs * type_expr) option =
43-
None
39+
type entry = {
40+
path: string;
41+
(** TODO: Maybe it can be a Path.t in Predef instead of string *)
42+
name: string;
43+
form: form;
44+
specialization: specialization;
45+
}
46+
47+
let builtin x = Primitive_modules.pervasives ^ "." ^ x
48+
49+
let entries =
50+
[|
51+
{
52+
path = builtin "+";
53+
name = "%add";
54+
form = Binary;
55+
specialization =
56+
{
57+
int = Paddint;
58+
bool = None;
59+
float = Some Paddfloat;
60+
bigint = Some Paddbigint;
61+
string = Some Pstringadd;
62+
};
63+
};
64+
{
65+
path = builtin "-";
66+
name = "%sub";
67+
form = Binary;
68+
specialization =
69+
{
70+
int = Psubint;
71+
bool = None;
72+
float = Some Psubfloat;
73+
bigint = Some Psubbigint;
74+
string = None;
75+
};
76+
};
77+
|]
4478

45-
let translate_primitive_application (env : Env.t) (prim : Primitive.description)
46-
(args : args) : Lambda.primitive option =
47-
None
79+
let index_by_path =
80+
entries |> Array.map (fun entry -> (entry.path, entry)) |> create_hashtable
81+
82+
let index_by_name =
83+
entries |> Array.map (fun entry -> (entry.name, entry)) |> create_hashtable
84+
85+
(*
86+
Actual implementations of translation are colocated into core modules
87+
88+
You can find it in:
89+
- Type-level : ml/typecore.ml
90+
- IR-level : ml/translcore.ml
91+
92+
With function name "translate_unified_application"
93+
*)

‎compiler/ml/unified_ops.mli

+20
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
type form = Unary | Binary
2+
3+
type specialization = {
4+
int: Lambda.primitive;
5+
bool: Lambda.primitive option;
6+
float: Lambda.primitive option;
7+
bigint: Lambda.primitive option;
8+
string: Lambda.primitive option;
9+
}
10+
11+
type entry = {
12+
path: string;
13+
name: string;
14+
form: form;
15+
specialization: specialization;
16+
}
17+
18+
val index_by_path : (string, entry) Hashtbl.t
19+
20+
val index_by_name : (string, entry) Hashtbl.t

‎tests/tests/src/generic_infix_test.js ‎tests/tests/src/generic_infix_test.mjs

+10-9
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
11
// Generated by ReScript, PLEASE EDIT WITH CARE
2-
'use strict';
32

43

54
let float = 1 + 2;
@@ -26,12 +25,14 @@ function addstring(a, b) {
2625

2726
let int = 3;
2827

29-
exports.int = int;
30-
exports.float = float;
31-
exports.string = string;
32-
exports.bigint = bigint;
33-
exports.addint = addint;
34-
exports.addfloat = addfloat;
35-
exports.addbigint = addbigint;
36-
exports.addstring = addstring;
28+
export {
29+
int,
30+
float,
31+
string,
32+
bigint,
33+
addint,
34+
addfloat,
35+
addbigint,
36+
addstring,
37+
}
3738
/* No side effect */

0 commit comments

Comments
 (0)