Merge pull request #9463 from lthls/fix_int64_cmm_typ

Fix Cmm type of unboxed integers in Clet_mut

Changes

@@ -66,9 +66,10 @@ Working version
 - #9280: Micro-optimise allocations on amd64 to save a register.
   (Stephen Dolan, review by Xavier Leroy)
 
-- #9316, #9443: Use typing information from Clambda for mutable Cmm variables.
+- #9316, #9443, #9463: Use typing information from Clambda
+  for mutable Cmm variables.
   (Stephen Dolan, review by Vincent Laviron, Guillaume Bury, Xavier Leroy,
-  and Gabriel Scherer)
+  and Gabriel Scherer; temporary bug report by Richard Jones)
 
 - #9426: build the Mingw ports with higher levels of GCC optimization
   (Xavier Leroy, review by Sébastien Hinderer)

asmcomp/cmmgen.ml

@@ -247,6 +247,11 @@ let box_int dbg bi arg =
 
 (* Boxed numbers *)
 
+let typ_of_boxed_number = function
+  | Boxed_float _ -> Cmm.typ_float
+  | Boxed_integer (Pint64, _) when size_int = 4 -> [|Int;Int|]
+  | Boxed_integer _ -> Cmm.typ_int
+
 let equal_unboxed_integer ui1 ui2 =
   match ui1, ui2 with
   | Pnativeint, Pnativeint -> true
@@ -687,11 +692,6 @@ and transl_catch env nfail ids body handler dbg =
   in
   let env_body = add_notify_catch nfail report env in
   let body = transl env_body body in
-  let typ_of_bn = function
-    | Boxed_float _ -> Cmm.typ_float
-    | Boxed_integer (Pint64, _) when size_int = 4 -> [|Int;Int|]
-    | Boxed_integer _ -> Cmm.typ_int
-  in
   let new_env, rewrite, ids =
     List.fold_right
       (fun (id, _kind, u) (env, rewrite, ids) ->
@@ -704,7 +704,7 @@ and transl_catch env nfail ids body handler dbg =
              let unboxed_id = V.create_local (VP.name id) in
              add_unboxed_id (VP.var id) unboxed_id bn env,
              (unbox_number Debuginfo.none bn) :: rewrite,
-             (VP.create unboxed_id, typ_of_bn bn) :: ids
+             (VP.create unboxed_id, typ_of_boxed_number bn) :: ids
       )
       ids (env, [], [])
   in
@@ -1165,8 +1165,7 @@ and transl_let env str kind id exp body =
         transl (add_unboxed_id (VP.var id) unboxed_id boxed_number env) body in
       begin match str, boxed_number with
       | Immutable, _ -> Clet (v, cexp, body)
-      | Mutable, Boxed_float _ -> Clet_mut (v, typ_float, cexp, body)
-      | Mutable, Boxed_integer _ -> Clet_mut (v, typ_int, cexp, body)
+      | Mutable, bn -> Clet_mut (v, typ_of_boxed_number bn, cexp, body)
       end
 
 and make_catch ncatch body handler dbg = match body with

testsuite/tests/lib-int64/issue9460.ml

@@ -0,0 +1,37 @@
+(* TEST
+*)
+
+(* See https://github.com/ocaml/ocaml/issues/9460
+   This test comes from Richard Jones
+   at
+     https://github.com/libguestfs/libnbd/blob/0475bfe04a527051c0a37af59a733c4c8554e427/ocaml/tests/test_400_pread.ml#L21-L36
+*)
+let test_result =
+  let b = Bytes.create 16 in
+  for i = 0 to 16/8-1 do
+    let i64 = ref (Int64.of_int (i*8)) in
+    for j = 0 to 7 do
+      let c = Int64.shift_right_logical !i64 56 in
+      let c = Int64.to_int c in
+      let c = Char.chr c in
+      Bytes.unsafe_set b (i*8+j) c;
+      i64 := Int64.shift_left !i64 8
+    done
+  done;
+  (Bytes.to_string b) ;;
+
+let expected =
+  "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\008"
+
+let () =
+  assert (test_result = expected)
+
+(* Reproduction case by Jeremy Yallop in
+   https://github.com/ocaml/ocaml/pull/9463#issuecomment-615831765
+*)
+let () =
+  let x = ref Int64.max_int in
+  assert (!x = Int64.max_int)
+
+let () =
+  print_endline "OK"

testsuite/tests/lib-int64/issue9460.reference

@@ -0,0 +1 @@
+OK