flambda-backend: Hash of mixed blocks raises an exception (#2429)

ncik-roberts · xclerc · web-flow · commit 135b96f3d1f6 · 2024-04-23T15:46:45.000-04:00
* caml_hash -&gt; caml_hash_exn

* Make hash raise

* fix

* make fmt

* Update ocaml/stdlib/char.ml

Co-authored-by: Xavier Clerc &lt;xclerc@users.noreply.github.com&gt;

* make bootstrap

---------

Co-authored-by: Xavier Clerc &lt;xclerc@users.noreply.github.com&gt;
diff --git a/boot/ocamlc b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
diff --git a/runtime/hash.c b/runtime/hash.c
@@ -24,6 +24,7 @@
 #include "caml/custom.h"
 #include "caml/memory.h"
 #include "caml/hash.h"
+#include "caml/fail.h"
 
 /* The implementation based on MurmurHash 3,
    https://github.com/aappleby/smhasher/ */
@@ -181,7 +182,14 @@ CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s)
 
 /* The generic hash function */
 
-CAMLprim value caml_hash(value count, value limit, value seed, value obj)
+/* Internally to Jane Street, we have renamed [caml_hash] to [caml_hash_exn]
+   to suggest that calling it could raise. (E.g. it raises on mixed blocks.)
+   As such, we've removed [@@noalloc] from the OCaml [external] that references
+   this C binding, and would likewise need to remove [@@noalloc] from any
+   other [external] formerly bound to [caml_hash].
+*/
+
+CAMLprim value caml_hash_exn(value count, value limit, value seed, value obj)
 {
   value queue[HASH_QUEUE_SIZE]; /* Queue of values to examine */
   intnat rd;                    /* Position of first value in queue */
@@ -279,20 +287,16 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
         break;
 
       default:
+	if (Is_mixed_block_reserved(Reserved_val(v))) {
+	  caml_invalid_argument("hash: mixed block value");
+	}
         /* Mix in the tag and size, but do not count this towards [num] */
         h = caml_hash_mix_uint32(h, Cleanhd_hd(Hd_val(v)));
         /* Copy fields into queue, not exceeding the total size [sz] */
-        for (i = 0, len = Scannable_wosize_val(v); i < len; i++) {
+        for (i = 0, len = Wosize_val(v); i < len; i++) {
           if (wr >= sz) break;
           queue[wr++] = Field(v, i);
         }
-
-	/* We don't attempt to hash the flat suffix of a mixed block.
-	   This is consistent with abstract blocks which, like mixed
-	   blocks, cause polymorphic comparison to raise and don't
-	   attempt to hash the non-scannable portion.
-	 */
-
         break;
       }
     }
diff --git a/runtime4/gc_ctrl.c b/runtime4/gc_ctrl.c
@@ -409,7 +409,7 @@ static intnat norm_minsize (intnat s)
   if (s > Minor_heap_max) s = Minor_heap_max;
   /* PR#9128 : Make sure the minor heap occupies an integral number of
      pages, so that no page contains both bytecode and OCaml
-     values. This would confuse, e.g., caml_hash. */
+     values. This would confuse, e.g., caml_hash_exn. */
   s = (s + page_wsize - 1) / page_wsize * page_wsize;
   return s;
 }
diff --git a/runtime4/hash.c b/runtime4/hash.c
@@ -24,6 +24,7 @@
 #include "caml/custom.h"
 #include "caml/memory.h"
 #include "caml/hash.h"
+#include "caml/fail.h"
 
 /* The implementation based on MurmurHash 3,
    https://github.com/aappleby/smhasher/ */
@@ -181,7 +182,13 @@ CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s)
 
 /* The generic hash function */
 
-CAMLprim value caml_hash(value count, value limit, value seed, value obj)
+/* Internally to Jane Street, we have renamed [caml_hash] to [caml_hash_exn]
+   to suggest that calling it could raise. (E.g. it raises on mixed blocks.)
+   As such, we've removed [@@noalloc] from the OCaml [external] that references
+   this C binding, and would likewise need to remove [@@noalloc] from any
+   other [external] formerly bound to [caml_hash].
+*/
+CAMLprim value caml_hash_exn(value count, value limit, value seed, value obj)
 {
   value queue[HASH_QUEUE_SIZE]; /* Queue of values to examine */
   intnat rd;                    /* Position of first value in queue */
@@ -283,20 +290,16 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
       }
 #endif
       default:
