flambda-backend: Right-to-left evaluation of arguments of String.get and friends (#354)

* Fix argument evaluation order in the following functions in Cmm_helpers:

mk_compare_ints
mk_compare_floats
safe_divmod_bi
stringref_safe
string_load
bigstring_load
arrayref_unsafe
bytesset_safe
bytes_set
bigstring_set

* Apply the fix to asmcomp

* Add tests for all the above

* Add tests for bigarray_get/set and send that are not yet fixed

Author: gretay-js

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,26 +2277,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
@@ -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 ->

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;
+
+  ()

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

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

testsuite/tests/asmcomp/evaluation_order_broken.reference

@@ -0,0 +1,10 @@
+B
+A
+1.
+C
+B
+A
+?
+B
+A
+m