Add some new locally-allocating primitives (#57)

  - Polymorphic comparison operators now accept local values
  - Local bytes can be created
  - bytes and Bigstring boxed integer accessors can return locally allocated values
  - Local arrays can be created and manipulated

New primitives are not currently exposed in the stdlib.

Author: stedolan

runtime/alloc.c

@@ -94,6 +94,20 @@ CAMLexport value caml_alloc_string (mlsize_t len)
   return result;
 }
 
+/* [len] is a number of bytes (chars) */
+CAMLexport value caml_alloc_local_string (mlsize_t len)
+{
+  mlsize_t offset_index;
+  mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
+  value result;
+
+  result = caml_alloc_local(wosize, String_tag);
+  Field (result, wosize - 1) = 0;
+  offset_index = Bsize_wsize (wosize) - 1;
+  Byte (result, offset_index) = offset_index - len;
+  return result;
+}
+
 /* [len] is a number of bytes (chars) */
 CAMLexport value caml_alloc_initialized_string (mlsize_t len, const char *p)
 {

runtime/array.c

@@ -282,6 +282,12 @@ CAMLprim value caml_floatarray_create(value len)
   return caml_process_pending_actions_with_root (result);
 }
 
+CAMLprim value caml_floatarray_create_local(value len)
+{
+  mlsize_t wosize = Long_val(len) * Double_wosize;
+  return caml_alloc_local (wosize, Double_array_tag);
+}
+
 /* [len] is a [value] representing number of words or floats */
 static value make_vect_gen(value len, value init, int local)
 {
@@ -447,8 +453,9 @@ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
   }
 #endif
   CAMLassert (Tag_val(a2) != Double_array_tag);