+	if (Is_mixed_block_reserved(Reserved_val(v))) {
+	  caml_invalid_argument("hash: mixed block value");
+	}
         /* Mix in the tag and size, but do not count this towards [num] */
         h = caml_hash_mix_uint32(h, Whitehd_hd(Hd_val(v)));
         /* Copy fields into queue, not exceeding the total size [sz] */
-        for (i = 0, len = Scannable_wosize_val(v); i < len; i++) {
+        for (i = 0, len = Wosize_val(v); i < len; i++) {
           if (wr >= sz) break;
           queue[wr++] = Field(v, i);
         }
-
-        /* We don't attempt to hash the flat suffix of a mixed block.
-           This is consistent with abstract blocks which, like mixed
-           blocks, cause polymorphic comparison to raise and don't
-           attempt to hash the non-scannable portion.
-        */
-
         break;
       }
     }
diff --git a/stdlib/bool.ml b/stdlib/bool.ml
@@ -37,7 +37,11 @@ let of_string = function
 
 let to_string = function false -> "false" | true -> "true"
 
+(* [caml_hash_exn] doesn't raise on booleans, so it's safe for
+   it to be marked as [@@noalloc].
+ *)
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> bool -> int = "caml_hash_exn" [@@noalloc]
+
 let seeded_hash seed x = seeded_hash_param 10 100 seed x
 let hash x = seeded_hash_param 10 100 0 x
diff --git a/stdlib/char.ml b/stdlib/char.ml
@@ -64,7 +64,10 @@ type t = char
 let compare c1 c2 = code c1 - code c2
 let equal (c1: t) (c2: t) = compare c1 c2 = 0
 
+(* [caml_hash_exn] doesn't raise on chars, so it's safe for
+   it to be marked as [@@noalloc].
+ *)
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> char -> int = "caml_hash_exn" [@@noalloc]
 let seeded_hash seed x = seeded_hash_param 10 100 seed x
 let hash x = seeded_hash_param 10 100 0 x
diff --git a/stdlib/float.ml b/stdlib/float.ml
@@ -171,8 +171,11 @@ let[@inline] min_max_num (x: float) (y: float) =
   else if is_nan y then (x,x)
   else if y > x || (not(sign_bit y) && sign_bit x) then (x,y) else (y,x)
 
+(* [caml_hash_exn] doesn't raise on floats, so it's safe for
+   it to be marked as [@@noalloc].
+ *)
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> float -> int = "caml_hash_exn" [@@noalloc]
 let seeded_hash seed x = seeded_hash_param 10 100 seed x
 let hash x = seeded_hash_param 10 100 0 x
 
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
@@ -501,7 +501,7 @@ module Make(H: HashedType): (S with type key = H.t) =
    use - see #2202 *)
 
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> 'a -> int = "caml_hash_exn"
 
 let hash x = seeded_hash_param 10 100 0 x
 let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
diff --git a/stdlib/int.ml b/stdlib/int.ml
@@ -56,7 +56,10 @@ let of_string s = try Some (int_of_string s) with Failure _ -> None
 external format_int : string -> int -> string = "caml_format_int"
 let to_string x = format_int "%d" x
 
+(* [caml_hash_exn] doesn't raise on ints, so it's safe for
+   it to be marked as [@@noalloc].
+ *)
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> int -> int = "caml_hash_exn" [@@noalloc]
 let seeded_hash seed x = seeded_hash_param 10 100 seed x
 let hash x = seeded_hash_param 10 100 0 x
diff --git a/stdlib/int32.ml b/stdlib/int32.ml
@@ -109,7 +109,10 @@ let[@inline available] unsigned_div n d =
 let[@inline available] unsigned_rem n d =
   sub n (mul ((unsigned_div[@inlined]) n d) d)
 
+(* [caml_hash_exn] doesn't raise on int32s, so it's safe for
+   it to be marked as [@@noalloc].
+ *)
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> int32 -> int = "caml_hash_exn" [@@noalloc]
 let seeded_hash seed x = seeded_hash_param 10 100 seed x
 let hash x = seeded_hash_param 10 100 0 x
