A new runtime primitive for Array.fill (#8716)

11 files changed, 119 insertions, 10 deletions

diff --git a/Changes b/Changes
index 301f134690..3bbd55fd09 100644
--- a/Changes
+++ b/Changes
@@ -70,6 +70,9 @@ Working version
   commands for execution by Sys.command.
   (Xavier Leroy, review by David Allsopp and Damien Doligez)
 
+- #8716: Optimize [Array.fill] and [Hashtbl.clear] with a new runtime primitive
+  (Alain Frisch, review by David Allsopp, Stephen Dolan and Damien Doligez)
+
 ### Other libraries:
 
 - #1939, #2023: Implement Unix.truncate and Unix.ftruncate on Windows.
diff --git a/boot/ocamlc b/boot/ocamlc
index af0d030796..9b40fef9b0 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index dd74e9d7b4..2c1f161537 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/runtime/array.c b/runtime/array.c
index 1ccd4aa01f..657220d1f6 100644
--- a/runtime/array.c
+++ b/runtime/array.c
@@ -589,3 +589,45 @@ CAMLprim value caml_array_concat(value al)
   }
   return res;
 }
+
+CAMLprim value caml_array_fill(value array,
+                               value v_ofs,
+                               value v_len,
+                               value val)
+{
+  intnat ofs = Long_val(v_ofs);
+  intnat len = Long_val(v_len);
+  value* fp;
+
+  /* This duplicates the logic of caml_modify.  Please refer to the
+     implementation of that function for a description of GC
+     invariants we need to enforce.*/
+
+#ifdef FLAT_FLOAT_ARRAY
+  if (Tag_val(array) == Double_array_tag) {
+    double d = Double_val (val);
+    for (; len > 0; len--, ofs++)
+      Store_double_flat_field(array, ofs, d);
+    return Val_unit;
+  }
+#endif
+  fp = &Field(array, ofs);
+  if (Is_young(array)) {
+    for (; len > 0; len--, fp++) *fp = val;
+  } else {
+    int is_val_young_block = Is_block(val) && Is_young(val);
+    CAMLassert(Is_in_heap(fp));
+    for (; len > 0; len--, fp++) {
+      value old = *fp;
+      if (old == val) continue;
+      *fp = val;
+      if (Is_block(old)) {
+        if (Is_young(old)) continue;
+        if (caml_gc_phase == Phase_mark) caml_darken(old, NULL);
+      }
+      if (is_val_young_block) add_to_ref_table (&caml_ref_table, fp);
+    }
+    if (is_val_young_block) caml_check_urgent_gc (Val_unit);
+  }
+  return Val_unit;
+}
diff --git a/runtime/memory.c b/runtime/memory.c
index a4b76783e4..830c8f084b 100644
--- a/runtime/memory.c
+++ b/runtime/memory.c
@@ -673,6 +673,11 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
         while the GC is in the marking phase
         --> call [caml_darken] on the overwritten pointer so that the
             major GC treats it as an additional root.
+
+     The logic implemented below is duplicated in caml_array_fill to
+     avoid repated calls to caml_modify and repeated tests on the
+     values.  Don't forget to update caml_array_fill if the logic
+     below changes!
   */
   value old;
 
diff --git a/stdlib/array.ml b/stdlib/array.ml
index a1b9663f1d..19ceab108b 100644
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -30,6 +30,8 @@ external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
 external concat : 'a array list -> 'a array = "caml_array_concat"
 external unsafe_blit :
   'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
+external unsafe_fill :
+  'a array -> int -> int -> 'a -> unit = "caml_array_fill"
 external create_float: int -> float array = "caml_make_float_vect"
 let make_float = create_float
 
@@ -81,7 +83,7 @@ let sub a ofs len =
 let fill a ofs len v =
   if ofs < 0 || len < 0 || ofs > length a - len
   then invalid_arg "Array.fill"
