Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Unified operators #7057

Merged
merged 16 commits into from
Nov 6, 2024
Merged

Unified operators #7057

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
16 commits
Select commit Hold shift + click to select a range
7205088
PoC: generic infix operators
cometkim Sep 28, 2024
0005e2f
try less diff
cometkim Oct 11, 2024
4bc812d
wip: unified ops
cometkim Oct 24, 2024
7551045
rewrite type translation
cometkim Nov 4, 2024
64d4e15
revert changes on comparison
cometkim Nov 4, 2024
19e01b7
done implement unified_ops translation
cometkim Nov 4, 2024
2c05e5a
migrate other arithmetic operators
cometkim Nov 4, 2024
6607973
rename test and more cases
cometkim Nov 4, 2024
cd7aa38
link comments
cometkim Nov 5, 2024
bcccd76
remove unused clause
cometkim Nov 5, 2024
68fa0dc
rename primitive
cometkim Nov 5, 2024
adc65bf
sync Pervasives_mini
cometkim Nov 5, 2024
efa0058
keep arg labels
cometkim Nov 5, 2024
15595d2
format
cometkim Nov 5, 2024
1791379
note on pervasives_mini
cometkim Nov 6, 2024
1ef4469
add changelog
cometkim Nov 6, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 4 additions & 0 deletions CHANGELOG.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
110 changes: 79 additions & 31 deletions compiler/ml/translcore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,33 @@ 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 *)
let entry = Hashtbl.find_opt Unified_ops.index_by_name prim.prim_name in
match entry with
| Some {specialization} -> (
match specialization with
| {int}
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I was wondering if the when clause in this case is complete. But I guess this case is just unnecessary and can be removes as it is already expressed as the last default case?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This always takes precedence int over other types. (Rule 1-2) The last default case is a fallback strategy. (Rule 3)

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Can you give an example of any change after removing this first case?
All the other cases seem to have incompatible when clauses, so it would fall back to the last case no matter what.
Unless I'm missing something.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

You are right. There is no logical difference in the behavior after removing that case. I was just thinking of the computational difference. In the existing codebase, I assume the first case is hit the most frequently (since it was originally int-only).

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's just a detail anyway. Not much difference. Whatever you think is best.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, it probably doesn't matter, but I'll leave it as is because it seems easier to understand the intent.

when is_base_type env lhs_type Predef.path_int
|| 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;
intcomp: Lambda.primitive;
Expand Down Expand Up @@ -394,12 +421,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 *)

Expand Down Expand Up @@ -458,32 +494,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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

why also [arg1] with only 1 argument?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

There is a couple of unary primitive to support, %pos and %neg

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes I noticed all the other functions don't have unaries, so if they're planned for this PR great.

This comment was marked as resolved.

Sign in to view

| _ -> 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 *)

Expand Down
99 changes: 98 additions & 1 deletion compiler/ml/typecore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 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
end_def ();
unify_var env (newvar ()) funct.exp_type;
Expand Down Expand Up @@ -3561,6 +3563,101 @@ 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
| 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)] ->
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 = [(lhs_label, Some lhs)] in
Some (targs, result_type)
| ( 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
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. 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
(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. 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
(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. 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 = [(lhs_label, Some lhs); (rhs_label, Some rhs)] in
Some (targs, result_type)
| _ -> None)
| _ -> None
and type_application ?type_clash_context uncurried env funct (sargs : sargs) :
targs * Types.type_expr * bool =
(* funct.exp_type may be generic *)
Expand Down
Loading