Skip to content

Commit

Permalink
Ensure right-to-left evaluation of arguments in cmm_helpers (#10732)
Browse files Browse the repository at this point in the history
This fixes evaluation order in the following C-- generation functions:

mk_compare_ints
mk_compare_floats
safe_divmod_bi
stringref_safe
string_load
bigstring_load
arrayref_unsafe
bytesset_safe
bytes_set
bigstring_set

A test file was added.

(cherry picked from commit 35af4cd)
  • Loading branch information
gretay-js authored and xavierleroy committed Dec 20, 2021
1 parent 1894450 commit 0fdbf79
Show file tree
Hide file tree
Showing 4 changed files with 133 additions and 22 deletions.
3 changes: 3 additions & 0 deletions Changes
Original file line number Diff line number Diff line change
Expand Up @@ -68,6 +68,9 @@ OCaml 4.14.0
- #10728: Ensure that functions are evaluated after their arguments
(Stephen Dolan, review by Mark Shinwell)

- #10732: Ensure right-to-left evaluation of arguments in cmm_helpers
(Greta Yorsh, review by Xavier Leroy)

### Standard library:

* #10710: Add UTF tools, codecs and validations to the Uchar, Bytes and
Expand Down
44 changes: 22 additions & 22 deletions asmcomp/cmm_helpers.ml
Original file line number Diff line number Diff line change
Expand Up @@ -291,16 +291,16 @@ let mk_compare_ints dbg a1 a2 =
| Cconst_natint (c1, _), Cconst_int (c2, _) ->
int_const dbg Nativeint.(compare c1 (of_int c2))
| a1, a2 -> begin
bind "int_cmp" a1 (fun a1 ->
bind "int_cmp" a2 (fun a2 ->
bind "int_cmp" a2 (fun a2 ->
bind "int_cmp" a1 (fun a1 ->
let op1 = Cop(Ccmpi(Cgt), [a1; a2], dbg) in
let op2 = Cop(Ccmpi(Clt), [a1; a2], dbg) in
tag_int(sub_int op1 op2 dbg) dbg))
end

let mk_compare_floats dbg a1 a2 =
bind "float_cmp" a1 (fun a1 ->
bind "float_cmp" a2 (fun a2 ->
bind "float_cmp" a2 (fun a2 ->
bind "float_cmp" a1 (fun a1 ->
let op1 = Cop(Ccmpf(CFgt), [a1; a2], dbg) in
let op2 = Cop(Ccmpf(CFlt), [a1; a2], dbg) in
let op3 = Cop(Ccmpf(CFeq), [a1; a1], dbg) in
Expand Down Expand Up @@ -520,8 +520,8 @@ let is_different_from x = function
| _ -> false

let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg =
bind "dividend" c1 (fun c1 ->
bind "divisor" c2 (fun c2 ->
bind "dividend" c1 (fun c1 ->
let c = mkop c1 c2 is_safe dbg in
if Arch.division_crashes_on_overflow
&& (size_int = 4 || bi <> Primitive.Pint32)
Expand Down Expand Up @@ -2284,26 +2284,26 @@ let stringref_unsafe arg1 arg2 dbg =

let stringref_safe arg1 arg2 dbg =
tag_int
(bind "str" arg1 (fun str ->
bind "index" (untag_int arg2 dbg) (fun idx ->
(bind "index" (untag_int arg2 dbg) (fun idx ->
bind "str" arg1 (fun str ->
Csequence(
make_checkbound dbg [string_length str dbg; idx],
Cop(Cload (Byte_unsigned, Mutable),
[add_int str idx dbg], dbg))))) dbg

let string_load size unsafe arg1 arg2 dbg =
box_sized size dbg
(bind "str" arg1 (fun str ->
bind "index" (untag_int arg2 dbg) (fun idx ->
(bind "index" (untag_int arg2 dbg) (fun idx ->
bind "str" arg1 (fun str ->
check_bound unsafe size dbg
(string_length str dbg)
idx (unaligned_load size str idx dbg))))

let bigstring_load size unsafe arg1 arg2 dbg =
box_sized size dbg
(bind "ba" arg1 (fun ba ->
bind "index" (untag_int arg2 dbg) (fun idx ->
bind "ba_data"
(bind "index" (untag_int arg2 dbg) (fun idx ->
bind "ba" arg1 (fun ba ->
bind "ba_data"
(Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
check_bound unsafe size dbg
Expand All @@ -2314,8 +2314,8 @@ let bigstring_load size unsafe arg1 arg2 dbg =
let arrayref_unsafe kind arg1 arg2 dbg =
match (kind : Lambda.array_kind) with
| Pgenarray ->
bind "arr" arg1 (fun arr ->
bind "index" arg2 (fun idx ->
bind "index" arg2 (fun idx ->
bind "arr" arg1 (fun arr ->
Cifthenelse(is_addr_array_ptr arr dbg,
dbg,
addr_array_ref arr idx dbg,
Expand Down Expand Up @@ -2402,14 +2402,14 @@ let bytesset_unsafe arg1 arg2 arg3 dbg =

let bytesset_safe arg1 arg2 arg3 dbg =
return_unit dbg
(bind "str" arg1 (fun str ->
(bind "newval" (ignore_high_bit_int (untag_int arg3 dbg)) (fun newval ->
bind "index" (untag_int arg2 dbg) (fun idx ->
bind "str" arg1 (fun str ->
Csequence(
make_checkbound dbg [string_length str dbg; idx],
Cop(Cstore (Byte_unsigned, Assignment),
[add_int str idx dbg;
ignore_high_bit_int (untag_int arg3 dbg)],
dbg)))))
[add_int str idx dbg; newval],
dbg))))))

let arrayset_unsafe kind arg1 arg2 arg3 dbg =
return_unit dbg (match (kind: Lambda.array_kind) with
Expand Down Expand Up @@ -2497,17 +2497,17 @@ let arrayset_safe kind arg1 arg2 arg3 dbg =

let bytes_set size unsafe arg1 arg2 arg3 dbg =
return_unit dbg
(bind "str" arg1 (fun str ->
(bind "newval" arg3 (fun newval ->
bind "index" (untag_int arg2 dbg) (fun idx ->
bind "newval" arg3 (fun newval ->
bind "str" arg1 (fun str ->
check_bound unsafe size dbg (string_length str dbg)
idx (unaligned_set size str idx newval dbg)))))

let bigstring_set size unsafe arg1 arg2 arg3 dbg =
return_unit dbg
(bind "ba" arg1 (fun ba ->
(bind "newval" arg3 (fun newval ->
bind "index" (untag_int arg2 dbg) (fun idx ->
bind "newval" arg3 (fun newval ->
bind "ba" arg1 (fun ba ->
bind "ba_data"
(Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg))
(fun ba_data ->
Expand Down
78 changes: 78 additions & 0 deletions testsuite/tests/asmcomp/evaluation_order.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,78 @@
(* TEST
*)
external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
external caml_bytes_get_16 : bytes -> int -> int = "%caml_bytes_get16"
external caml_bytes_set_16 : bytes -> int -> int -> unit = "%caml_bytes_set16"

open Bigarray
type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t

external caml_bigstring_get_16 :
bigstring -> int -> int = "%caml_bigstring_get16"

external caml_bigstring_set_16 :
bigstring -> int -> int -> unit = "%caml_bigstring_set16"

let bigstring_of_string s =
let a = Array1.create char c_layout (String.length s) in
for i = 0 to String.length s - 1 do
a.{i} <- s.[i]
done;
a

let () =
(* stringref_safe *)
String.get (print_endline "hello"; "foo") (print_endline "world"; 0)
|> Printf.printf "%c\n";

(* string_load *)
caml_bytes_get_16 (print_endline "hello"; Bytes.make 10 '\x00')
(print_endline "world"; 0)
|> Printf.printf "%x\n";

(* bigstring_load *)
caml_bigstring_get_16 (print_endline "hello";
bigstring_of_string (String.make 10 '\x00'))
(print_endline "world"; 0)
|> Printf.printf "%x\n";

(* bytes_set *)
caml_bytes_set_16 (print_endline "a"; Bytes.make 10 '\x00')
(print_endline "b"; 0)
(print_endline "c"; 0xFF);

(* bigstring_set *)
caml_bigstring_set_16 (print_endline "a";
bigstring_of_string (String.make 10 '\x00'))
(print_endline "b"; 0)
(print_endline "c"; 0xFF);

(* mk_compare_ints_untagged *)
print_int (compare (print_endline "A"; Sys.opaque_identity (2))
(print_endline "B"; Sys.opaque_identity (3)));
print_newline ();

(* mk_compare_floats *)
print_int (compare (print_endline "A"; Sys.opaque_identity (2.0))
(print_endline "B"; Sys.opaque_identity (3.5)));
print_newline ();

(* bytesset_safe *)
Bytes.set (print_endline "a"; Bytes.make 10 '\x00')
(print_endline "b"; 0)
(print_endline "c"; 'c');

(* safe_div_bi *)
Printf.printf "%nd\n"
(Nativeint.div (print_endline "A"; Sys.opaque_identity (6n))
(print_endline "B"; Sys.opaque_identity (3n)));

(* arrayref_unsafe *)
let[@inline never] test_arrayref_unsafe
: type t . t array -> int -> (t -> string) -> unit =
fun a i c ->
print_endline (c (Array.unsafe_get (print_endline "A"; a) (print_endline "B"; i)))
in
test_arrayref_unsafe [| "1";"2";"3" |] 0 Fun.id;

()
30 changes: 30 additions & 0 deletions testsuite/tests/asmcomp/evaluation_order.reference
Original file line number Diff line number Diff line change
@@ -0,0 +1,30 @@
world
hello
f
world
hello
0
world
hello
0
c
b
a
c
b
a
B
A
-1
B
A
-1
c
b
a
B
A
2
B
A
1

0 comments on commit 0fdbf79

Please sign in to comment.