diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index ebf889688e6..40aff966608 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -281,8 +281,8 @@ let mk_not dbg cmm = Cop(Csubi, [Cconst_int (4, dbg); c], dbg) let mk_compare_ints_untagged dbg a1 a2 = - 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 sub_int op1 op2 dbg)) @@ -300,8 +300,8 @@ let mk_compare_ints dbg a1 a2 = | a1, a2 -> tag_int (mk_compare_ints_untagged dbg a1 a2) dbg let mk_compare_floats_untagged 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 @@ -319,8 +319,8 @@ let mk_compare_floats_untagged dbg a1 a2 = add_int (sub_int op1 op2 dbg) (sub_int op3 op4 dbg) dbg)) 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 @@ -543,8 +543,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) @@ -2436,8 +2436,8 @@ 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), @@ -2445,17 +2445,17 @@ let stringref_safe arg1 arg2 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 @@ -2466,8 +2466,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, @@ -2554,14 +2554,15 @@ let bytesset_unsafe arg1 arg2 arg3 dbg = let bytesset_safe arg1 arg2 arg3 dbg = return_unit dbg - (bind "str" arg1 (fun str -> + (bind "newval" (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))))) + ignore_high_bit_int newval], + dbg)))))) let arrayset_unsafe kind arg1 arg2 arg3 dbg = return_unit dbg (match (kind: Lambda.array_kind) with @@ -2649,17 +2650,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 -> @@ -2701,9 +2702,9 @@ let bigstring_prefetch ~is_write locality args dbg = let op = Cprefetch { is_write; locality; } in if_operation_supported op ~f:(fun () -> let arg1, arg2 = two_args "bigstring_prefetch" args in - bind "ba" arg1 (fun ba -> - (* [arg2], the index, is already untagged. *) - bind "index" arg2 (fun idx -> + (* [arg2], the index, is already untagged. *) + bind "index" arg2 (fun idx -> + bind "ba" arg1 (fun ba -> bind "ba_data" (Cop(Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) (fun ba_data -> diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index dcc9587dd89..b0b4ac6bae4 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/ocaml/asmcomp/cmm_helpers.ml @@ -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 @@ -522,8 +522,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) @@ -2277,8 +2277,8 @@ 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), @@ -2286,17 +2286,17 @@ let stringref_safe arg1 arg2 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 @@ -2307,8 +2307,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, @@ -2395,14 +2395,15 @@ let bytesset_unsafe arg1 arg2 arg3 dbg = let bytesset_safe arg1 arg2 arg3 dbg = return_unit dbg - (bind "str" arg1 (fun str -> + (bind "newval" (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))))) + ignore_high_bit_int newval], + dbg)))))) let arrayset_unsafe kind arg1 arg2 arg3 dbg = return_unit dbg (match (kind: Lambda.array_kind) with @@ -2490,17 +2491,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 -> diff --git a/ocaml/testsuite/tests/asmcomp/evaluation_order.ml b/ocaml/testsuite/tests/asmcomp/evaluation_order.ml new file mode 100644 index 00000000000..2fb7f917ff9 --- /dev/null +++ b/ocaml/testsuite/tests/asmcomp/evaluation_order.ml @@ -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; + + () diff --git a/ocaml/testsuite/tests/asmcomp/evaluation_order.reference b/ocaml/testsuite/tests/asmcomp/evaluation_order.reference new file mode 100644 index 00000000000..26082b114e5 --- /dev/null +++ b/ocaml/testsuite/tests/asmcomp/evaluation_order.reference @@ -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 diff --git a/ocaml/testsuite/tests/asmcomp/evaluation_order_broken.ml b/ocaml/testsuite/tests/asmcomp/evaluation_order_broken.ml new file mode 100644 index 00000000000..5543fb0edb9 --- /dev/null +++ b/ocaml/testsuite/tests/asmcomp/evaluation_order_broken.ml @@ -0,0 +1,33 @@ +(* TEST + * bytecode +*) + +(* The following examples have different output on bytecode and native. + The order of evaluation of arguments in cmm_helpers needs to be fixed. *) +open Bigarray +let () = +(* CR gyorsh: fix bigarray_get *) + let[@inline never] test_bigarray_get + (a : (Complex.t, complex32_elt, c_layout) Array1.t) + (i : int) = + print_float (Array1.unsafe_get (print_endline "A"; a) + (print_endline "B"; i)).Complex.re; + print_newline () + in + test_bigarray_get (Array1.init complex32 c_layout 3 (fun _ -> Complex.one)) 0; + + (* CR gyorsh: fix bigarray_set *) + let[@inline never] test_bigarray_set + (a : (Complex.t, complex32_elt, c_layout) Array1.t) + (i : int) = + Array1.unsafe_set (print_endline "A"; a) (print_endline "B"; i) + (print_endline "C"; Complex.i); + print_endline "?" + in + test_bigarray_set (Array1.create complex32 c_layout 3) 0; + + (* CR gyorsh: fix send *) + let[@inline never] test_send o x = + (print_endline "A"; o)#m (print_endline "B"; x) + in + test_send (object method m (_ : int) = print_endline "m" end) 1 diff --git a/ocaml/testsuite/tests/asmcomp/evaluation_order_broken.reference b/ocaml/testsuite/tests/asmcomp/evaluation_order_broken.reference new file mode 100644 index 00000000000..f67c856a55e --- /dev/null +++ b/ocaml/testsuite/tests/asmcomp/evaluation_order_broken.reference @@ -0,0 +1,10 @@ +B +A +1. +C +B +A +? +B +A +m