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

[gretay-js]

A few string-related primitives handled in cmmgen have they arguments evaluated from left to right.
For example, each of the following lines

String.get (print_endline "hello"; "foo") (print_endline "world"; 0) ;;
Bigstring_unix.get (print_endline "hello"; Bigstring_unix.of_string "foo") (print_endline "world"; 0);;
Bytes.get (print_endline "hello"; Bytes.make 10 '\x00') (print_endline "world"; 0);;

prints

hello
world

instead of

world
hello

This PR fixes it to match with the order of evaluation of bytecode and other functions.

Testing: I cannot come up with a test for the change in arrayref_unsafe. I added a test for other functions affected by this PR.

If this change is approved, I'll apply the same fix to cmm_helpers.ml under ocaml/asmcomp and submit a PR upstream.

[mshinwell]

Ugh, well spotted

[mshinwell]

(For the record this does not affect Flambda 2, which bypasses Cmmgen.)

[xclerc]

I think there are other occurrences of the same problem in
Cmm_helpers. In particular see mk_compare_ints_untagged
or mk_compare_floats_untagged.

For instance:

% cat s.ml
let[@inline never] f (x : int) (y : int) =
  print_int (compare (print_endline "A"; x) (print_endline "B"; y));
  print_newline ()

let () = f 2 3
% ocaml s.ml
B
A
-1

% ocamlopt s.ml && ./a.out
A
B
-1

[mshinwell]

(For the record this does not affect Flambda 2, which bypasses Cmmgen.)

Oh but in fact these functions are in Cmm_helpers. I think Flambda 2 should be ok though.

[xclerc]

After some superficial grepping, I think we should look
at the following funtions (in addition to the ones already
mentioned):

• mk_compare_floats;
• safe_divmod_bi;
• send;
• bytesset_safe;
• bytes_set;
• bigstring_set;
• bigstring_prefetch.

[gretay-js]

@xclerc thank you! let me try to fix them.
bigarray_get/set are fine, right?

[xclerc]

My grepping was too superficial to yield bigarray_{g,s}et,
but the binding order looks suspicious indeed. And slightly
harder to fix.

[xclerc]

Some bigarrays are indeed affected:

% cat t.ml
let[@inline never] f
    (b : (Complex.t, Bigarray.complex32_elt, Bigarray.c_layout) Bigarray.Array1.t)
    (i : int) =
  print_float (Bigarray.Array1.unsafe_get (print_endline "A"; b) (print_endline "B"; i)).Complex.re;
  print_newline ()

let () = f (Bigarray.(Array1.create complex32 c_layout 3 )) 0
% ocaml t.ml && ocamlopt t.ml && ./a.out
B
A
0.

A
B
0.

[xclerc]

Testing: I cannot come up with a test for the change in arrayref_unsafe. I added a test for other functions affected by this PR.

Here is one:

% cat a.ml && ocaml a.ml && ocamlopt a.ml && ./a.out
let[@inline never] f : 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)))

let () = f Sys.argv 0 Fun.id
B
A
a.ml

A
B
./a.out

[gretay-js]

Fixed all the above except send and bigarray_get/set.
@xclerc Thanks for the tests, I've added them to the PR.

[xclerc]

I don't think the tests should be reused as-is: Bigarray's
create functions do not initialize the arrays, so the tests
will be quite flaky.

[gretay-js]

I don't think the tests should be reused as-is: Bigarray's create functions do not initialize the arrays, so the tests will be quite flaky.

I fixed the initialization.

[xclerc]

Indeed, I was misled by the surviving call to create,
but the test does not read from that particular array.

[xclerc]

I think there is still a problem with send:

% cat m.ml && ocaml m.ml && ocamlopt m.ml && ./a.out
let[@inline never] f o x =
  (print_endline "A"; o)#m (print_endline "B"; x)

let () = f (object method m (_ : int) = print_endline "m" end) 1
B
A
m

A
B
m

But maybe it is annoying to fix, like for bigarrays.

[gretay-js]

Yeas, I wasn't sure how to fix send and bigarrays. Let's see what upstream response would be - I think it's ready enough to make a PR upstream.

[xclerc]

Since we have tests to record the issue for bigarrays even
though we delay the fix, I would suggest to do the same for
send. For the sake of consistency/completeness.

[xclerc]

The following patch appears to fix the issue for bigarray_get,
but it is very lightly tested and not particularly elegant. The idea
is to use a variant of bind to simply collect beforehand what
would be bound and create the let bindings later.