diff --git a/stdlib/int64.ml b/stdlib/int64.ml
@@ -108,7 +108,10 @@ let[@inline available] unsigned_div n d =
 let[@inline available] unsigned_rem n d =
   sub n (mul ((unsigned_div[@inlined]) n d) d)
 
+(* [caml_hash_exn] doesn't raise on int64s, so it's safe for
+   it to be marked as [@@noalloc].
+ *)
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> int64 -> int = "caml_hash_exn" [@@noalloc]
 let seeded_hash seed x = seeded_hash_param 10 100 seed x
 let hash x = seeded_hash_param 10 100 0 x
diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml
@@ -98,7 +98,10 @@ let[@inline available] unsigned_div n d =
 let[@inline available] unsigned_rem n d =
   sub n (mul ((unsigned_div[@inlined]) n d) d)
 
+(* [caml_hash_exn] doesn't raise on nativeints, so it's safe for
+   it to be marked as [@@noalloc].
+ *)
 external seeded_hash_param :
-  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+  int -> int -> int -> nativeint -> int = "caml_hash_exn" [@@noalloc]
 let seeded_hash seed x = seeded_hash_param 10 100 seed x
 let hash x = seeded_hash_param 10 100 0 x
diff --git a/testsuite/tests/mixed-blocks/generate_mixed_blocks_code.ml b/testsuite/tests/mixed-blocks/generate_mixed_blocks_code.ml
@@ -334,7 +334,6 @@ let copy_via_tag x =
   line {|let oc = Out_channel.open_bin "/dev/null"|};
   line {|exception Unexpected_success|};
   line {|type forget = T : _ -> forget|};
-  line {|let try_hash x = ignore (Hashtbl.hash x : int)|};
   if not bytecode
   then
     line
@@ -344,6 +343,9 @@ let expect_failure f =
   | Unexpected_success -> assert false
   | _ -> ()
 
+let try_hash x =
+  expect_failure (fun () -> ignore (Hashtbl.hash x : int))
+
 let try_compare x y =
   expect_failure (fun () -> ignore (compare (T x) (T y) : int));
   expect_failure (fun () -> ignore ((T x) = (T y) : bool))
@@ -356,6 +358,9 @@ let try_marshal t =
      *)
     line
       {|
+let try_hash x =
+  ignore (Hashtbl.hash x : int)
+
 let try_compare x y =
   ignore (compare (T x) (T y) : int);
   ignore ((T x) = (T y) : bool)
diff --git a/testsuite/tests/mixed-blocks/generated_byte_test.ml b/testsuite/tests/mixed-blocks/generated_byte_test.ml
@@ -34,7 +34,9 @@ let copy_via_tag x =
 let oc = Out_channel.open_bin "/dev/null"
 exception Unexpected_success
 type forget = T : _ -> forget
-let try_hash x = ignore (Hashtbl.hash x : int)
+
+let try_hash x =
+  ignore (Hashtbl.hash x : int)
 
 let try_compare x y =
   ignore (compare (T x) (T y) : int);
diff --git a/testsuite/tests/mixed-blocks/generated_native_test.ml b/testsuite/tests/mixed-blocks/generated_native_test.ml
@@ -35,13 +35,15 @@ let copy_via_tag x =
 let oc = Out_channel.open_bin "/dev/null"
 exception Unexpected_success
 type forget = T : _ -> forget
-let try_hash x = ignore (Hashtbl.hash x : int)
 
 let expect_failure f =
   try f (); raise Unexpected_success with
   | Unexpected_success -> assert false
   | _ -> ()
 
+let try_hash x =
+  expect_failure (fun () -> ignore (Hashtbl.hash x : int))
+
 let try_compare x y =
   expect_failure (fun () -> ignore (compare (T x) (T y) : int));
   expect_failure (fun () -> ignore ((T x) = (T y) : bool))
diff --git a/testsuite/tests/mixed-blocks/hash.ml b/testsuite/tests/mixed-blocks/hash.ml
@@ -20,13 +20,20 @@
 
 (* Currently bytecode/native hashes of mixed records are different.
    Mixed records are represented as mixed blocks in native code and
-   normal blocks in bytecode. We don't make any special effort to get
-   their hash values to line up. This is something we could consider
-   revisiting -- the simplest way to accomplish this may well be to
-   support mixed blocks in bytecode.
- *)
+   normal blocks in bytecode. Hash raises on mixed blocks (but not
+   on normal blocks).
+
+   We could consider making native hash return a value instead. But,
+   if it's a different value than bytecode, it's important that users
+   can't marshal mixed block values from native code to bytecode.
+   (Otherwise you could marshal a hashtable, breaking its invariants.)
+*)
+
+let hash x =
+ match Hashtbl.hash x with
+ | exception exn -> Printf.sprintf "raised %s" (Printexc.to_string exn)
+ | i -> string_of_int i
 
