Right-to-left evaluation of arguments of String.get and friends

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

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,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 ->

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

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