(The same could of course by applied to bigarray_set, and
quite probably to send.)

diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml
index b2de73b34..6b07400ca 100644
--- a/backend/cmm_helpers.ml
+++ b/backend/cmm_helpers.ml
@@ -986,23 +986,43 @@ let bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk = function
   | Pbigarray_complex32 -> Single
   | Pbigarray_complex64 -> Double
 
+let bind_info name arg =
+  match arg with
+    Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ -> None, arg
+  | _ -> let id = V.create_local name in (Some (VP.create id, arg)), Cvar id
+
+let bind_info args =
+  List.fold_right (fun hd tl -> bind_info "bi" hd :: tl) args []
+
+let rec wrap_with_bind_info bind_info body =
+  match bind_info with
+  | [] -> body
+  | (None, _) :: tl ->
+    wrap_with_bind_info tl body
+  | (Some (vp, e), _) :: tl ->
+    Clet (vp, e, (wrap_with_bind_info tl body))
+
 let bigarray_get unsafe elt_kind layout b args dbg =
-  bind "ba" b (fun b ->
+  let args = bind_info args in
     match (elt_kind : Lambda.bigarray_kind) with
       Pbigarray_complex32 | Pbigarray_complex64 ->
         let kind = bigarray_word_kind elt_kind in
         let sz = bigarray_elt_size_in_bytes elt_kind / 2 in
+        wrap_with_bind_info args @@
+        bind "ba" b (fun b ->
         bind "addr"
-          (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
+          (bigarray_indexing unsafe elt_kind layout b (List.map snd args) dbg) (fun addr ->
             bind "reval"
               (Cop(Cload (kind, Mutable), [addr], dbg)) (fun reval ->
                 bind "imval"
                   (Cop(Cload (kind, Mutable),
                        [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg)], dbg))
-                  (fun imval -> box_complex dbg reval imval)))
+                  (fun imval -> box_complex dbg reval imval))))
     | _ ->
+        wrap_with_bind_info args @@
+        bind "ba" b (fun b ->
         Cop(Cload (bigarray_word_kind elt_kind, Mutable),
-            [bigarray_indexing unsafe elt_kind layout b args dbg],
+            [bigarray_indexing unsafe elt_kind layout b (List.map snd args) dbg],
             dbg))
 
 let bigarray_set unsafe elt_kind layout b args newval dbg =

[gretay-js]

The following patch appears to fix the issue for bigarray_get, but it is very lightly tested and not particularly elegant. The idea is to use a variant of bind to simply collect beforehand what would be bound and create the let bindings later.

(The same could of course by applied to bigarray_set, and quite probably to send.)

Great! Would you like to make a separate PR with it?

[lthls]

I might be missing something, but wouldn't it be simpler to define a bind_list function and use it to systematically bind everything at the toplevel of these functions ?

For example:

let bind_list name args fn =
  let rec aux bound_args = function
    | [] -> fn bound_args
    | arg :: args ->
      bind name arg (fun bound_arg -> aux (bound_arg :: bound_args) args)
  in
  aux [] (List.rev args)

let bigarray_get unsafe elt_kind layout b args dbg =
  bind_list "idx" args (fun args ->
  bind "ba" b (fun b ->
    match (elt_kind : Lambda.bigarray_kind) with
      Pbigarray_complex32 | Pbigarray_complex64 ->
        let kind = bigarray_word_kind elt_kind in
        let sz = bigarray_elt_size_in_bytes elt_kind / 2 in
        bind "addr"
          (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
            bind "reval"
              (Cop(Cload (kind, Mutable), [addr], dbg)) (fun reval ->
                bind "imval"
                  (Cop(Cload (kind, Mutable),
                       [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg)], dbg))
                  (fun imval -> box_complex dbg reval imval)))
    | _ ->
        Cop(Cload (bigarray_word_kind elt_kind, Mutable),
            [bigarray_indexing unsafe elt_kind layout b args dbg],
            dbg)))

[gretay-js]

I might be missing something, but wouldn't it be simpler to define a bind_list function and use it to systematically bind everything at the toplevel of these functions ?

Yes, it's simpler, and would simplify bigarray_indexing too, I think, as it won't need to handle the order of argument evaluation any more.

[gretay-js]

I'm merging this and will make a separate PR for bigarray_get/set and send, with additional tests.