-  else for i = ofs to ofs + len - 1 do unsafe_set a i v done
+  else unsafe_fill a ofs len v
 
 let blit a1 ofs1 a2 ofs2 len =
   if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index 82ee9db79f..4630ec1b31 100644
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -81,11 +81,10 @@ let create ?(random = !randomized) initial_size =
   { initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
 
 let clear h =
-  h.size <- 0;
-  let len = Array.length h.data in
-  for i = 0 to len - 1 do
-    h.data.(i) <- Empty
-  done
+  if h.size > 0 then begin
+    h.size <- 0;
+    Array.fill h.data 0 (Array.length h.data) Empty
+  end
 
 let reset h =
   let len = Array.length h.data in
diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference
index 296d4328a6..cfbdf900de 100644
--- a/testsuite/tests/backtrace/backtrace2.byte.reference
+++ b/testsuite/tests/backtrace/backtrace2.byte.reference
@@ -35,7 +35,7 @@ Uncaught exception Invalid_argument("index out of bounds")
 Raised by primitive operation at file "backtrace2.ml", line 67, characters 14-22
 test_Not_found
 Uncaught exception Not_found
-Raised at file "hashtbl.ml", line 194, characters 19-28
+Raised at file "hashtbl.ml", line 193, characters 19-28
 Called from file "backtrace2.ml", line 48, characters 9-42
 Re-raised at file "backtrace2.ml", line 48, characters 67-70
 Called from file "backtrace2.ml", line 67, characters 11-23
@@ -50,7 +50,7 @@ Called from file "camlinternalLazy.ml", line 31, characters 17-27
 Re-raised at file "camlinternalLazy.ml", line 36, characters 10-11
 Called from file "backtrace2.ml", line 67, characters 11-23
 Uncaught exception Not_found
-Raised at file "hashtbl.ml", line 194, characters 19-28
+Raised at file "hashtbl.ml", line 193, characters 19-28
 Called from file "backtrace2.ml", line 55, characters 8-41
 Re-raised at file "camlinternalLazy.ml", line 35, characters 62-63
 Called from file "camlinternalLazy.ml", line 31, characters 17-27
diff --git a/testsuite/tests/backtrace/backtrace2.opt.reference b/testsuite/tests/backtrace/backtrace2.opt.reference
index 2c246e2db2..d939835237 100644
--- a/testsuite/tests/backtrace/backtrace2.opt.reference
+++ b/testsuite/tests/backtrace/backtrace2.opt.reference
@@ -35,7 +35,7 @@ Uncaught exception Invalid_argument("index out of bounds")
 Raised by primitive operation at file "backtrace2.ml", line 67, characters 14-22
 test_Not_found
 Uncaught exception Not_found
-Raised at file "hashtbl.ml", line 194, characters 13-28
+Raised at file "hashtbl.ml", line 193, characters 13-28
 Called from file "backtrace2.ml", line 48, characters 9-42
 Re-raised at file "backtrace2.ml", line 48, characters 61-70
 Called from file "backtrace2.ml", line 67, characters 11-23
@@ -50,7 +50,7 @@ Called from file "camlinternalLazy.ml", line 31, characters 17-27
 Re-raised at file "camlinternalLazy.ml", line 36, characters 4-11
 Called from file "backtrace2.ml", line 67, characters 11-23
 Uncaught exception Not_found
-Raised at file "hashtbl.ml", line 194, characters 13-28
+Raised at file "hashtbl.ml", line 193, characters 13-28
 Called from file "backtrace2.ml", line 55, characters 8-41
 Re-raised at file "camlinternalLazy.ml", line 35, characters 56-63
 Called from file "camlinternalLazy.ml", line 31, characters 17-27
diff --git a/testsuite/tests/lib-array/ocamltests b/testsuite/tests/lib-array/ocamltests
new file mode 100644
index 0000000000..84c0c6ee5b
--- /dev/null
+++ b/testsuite/tests/lib-array/ocamltests
@@ -0,0 +1 @@
+test_array.ml
diff --git a/testsuite/tests/lib-array/test_array.ml b/testsuite/tests/lib-array/test_array.ml
new file mode 100644
index 0000000000..5cd9c7196a
--- /dev/null
+++ b/testsuite/tests/lib-array/test_array.ml
@@ -0,0 +1,57 @@
+(* TEST
+   * expect
+*)
+
+let a = Array.make 8 None;;
+let _ = Array.fill a 2 3 (Some 42);;
+a;;
+[%%expect{|
+val a : '_weak1 option array =
+  [|None; None; None; None; None; None; None; None|]
+- : unit = ()
+- : int option array =
+[|None; None; Some 42; Some 42; Some 42; None; None; None|]
+|}]
+let _ = Array.fill a 3 1 (Some 0);;
+a;;
+[%%expect{|
+- : unit = ()
+- : int option array =
+[|None; None; Some 42; Some 0; Some 42; None; None; None|]
+|}]
+let _ = Array.fill a 3 6 None;;
+a;;
+[%%expect{|
+Exception: Invalid_argument "Array.fill".
+|}]
+let _ = Array.fill a (-1) 2 None;;
+a;;
+[%%expect{|
+Exception: Invalid_argument "Array.fill".
+|}]
+let _ = Gc.compact ();;
+let _ = Array.fill a 5 1 (Some (if Random.int 2 < 0 then 1 else 2));;
+a;;
+[%%expect{|
+- : unit = ()
+- : unit = ()
+- : int option array =
+[|None; None; Some 42; Some 0; Some 42; Some 2; None; None|]
+|}]
+let _ = Array.fill a 5 1 None;;
+a;;
+[%%expect{|
+- : unit = ()
+- : int option array =
+[|None; None; Some 42; Some 0; Some 42; None; None; None|]
+|}]
+
+
+let a = Array.make 8 0.;;
+let _ = Array.fill a 2 3 42.;;
+a;;
+[%%expect{|
+val a : float array = [|0.; 0.; 0.; 0.; 0.; 0.; 0.; 0.|]
+- : unit = ()
+- : float array = [|0.; 0.; 42.; 42.; 42.; 0.; 0.; 0.|]
+|}]