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

Raise if either argument to poly compare is a mixed block #2504

Closed
wants to merge 5 commits into from
Closed

Raise if either argument to poly compare is a mixed block #2504

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
2aa169e
Change poly compare implementation
ncik-roberts Apr 26, 2024
273c6c9
Refactor implementation a tiny bit
ncik-roberts Apr 26, 2024
0cd1882
fix typo in runtime 5
ncik-roberts Apr 29, 2024
8e2f0fb
Fix still another typo
ncik-roberts Apr 29, 2024
fc57863
Merge remote-tracking branch 'origin/main' into nroberts/mixed-block-…
ncik-roberts Apr 30, 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
21 changes: 16 additions & 5 deletions ocaml/runtime/compare.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -120,6 +120,19 @@ static void run_pending_actions(struct compare_stack* stk,

/* Structural comparison */

/* Like abstract blocks, mixed blocks don't support polymorphic compare.
Unlike abstract blocks, it's fairly common for some values of a type
to be mixed and others to not be mixed, so we take special care to
raise if either argument is mixed.
*/
Caml_inline void check_pointer_not_mixed_block(
value val, struct compare_stack* stk) {
CAMLassert(!Is_long(val));
if (Is_mixed_block_reserved(Reserved_val(val))) {
compare_free_stack(stk);
caml_invalid_argument("compare: mixed block value");
}
}

#define LESS -1
#define EQUAL 0
Expand Down Expand Up @@ -149,6 +162,7 @@ static intnat do_compare_val(struct compare_stack* stk,
if (Is_long(v2))
return Long_val(v1) - Long_val(v2);
/* Subtraction above cannot overflow and cannot result in UNORDERED */
check_pointer_not_mixed_block(v2, stk);
switch (Tag_val(v2)) {
case Forward_tag:
v2 = Forward_val(v2);
Expand All @@ -169,6 +183,7 @@ static intnat do_compare_val(struct compare_stack* stk,

return LESS; /* v1 long < v2 block */
}
check_pointer_not_mixed_block(v1, stk);
if (Is_long(v2)) {
switch (Tag_val(v1)) {
case Forward_tag:
Expand All @@ -189,6 +204,7 @@ static intnat do_compare_val(struct compare_stack* stk,
}
return GREATER; /* v1 block > v2 long */
}
check_pointer_not_mixed_block(v2, stk);
t1 = Tag_val(v1);
t2 = Tag_val(v2);
if (t1 != t2) {
Expand All @@ -207,11 +223,6 @@ static intnat do_compare_val(struct compare_stack* stk,
if (t1 != t2)
return (intnat)t1 - (intnat)t2;
}
if ( Is_mixed_block_reserved(Reserved_val(v1))
|| Is_mixed_block_reserved(Reserved_val(v2))) {
compare_free_stack(stk);
caml_invalid_argument("compare: mixed block value");
}
switch(t1) {
case Forward_tag: {
v1 = Forward_val (v1);
Expand Down
23 changes: 18 additions & 5 deletions ocaml/runtime4/compare.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -101,6 +101,20 @@ static intnat compare_val(value v1, value v2, int total)

/* Structural comparison */

/* Like abstract blocks, mixed blocks don't support polymorphic compare.
Unlike abstract blocks, it's fairly common for some values of a type
to be mixed and others to not be mixed, so we take special care to
raise if either argument is mixed.
*/
Caml_inline void check_pointer_in_value_area_not_mixed_block(
value val, struct compare_stack* stk) {
CAMLassert(!Is_long(val));
CAMLassert(Is_in_value_area(val));
if (Is_mixed_block_reserved(Reserved_val(val))) {
compare_free_stack(stk);
caml_invalid_argument("compare: mixed block value");
}
}

#define LESS -1
#define EQUAL 0
Expand Down Expand Up @@ -129,6 +143,7 @@ static intnat do_compare_val(struct compare_stack* stk,
/* Subtraction above cannot overflow and cannot result in UNORDERED */
if (!Is_in_value_area(v2))
return LESS;
check_pointer_in_value_area_not_mixed_block(v2, stk);
switch (Tag_val(v2)) {
case Forward_tag:
v2 = Forward_val(v2);
Expand All @@ -150,6 +165,7 @@ static intnat do_compare_val(struct compare_stack* stk,
if (Is_long(v2)) {
if (!Is_in_value_area(v1))
return GREATER;
check_pointer_in_value_area_not_mixed_block(v1, stk);
switch (Tag_val(v1)) {
case Forward_tag:
v1 = Forward_val(v1);
Expand All @@ -176,6 +192,8 @@ static intnat do_compare_val(struct compare_stack* stk,
return (v1 >> 1) - (v2 >> 1);
/* Subtraction above cannot result in UNORDERED */
}
check_pointer_in_value_area_not_mixed_block(v1, stk);
check_pointer_in_value_area_not_mixed_block(v2, stk);
t1 = Tag_val(v1);
t2 = Tag_val(v2);
if (t1 != t2) {
Expand All @@ -194,11 +212,6 @@ static intnat do_compare_val(struct compare_stack* stk,
if (t1 != t2)
return (intnat)t1 - (intnat)t2;
}
if ( Is_mixed_block_reserved(Reserved_val(v1))
|| Is_mixed_block_reserved(Reserved_val(v2))) {
compare_free_stack(stk);
caml_invalid_argument("compare: mixed block value");
}
switch(t1) {
case Forward_tag: {
v1 = Forward_val (v1);
Expand Down
101 changes: 101 additions & 0 deletions ocaml/testsuite/tests/mixed-blocks/compare.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,101 @@
(* TEST
flags = "-extension layouts_alpha";
flambda2;
{
native;
}{
bytecode;
}
*)

(* Polymorphic comparison raises if either argument is a mixed block.

The one exception is [compare x x], wich always returns [0].
(Note that [x = x] still raises for mixed blocks!) This discrepancy
between [compare] and [equal] is consistent with e.g. functional values.
*)

type forget = T : _ -> forget

let compare (x : forget) (y : forget) =
match compare (T x) (T y) with
| exception exn -> Printf.sprintf "raised %s" (Printexc.to_string exn)
| i -> string_of_int i

let equal (x : forget) (y : forget) =
match T x = T y with
| exception exn -> Printf.sprintf "raised %s" (Printexc.to_string exn)
| b -> string_of_bool b

type normal =
{ x : int;
y : int;
}

type all_float =
{ x : float;
y : float#;
}

type mixed1 =
{ x : string;
y : float#;
z : int;
}

type mixed2 =
{ x : float#;
y : int;
}

let mixed =
[ "all_float", T ({ x = 4.0; y = #5.0 } : all_float);
"mixed1", T ({ x = "str"; y = #5.0; z = 3 } : mixed1);
"mixed2", T ({ x = #3.0; y = 3 } : mixed2);
]

let normal =
[ "normal", T ({ x = 4; y = 5 } : normal);
"int", T 3;
"string", T "string";
"floatarray", T [| 5.0 |];
"empty", T [||];
"closure", T (let y = #5.0 in fun x -> x +. Stdlib__Float_u.to_float y);
]

let () = Printf.printf "NORMAL VS. MIXED\n\n"

let run_compare (label1, x1) (label2, x2) =
Printf.printf "compare %-10s %-11s= %s\n"
label1 label2 (compare x1 x2)

let run_equal (label1, x1) (label2, x2) =
Printf.printf "%-10s = %-11s= %s\n"
label1 label2 (equal x1 x2)

open StdLabels

let () =
List.iter mixed ~f:(fun mixed ->
List.iter normal ~f:(fun normal ->
run_compare mixed normal);
List.iter normal ~f:(fun normal ->
run_compare normal mixed));
List.iter mixed ~f:(fun mixed ->
List.iter normal ~f:(fun normal ->
run_equal mixed normal);
List.iter normal ~f:(fun normal ->
run_equal normal mixed));
print_newline ()
;;

let () = Printf.printf "MIXED VS. MIXED\n\n"

let () =
List.iter mixed ~f:(fun mixed1 ->
List.iter mixed ~f:(fun mixed2 ->
run_compare mixed1 mixed2));
List.iter mixed ~f:(fun mixed1 ->
List.iter mixed ~f:(fun mixed2 ->
run_equal mixed1 mixed2));
;;
95 changes: 95 additions & 0 deletions ocaml/testsuite/tests/mixed-blocks/compare.reference
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,95 @@
NORMAL VS. MIXED

compare all_float normal = raised Invalid_argument("compare: mixed block value")
compare all_float int = raised Invalid_argument("compare: mixed block value")
compare all_float string = raised Invalid_argument("compare: mixed block value")
compare all_float floatarray = raised Invalid_argument("compare: mixed block value")
compare all_float empty = raised Invalid_argument("compare: mixed block value")
compare all_float closure = raised Invalid_argument("compare: mixed block value")
compare normal all_float = raised Invalid_argument("compare: mixed block value")
compare int all_float = raised Invalid_argument("compare: mixed block value")
compare string all_float = raised Invalid_argument("compare: mixed block value")
compare floatarray all_float = raised Invalid_argument("compare: mixed block value")
compare empty all_float = raised Invalid_argument("compare: mixed block value")
compare closure all_float = raised Invalid_argument("compare: mixed block value")
compare mixed1 normal = raised Invalid_argument("compare: mixed block value")
compare mixed1 int = raised Invalid_argument("compare: mixed block value")
compare mixed1 string = raised Invalid_argument("compare: mixed block value")
compare mixed1 floatarray = raised Invalid_argument("compare: mixed block value")
compare mixed1 empty = raised Invalid_argument("compare: mixed block value")
compare mixed1 closure = raised Invalid_argument("compare: mixed block value")
compare normal mixed1 = raised Invalid_argument("compare: mixed block value")
compare int mixed1 = raised Invalid_argument("compare: mixed block value")
compare string mixed1 = raised Invalid_argument("compare: mixed block value")
compare floatarray mixed1 = raised Invalid_argument("compare: mixed block value")
compare empty mixed1 = raised Invalid_argument("compare: mixed block value")
compare closure mixed1 = raised Invalid_argument("compare: mixed block value")
compare mixed2 normal = raised Invalid_argument("compare: mixed block value")
compare mixed2 int = raised Invalid_argument("compare: mixed block value")
compare mixed2 string = raised Invalid_argument("compare: mixed block value")
compare mixed2 floatarray = raised Invalid_argument("compare: mixed block value")
compare mixed2 empty = raised Invalid_argument("compare: mixed block value")
compare mixed2 closure = raised Invalid_argument("compare: mixed block value")
compare normal mixed2 = raised Invalid_argument("compare: mixed block value")
compare int mixed2 = raised Invalid_argument("compare: mixed block value")
compare string mixed2 = raised Invalid_argument("compare: mixed block value")
compare floatarray mixed2 = raised Invalid_argument("compare: mixed block value")
compare empty mixed2 = raised Invalid_argument("compare: mixed block value")
compare closure mixed2 = raised Invalid_argument("compare: mixed block value")
all_float = normal = raised Invalid_argument("compare: mixed block value")
all_float = int = raised Invalid_argument("compare: mixed block value")
all_float = string = raised Invalid_argument("compare: mixed block value")
all_float = floatarray = raised Invalid_argument("compare: mixed block value")
all_float = empty = raised Invalid_argument("compare: mixed block value")
all_float = closure = raised Invalid_argument("compare: mixed block value")
normal = all_float = raised Invalid_argument("compare: mixed block value")
int = all_float = raised Invalid_argument("compare: mixed block value")
string = all_float = raised Invalid_argument("compare: mixed block value")
floatarray = all_float = raised Invalid_argument("compare: mixed block value")
empty = all_float = raised Invalid_argument("compare: mixed block value")
closure = all_float = raised Invalid_argument("compare: mixed block value")
mixed1 = normal = raised Invalid_argument("compare: mixed block value")
mixed1 = int = raised Invalid_argument("compare: mixed block value")
mixed1 = string = raised Invalid_argument("compare: mixed block value")
mixed1 = floatarray = raised Invalid_argument("compare: mixed block value")
mixed1 = empty = raised Invalid_argument("compare: mixed block value")
mixed1 = closure = raised Invalid_argument("compare: mixed block value")
normal = mixed1 = raised Invalid_argument("compare: mixed block value")
int = mixed1 = raised Invalid_argument("compare: mixed block value")
string = mixed1 = raised Invalid_argument("compare: mixed block value")
floatarray = mixed1 = raised Invalid_argument("compare: mixed block value")
empty = mixed1 = raised Invalid_argument("compare: mixed block value")
closure = mixed1 = raised Invalid_argument("compare: mixed block value")
mixed2 = normal = raised Invalid_argument("compare: mixed block value")
mixed2 = int = raised Invalid_argument("compare: mixed block value")
mixed2 = string = raised Invalid_argument("compare: mixed block value")
mixed2 = floatarray = raised Invalid_argument("compare: mixed block value")
mixed2 = empty = raised Invalid_argument("compare: mixed block value")
mixed2 = closure = raised Invalid_argument("compare: mixed block value")
normal = mixed2 = raised Invalid_argument("compare: mixed block value")
int = mixed2 = raised Invalid_argument("compare: mixed block value")
string = mixed2 = raised Invalid_argument("compare: mixed block value")
floatarray = mixed2 = raised Invalid_argument("compare: mixed block value")
empty = mixed2 = raised Invalid_argument("compare: mixed block value")
closure = mixed2 = raised Invalid_argument("compare: mixed block value")

MIXED VS. MIXED

compare all_float all_float = 0
compare all_float mixed1 = raised Invalid_argument("compare: mixed block value")
compare all_float mixed2 = raised Invalid_argument("compare: mixed block value")
compare mixed1 all_float = raised Invalid_argument("compare: mixed block value")
compare mixed1 mixed1 = 0
compare mixed1 mixed2 = raised Invalid_argument("compare: mixed block value")
compare mixed2 all_float = raised Invalid_argument("compare: mixed block value")
compare mixed2 mixed1 = raised Invalid_argument("compare: mixed block value")
compare mixed2 mixed2 = 0
all_float = all_float = raised Invalid_argument("compare: mixed block value")
all_float = mixed1 = raised Invalid_argument("compare: mixed block value")
all_float = mixed2 = raised Invalid_argument("compare: mixed block value")
mixed1 = all_float = raised Invalid_argument("compare: mixed block value")
mixed1 = mixed1 = raised Invalid_argument("compare: mixed block value")
mixed1 = mixed2 = raised Invalid_argument("compare: mixed block value")
mixed2 = all_float = raised Invalid_argument("compare: mixed block value")
mixed2 = mixed1 = raised Invalid_argument("compare: mixed block value")
mixed2 = mixed2 = raised Invalid_argument("compare: mixed block value")
Loading