-  if (Is_young(a2)) {
-    /* Arrays of values, destination is in young generation.
+  if (Is_young(a2) ||
+      Color_hd(Hd_val(a2)) == Local_unmarked) {
+    /* Arrays of values, destination is local or in young generation.
        Here too we can do a direct copy since this cannot create
        old-to-young pointers, nor mess up with the incremental major GC.
        Again, memmove takes care of overlap. */
@@ -487,7 +494,8 @@ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
 static value caml_array_gather(intnat num_arrays,
                                value arrays[/*num_arrays*/],
                                intnat offsets[/*num_arrays*/],
-                               intnat lengths[/*num_arrays*/])
+                               intnat lengths[/*num_arrays*/],
+                               int local)
 {
   CAMLparamN(arrays, num_arrays);
   value res;                    /* no need to register it as a root */
@@ -516,7 +524,9 @@ static value caml_array_gather(intnat num_arrays,
     /* This is an array of floats.  We can use memcpy directly. */
     if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat");
     wsize = size * Double_wosize;
-    res = caml_alloc(wsize, Double_array_tag);
+    res = local ?
+      caml_alloc_local(wsize, Double_array_tag) :
+      caml_alloc(wsize, Double_array_tag);
     for (i = 0, pos = 0; i < num_arrays; i++) {
       memcpy((double *)res + pos,
              (double *)arrays[i] + offsets[i],
@@ -526,21 +536,22 @@ static value caml_array_gather(intnat num_arrays,
     CAMLassert(pos == size);
   }
 #endif
-  else if (size <= Max_young_wosize) {
-    /* Array of values, small enough to fit in young generation.
+  else if (size > Max_wosize) {
+    /* Array of values, too big. */
+    caml_invalid_argument("Array.concat");
+  } else if (size <= Max_young_wosize || local) {
+    /* Array of values, local or small enough to fit in young generation.
        We can use memcpy directly. */
-    res = caml_alloc_small(size, 0);
+    res = local ?
+      caml_alloc_local(size, 0) :
+      caml_alloc_small(size, 0);
     for (i = 0, pos = 0; i < num_arrays; i++) {
       memcpy(&Field(res, pos),
              &Field(arrays[i], offsets[i]),
              lengths[i] * sizeof(value));
       pos += lengths[i];
     }
     CAMLassert(pos == size);
-  }
-  else if (size > Max_wosize) {
-    /* Array of values, too big. */
-    caml_invalid_argument("Array.concat");
   } else {
     /* Array of values, must be allocated in old generation and filled
        using caml_initialize. */
@@ -567,18 +578,34 @@ CAMLprim value caml_array_sub(value a, value ofs, value len)
   value arrays[1] = { a };
   intnat offsets[1] = { Long_val(ofs) };
   intnat lengths[1] = { Long_val(len) };
-  return caml_array_gather(1, arrays, offsets, lengths);
+  return caml_array_gather(1, arrays, offsets, lengths, 0);
+}
+
+CAMLprim value caml_array_sub_local(value a, value ofs, value len)
+{
+  value arrays[1] = { a };
+  intnat offsets[1] = { Long_val(ofs) };
+  intnat lengths[1] = { Long_val(len) };
+  return caml_array_gather(1, arrays, offsets, lengths, 1);
 }
 
 CAMLprim value caml_array_append(value a1, value a2)
 {
   value arrays[2] = { a1, a2 };
   intnat offsets[2] = { 0, 0 };
   intnat lengths[2] = { caml_array_length(a1), caml_array_length(a2) };
-  return caml_array_gather(2, arrays, offsets, lengths);
+  return caml_array_gather(2, arrays, offsets, lengths, 0);
 }
 
-CAMLprim value caml_array_concat(value al)
+CAMLprim value caml_array_append_local(value a1, value a2)
+{
+  value arrays[2] = { a1, a2 };
+  intnat offsets[2] = { 0, 0 };
+  intnat lengths[2] = { caml_array_length(a1), caml_array_length(a2) };
+  return caml_array_gather(2, arrays, offsets, lengths, 1);
+}
+
+static value array_concat_gen(value al, int local)
 {
 #define STATIC_SIZE 16
   value static_arrays[STATIC_SIZE], * arrays;
@@ -615,7 +642,7 @@ CAMLprim value caml_array_concat(value al)
     lengths[i] = caml_array_length(Field(l, 0));
   }
   /* Do the concatenation */
-  res = caml_array_gather(n, arrays, offsets, lengths);
+  res = caml_array_gather(n, arrays, offsets, lengths, local);
   /* Free the extra storage if needed */
   if (n > STATIC_SIZE) {
     caml_stat_free(arrays);
@@ -625,6 +652,16 @@ CAMLprim value caml_array_concat(value al)
   return res;
 }
 
+CAMLprim value caml_array_concat(value al)
+{
+  return array_concat_gen(al, 0);
+}
+
+CAMLprim value caml_array_concat_local(value al)
+{
+  return array_concat_gen(al, 1);
+}
+
 CAMLprim value caml_array_fill(value array,
                                value v_ofs,
                                value v_len,
@@ -647,7 +684,8 @@ CAMLprim value caml_array_fill(value array,
   }
 #endif
   fp = &Field(array, ofs);
-  if (Is_young(array)) {
+  if (Is_young(array) ||
+      Color_hd(Hd_val(array)) == Local_unmarked) {
     for (; len > 0; len--, fp++) *fp = val;
   } else {
     int is_val_young_block = Is_block(val) && Is_young(val);

runtime/caml/address_class.h

@@ -82,7 +82,7 @@
 #define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young))
 
 #define Is_in_value_area(a)                                     \
-  (Classify_addr(a) & (In_heap | In_young | In_static_data))
+  (Classify_addr(a) & (In_heap | In_young | In_static_data | In_local))
 
 #define Is_in_static_data(a) (Classify_addr(a) & In_static_data)
 
@@ -95,6 +95,7 @@
 #define In_heap 1
 #define In_young 2
 #define In_static_data 4
+#define In_local 8
 
 #ifdef ARCH_SIXTYFOUR
 

runtime/caml/alloc.h

@@ -36,6 +36,7 @@ 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) */
 CAMLextern value caml_alloc_initialized_string (mlsize_t len, const char *);
+CAMLextern value caml_alloc_local_string (mlsize_t len);
 CAMLextern value caml_copy_string (char const *);
 CAMLextern value caml_copy_string_array (char const **);
 CAMLextern value caml_copy_double (double);

runtime/caml/gc.h

@@ -77,6 +77,7 @@
 struct caml_local_arena {
   char* base;
   uintnat length;
+  void* alloc_block;
 };
 typedef struct caml_local_arenas {
   int count;

runtime/memory.c

@@ -728,6 +728,7 @@ void caml_local_realloc()
   caml_local_arenas* s = caml_get_local_arenas();
   intnat i;
   char* arena;
+  caml_stat_block block;
   if (s == NULL) {
     s = caml_stat_alloc(sizeof(*s));
     s->count = 0;
@@ -748,9 +749,10 @@ void caml_local_realloc()
     /* may need to loop, if a very large allocation was requested */
   } while (s->saved_sp + s->next_length < 0);
 
-  arena = caml_stat_alloc_noexc(s->next_length);
+  arena = caml_stat_alloc_aligned_noexc(s->next_length, 0, &block);
   if (arena == NULL)
     caml_fatal_error("Local allocation stack overflow - out of memory");
+  caml_page_table_add(In_local, arena, arena + s->next_length);
 #ifdef DEBUG
   for (i = 0; i < s->next_length; i += sizeof(value)) {
     *((header_t*)(arena + i)) = Debug_uninit_local;
@@ -765,6 +767,7 @@ void caml_local_realloc()
   s->count++;
   s->arenas[s->count-1].length = s->next_length;
   s->arenas[s->count-1].base = arena;
+  s->arenas[s->count-1].alloc_block = block;
   caml_set_local_arenas(s);
   CAMLassert(Caml_state->local_limit <= Caml_state->local_sp);
 }

runtime/str.c

@@ -78,6 +78,14 @@ CAMLprim value caml_create_bytes(value len)
   return caml_alloc_string(size);
 }
 
+CAMLprim value caml_create_local_bytes(value len)
+{
+  mlsize_t size = Long_val(len);
+  if (size > Bsize_wsize (Max_wosize) - 1){
+    caml_invalid_argument("Bytes.create");
+  }
+  return caml_alloc_local_string(size);
+}
 
 
 CAMLprim value caml_string_get(value str, value index)

stdlib/stdlib.ml

@@ -63,13 +63,13 @@ external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
 
 (* Comparisons *)
 
-external ( = ) : 'a -> 'a -> bool = "%equal"
-external ( <> ) : 'a -> 'a -> bool = "%notequal"
-external ( < ) : 'a -> 'a -> bool = "%lessthan"
-external ( > ) : 'a -> 'a -> bool = "%greaterthan"
-external ( <= ) : 'a -> 'a -> bool = "%lessequal"
-external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
-external compare : 'a -> 'a -> int = "%compare"
+external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal"
+external ( <> ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%notequal"
+external ( < ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessthan"
+external ( > ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterthan"
+external ( <= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessequal"
+external ( >= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterequal"
+external compare : ('a[@local_opt]) -> ('a[@local_opt]) -> int = "%compare"
 
 let min x y = if x <= y then x else y
 let max x y = if x >= y then x else y

stdlib/stdlib.mli

@@ -118,7 +118,7 @@ exception Undefined_recursive_module of (string * int * int)
 
 (** {1 Comparisons} *)
 
-external ( = ) : 'a -> 'a -> bool = "%equal"
+external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal"
 (** [e1 = e2] tests for structural equality of [e1] and [e2].
    Mutable structures (e.g. references and arrays) are equal
    if and only if their current contents are structurally equal,
@@ -127,27 +127,27 @@ external ( = ) : 'a -> 'a -> bool = "%equal"
    Equality between cyclic data structures may not terminate.
    Left-associative operator, see {!Ocaml_operators} for more information. *)
 
-external ( <> ) : 'a -> 'a -> bool = "%notequal"
+external ( <> ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%notequal"
 (** Negation of {!Stdlib.( = )}.
     Left-associative operator, see {!Ocaml_operators} for more information.
 *)
 
-external ( < ) : 'a -> 'a -> bool = "%lessthan"
+external ( < ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessthan"
 (** See {!Stdlib.( >= )}.
     Left-associative operator, see {!Ocaml_operators} for more information.
 *)
 
-external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+external ( > ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterthan"
 (** See {!Stdlib.( >= )}.
     Left-associative operator,  see {!Ocaml_operators} for more information.
 *)
 
-external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+external ( <= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessequal"
 (** See {!Stdlib.( >= )}.
     Left-associative operator,  see {!Ocaml_operators} for more information.
 *)
 
-external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+external ( >= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterequal"
 (** Structural ordering functions. These functions coincide with
    the usual orderings over integers, characters, strings, byte sequences
    and floating-point numbers, and extend them to a
@@ -159,7 +159,7 @@ external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
    Left-associative operator, see {!Ocaml_operators} for more information.
 *)
 
-external compare : 'a -> 'a -> int = "%compare"
+external compare : ('a[@local_opt]) -> ('a[@local_opt]) -> int = "%compare"
 (** [compare x y] returns [0] if [x] is equal to [y],
    a negative integer if [x] is less than [y], and a positive integer
    if [x] is greater than [y].  The ordering implemented by [compare]