From dac715c8db01ce8b0bc1c19798b3813be5d5df58 Mon Sep 17 00:00:00 2001
From: Damien Doligez <damien.doligez@inria.fr>
Date: Tue, 20 Sep 2022 15:37:53 +0200
Subject: [PATCH] fix #11482: random crash in large closure allocation (#11542)

---
 backend/cmm_helpers.ml | 10 +++-------
 runtime4/alloc.c       | 30 ++++++++++++++++++++++++++++++
 runtime4/caml/alloc.h  |  1 +
 3 files changed, 34 insertions(+), 7 deletions(-)

diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml
index 3931e0eb7c6..5d7be318b64 100644
--- 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
index c25b606859b..7821c609a4e 100644
--- a/runtime4/alloc.c
+++ b/runtime4/alloc.c
@@ -67,6 +67,28 @@ 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) {
@@ -74,6 +96,14 @@ CAMLexport value caml_alloc_mixed (mlsize_t wosize, tag_t tag,
     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
index 2c243ccd084..10f0fefc484 100644
--- 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) */