runtime fns

Author: TheNumbat

ocaml/runtime/array.c

@@ -30,23 +30,22 @@ static const mlsize_t mlsize_t_max = -1;
 
 /* Unboxed arrays */
 
-static int no_polymorphic_compare(value v1, value v2)
+int no_polymorphic_compare(value v1, value v2)
 {
   caml_failwith("Polymorphic comparison is not permitted for unboxed arrays");
 }
 
-static intnat no_polymorphic_hash(value v)
+intnat no_polymorphic_hash(value v)
 {
   caml_failwith("Polymorphic hash is not permitted for unboxed arrays");
 }
 
-static void unboxed_array_serialize(value v, uintnat* bsize_32,
-                                    uintnat* bsize_64)
+void unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64)
 {
   caml_failwith("Marshalling is not yet implemented for unboxed arrays");
 }
 
-static uintnat unboxed_array_deserialize(void* dst)
+uintnat unboxed_array_deserialize(void* dst)
 {
   caml_failwith("Marshalling is not yet implemented for unboxed arrays");
 }

ocaml/runtime/float32.c

@@ -25,6 +25,7 @@
 #include <math.h>
 #include <float.h>
 #include <limits.h>
+#include <string.h>
 
 #include "caml/alloc.h"
 #include "caml/fail.h"
@@ -540,3 +541,59 @@ CAMLprim value caml_float32_of_string(value vs)
   caml_failwith("float32_of_string");
   return Val_unit; /* not reached */
 }
+
+/* Defined in array.c */
+
+extern int no_polymorphic_compare(value v1, value v2);
+extern intnat no_polymorphic_hash(value v);
+extern void unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64);
+extern uintnat unboxed_array_deserialize(void* dst);
+extern value caml_make_vect(value len, value init);
+
+CAMLexport const struct custom_operations caml_unboxed_float32_array_ops[2] = {
+  { "_unboxed_float32_even_array",
+    custom_finalize_default,
+    no_polymorphic_compare,
+    no_polymorphic_hash,
+    unboxed_array_serialize,
+    unboxed_array_deserialize,
+    custom_compare_ext_default,
+    custom_fixed_length_default },
+  { "_unboxed_float32_odd_array",
+    custom_finalize_default,
+    no_polymorphic_compare,
+    no_polymorphic_hash,
+    unboxed_array_serialize,
+    unboxed_array_deserialize,
+    custom_compare_ext_default,
+    custom_fixed_length_default },
+};
+
+CAMLprim value caml_make_unboxed_float32_vect(value len)
+{
+  /* This is only used on 64-bit targets. */
+
+  mlsize_t num_elements = Long_val(len);
+  if (num_elements > Max_wosize) caml_invalid_argument("Array.make");
+
+  /* [num_fields] does not include the custom operations field. */
+  mlsize_t num_fields = (num_elements + 1) / 2;
+
+  return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2],
+                           num_fields * sizeof(value), 0, 0);
+}
+
+CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len)
+{
+  return caml_make_vect(len, caml_copy_float32(0.0f));
+}
+
+CAMLprim value caml_unboxed_float32_vect_blit(value a1, value ofs1, value a2,
+                                              value ofs2, value n)
+{
+  // Need to skip the custom_operations field
+  memmove((float *)((uintnat *)a2 + 1) + Long_val(ofs2),
+          (float *)((uintnat *)a1 + 1) + Long_val(ofs1),
+          Long_val(n) * sizeof(float));
+  return Val_unit;
+}

ocaml/runtime4/array.c

@@ -30,23 +30,22 @@ static const mlsize_t mlsize_t_max = -1;
 
 /* Unboxed arrays */
 
-static int no_polymorphic_compare(value v1, value v2)
+int no_polymorphic_compare(value v1, value v2)
 {
   caml_failwith("Polymorphic comparison is not permitted for unboxed arrays");
 }
 
-static intnat no_polymorphic_hash(value v)
+intnat no_polymorphic_hash(value v)
 {
   caml_failwith("Polymorphic hash is not permitted for unboxed arrays");
 }
 
-static void unboxed_array_serialize(value v, uintnat* bsize_32,
-                                    uintnat* bsize_64)
+void unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64)
 {
   caml_failwith("Marshalling is not yet implemented for unboxed arrays");
 }
 
-static uintnat unboxed_array_deserialize(void* dst)
+uintnat unboxed_array_deserialize(void* dst)
 {
   caml_failwith("Marshalling is not yet implemented for unboxed arrays");
 }

ocaml/runtime4/float32.c

@@ -25,6 +25,7 @@
 #include <math.h>
 #include <float.h>
 #include <limits.h>
+#include <string.h>
 
 #include "caml/alloc.h"
 #include "caml/fail.h"
@@ -540,3 +541,59 @@ CAMLprim value caml_float32_of_string(value vs)
   caml_failwith("float32_of_string");
   return Val_unit; /* not reached */
 }
+
+/* Defined in array.c */
+
+extern int no_polymorphic_compare(value v1, value v2);
+extern intnat no_polymorphic_hash(value v);
+extern void unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64);
+extern uintnat unboxed_array_deserialize(void* dst);
+extern value caml_make_vect(value len, value init);
+
+CAMLexport struct custom_operations caml_unboxed_float32_array_ops[2] = {
+  { "_unboxed_float32_even_array",
+    custom_finalize_default,
+    no_polymorphic_compare,
+    no_polymorphic_hash,
+    unboxed_array_serialize,
+    unboxed_array_deserialize,
+    custom_compare_ext_default,
+    custom_fixed_length_default },
+  { "_unboxed_float32_odd_array",
+    custom_finalize_default,
+    no_polymorphic_compare,
+    no_polymorphic_hash,
+    unboxed_array_serialize,
+    unboxed_array_deserialize,
+    custom_compare_ext_default,
+    custom_fixed_length_default },
+};
+
+CAMLprim value caml_make_unboxed_float32_vect(value len)
+{
+  /* This is only used on 64-bit targets. */
+
+  mlsize_t num_elements = Long_val(len);
+  if (num_elements > Max_wosize) caml_invalid_argument("Array.make");
+
+  /* [num_fields] does not include the custom operations field. */
+  mlsize_t num_fields = (num_elements + 1) / 2;
+
+  return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2],
+                           num_fields * sizeof(value), 0, 0);
+}
+
+CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len)
+{
+  return caml_make_vect(len, caml_copy_float32(0.0f));
+}
+
+CAMLprim value caml_unboxed_float32_vect_blit(value a1, value ofs1, value a2,
+                                              value ofs2, value n)
+{
+  // Need to skip the custom_operations field
+  memmove((float *)((uintnat *)a2 + 1) + Long_val(ofs2),
+          (float *)((uintnat *)a1 + 1) + Long_val(ofs1),
+          Long_val(n) * sizeof(float));
+  return Val_unit;
+}