-let hash = Hashtbl.hash
 let printf = Printf.printf
 
 let () = printf "All Float Mixed Records\n"
@@ -39,7 +46,7 @@ let () =
       }
   end in
   hash { x = 4.0; y = #5.1 }
-  |> printf "\t{ x : float; y : float# } = %d\n"
+  |> printf "\t{ x : float; y : float# } = %s\n"
 
 
 let () =
@@ -50,7 +57,7 @@ let () =
       }
   end in
   hash { x = #4.0; y = 5.1 }
-  |> printf "\t{ x : float#; y : float } = %d\n"
+  |> printf "\t{ x : float#; y : float } = %s\n"
 
 let () = printf "General Mixed Records\n"
 
@@ -63,7 +70,7 @@ let () =
       }
   end in
   hash { x = "abc"; y = #5.1 }
-  |> printf "\t{ x : string; y : float# } = %d\n"
+  |> printf "\t{ x : string; y : float# } = %s\n"
 
 let () =
   let open struct
@@ -73,7 +80,7 @@ let () =
       }
   end in
   hash { x = 23940; y = #5.1 }
-  |> printf "\t{ x : int; y : float# } = %d\n"
+  |> printf "\t{ x : int; y : float# } = %s\n"
 
 let () =
   let open struct
@@ -84,7 +91,7 @@ let () =
       }
   end in
   hash { x = 23940; y = #5.1; z = 1340 }
-  |> printf "\t{ x : int; y : float#; z : int } = %d\n"
+  |> printf "\t{ x : int; y : float#; z : int } = %s\n"
 
 let () =
   let open struct
@@ -96,4 +103,4 @@ let () =
       }
   end in
   hash { a = "abc"; x = 23940; y = #5.1; z = 1340 }
-  |> printf "\t{ a : string; x : int; y : float#; z : int } = %d\n"
+  |> printf "\t{ a : string; x : int; y : float#; z : int } = %s\n"
diff --git a/testsuite/tests/mixed-blocks/hash.native.reference b/testsuite/tests/mixed-blocks/hash.native.reference
@@ -1,8 +1,8 @@
 All Float Mixed Records
-	{ x : float; y : float# } = 980550003
-	{ x : float#; y : float } = 980550003
+	{ x : float; y : float# } = raised Invalid_argument("hash: mixed block value")
+	{ x : float#; y : float } = raised Invalid_argument("hash: mixed block value")
 General Mixed Records
-	{ x : string; y : float# } = 883581425
-	{ x : int; y : float# } = 980550003
-	{ x : int; y : float#; z : int } = 531159882
-	{ a : string; x : int; y : float#; z : int } = 677901263
+	{ x : string; y : float# } = raised Invalid_argument("hash: mixed block value")
+	{ x : int; y : float# } = raised Invalid_argument("hash: mixed block value")
+	{ x : int; y : float#; z : int } = raised Invalid_argument("hash: mixed block value")
+	{ a : string; x : int; y : float#; z : int } = raised Invalid_argument("hash: mixed block value")

Original file line number	Diff line number	Diff line change
`@@ -409,7 +409,7 @@ static intnat norm_minsize (intnat s)`
`409`	`409`	`if (s > Minor_heap_max) s = Minor_heap_max;`
`410`	`410`	`/* PR#9128 : Make sure the minor heap occupies an integral number of`
`411`	`411`	`pages, so that no page contains both bytecode and OCaml`
`412`		`- values. This would confuse, e.g., caml_hash. */`
	`412`	`+ values. This would confuse, e.g., caml_hash_exn. */`
`413`	`413`	`s = (s + page_wsize - 1) / page_wsize * page_wsize;`
`414`	`414`	`return s;`
`415`	`415`	`}`