fix #11482: random crash in large closure allocation (#11542)

lthls · Jan 6, 2025 · dac715c · dac715c
1 parent 2a5bcc5
commit dac715c
Show file tree

Hide file tree

Showing 3 changed files with 34 additions and 7 deletions.
diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml
@@ -1769,15 +1769,11 @@ let make_alloc_generic ~block_kind ~mode dbg tag wordsize args
            fields and memory chunks"
     in
     let caml_alloc_func, caml_alloc_args =
-      match Config.runtime5, block_kind with
-      | true, Regular_block -> "caml_alloc_shr_check_gc", [wordsize; tag]
-      | false, Regular_block -> "caml_alloc", [wordsize; tag]
-      | true, Mixed_block { scannable_prefix } ->
+      match block_kind with
+      | Regular_block -> "caml_alloc_shr_check_gc", [wordsize; tag]
+      | Mixed_block { scannable_prefix } ->
         Mixed_block_support.assert_mixed_block_support ();
         "caml_alloc_mixed_shr_check_gc", [wordsize; tag; scannable_prefix]
-      | false, Mixed_block { scannable_prefix } ->
-        Mixed_block_support.assert_mixed_block_support ();
-        "caml_alloc_mixed", [wordsize; tag; scannable_prefix]
     in
     Clet
       ( VP.create id,

diff --git a/runtime4/alloc.c b/runtime4/alloc.c
@@ -67,13 +67,43 @@ CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) {
   return caml_alloc_with_reserved (wosize, tag, 0);
 }
 
+/* This is used by the native compiler for large block allocations. */
+CAMLexport value caml_alloc_shr_reserved_check_gc (mlsize_t wosize, tag_t tag,
+                                                   reserved_t reserved)
+{
+  CAMLassert (tag < Num_tags);
+  CAMLassert (tag != Infix_tag);
+  caml_check_urgent_gc (Val_unit);
+  value result = caml_alloc_shr_reserved (wosize, tag, reserved);
+  if (tag < No_scan_tag) {
+    mlsize_t scannable_wosize = Scannable_wosize_val(result);
+    for (mlsize_t i = 0; i < scannable_wosize; i++) {
+      Field (result, i) = Val_unit;
+    }
+  }
+  return result;
+}
+
+CAMLexport value caml_alloc_shr_check_gc (mlsize_t wosize, tag_t tag)
+{
+  return caml_alloc_shr_reserved_check_gc(wosize, tag, 0);
+}
+
 #ifdef NATIVE_CODE
 CAMLexport value caml_alloc_mixed (mlsize_t wosize, tag_t tag,
                                    mlsize_t scannable_prefix) {
   reserved_t reserved =
     Reserved_mixed_block_scannable_wosize_native(scannable_prefix);
   return caml_alloc_with_reserved (wosize, tag, reserved);
 }
+
+CAMLexport value caml_alloc_mixed_shr_check_gc (mlsize_t wosize, tag_t tag,
+                                                mlsize_t scannable_prefix_len)
+{
+  reserved_t reserved =
+    Reserved_mixed_block_scannable_wosize_native(scannable_prefix_len);
+  return caml_alloc_shr_reserved_check_gc(wosize, tag, reserved);
+}
 #endif // NATIVE_CODE
 
 CAMLexport value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t tag,

diff --git a/runtime4/caml/alloc.h b/runtime4/caml/alloc.h
@@ -37,6 +37,7 @@ CAMLextern value caml_alloc_mixed (mlsize_t wosize, tag_t,
 CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t);
 CAMLextern value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t,
                                                  reserved_t);
+CAMLextern value caml_alloc_shr_check_gc (mlsize_t, tag_t);
 CAMLextern value caml_alloc_tuple (mlsize_t wosize);
 CAMLextern value caml_alloc_float_array (mlsize_t len);
 CAMLextern value caml_alloc_string (mlsize_t len);  /* len in bytes (chars) */