/* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient_c.c,v 1.1 2006-09-27 12:07:07 rich Exp $
+ * $Id: ancient_c.c,v 1.8 2006-10-09 12:18:05 rich Exp $
*/
#include <string.h>
#include <caml/mlvalues.h>
#include <caml/fail.h>
+#include "mmalloc/mmalloc.h"
+
// From byterun/misc.h:
typedef char * addr;
+// From byterun/minor_gc.c:
+CAMLextern char *caml_young_start;
+CAMLextern char *caml_young_end;
+#define Is_young(val) \
+ (assert (Is_block (val)), \
+ (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start)
+
// From byterun/major_gc.h:
#ifdef __alpha
typedef int page_table_entry;
CAMLextern char *caml_heap_start;
CAMLextern char *caml_heap_end;
CAMLextern page_table_entry *caml_page_table;
-extern asize_t caml_page_low, caml_page_high;
#define In_heap 1
#define Not_in_heap 0
void *ptr; // Start of area.
size_t n; // Current position.
size_t size; // Allocated size.
+
+ // If this area requires custom realloc function, these will be non-null.
+ void *(*realloc)(void *data, void *ptr, size_t size);
+ void (*free)(void *data, void *ptr);
+ void *data;
} area;
static inline void
a->ptr = 0;
a->n =
a->size = 0;
+ a->realloc = 0;
+ a->free = 0;
+ a->data = 0;
+}
+
+static inline void
+area_init_custom (area *a,
+ void *(*realloc)(void *data, void *ptr, size_t size),
+ void (*free)(void *data, void *ptr),
+ void *data)
+{
+ area_init (a);
+ a->realloc = realloc;
+ a->free = free;
+ a->data = data;
}
static inline int
{
while (a->n + size > a->size) {
if (a->size == 0) a->size = 256; else a->size <<= 1;
- a->ptr = realloc (a->ptr, a->size);
+ a->ptr =
+ a->realloc
+ ? a->realloc (a->data, a->ptr, a->size)
+ : realloc (a->ptr, a->size);
if (a->ptr == 0) return -1; // Out of memory.
}
memcpy (a->ptr + a->n, obj, size);
{
if (a->n != a->size) {
a->size = a->n;
- a->ptr = realloc (a->ptr, a->size);
+ a->ptr =
+ a->realloc
+ ? a->realloc (a->data, a->ptr, a->size)
+ : realloc (a->ptr, a->size);
assert (a->ptr); // Getting smaller, so shouldn't really fail.
}
}
static inline void
area_free (area *a)
{
- free (a->ptr);
+ if (a->free) a->free (a->data, a->ptr);
+ else free (a->ptr);
a->n =
a->size = 0;
}
// object's header to a special 'visited' value. However since these
// are objects in the Caml heap we have to restore the original
// headers at the end, which is the purpose of the [restore] area.
+// 4. We use realloc to allocate the memory for the copy, but because
+// the memory can move around, we cannot store absolute pointers.
+// Instead we store offsets and fix them up later. This is the
+// purpose of the [fixups] area.
//
-// XXX Recursive function will probably fall over once we apply it to
-// large, deeply recursive structures. Should be replaced with something
-// iterative.
+// XXX Large, deeply recursive structures cause a stack overflow.
+// Temporary solution: 'ulimit -s unlimited'. This function should
+// be replaced with something iterative.
static size_t
-mark (value obj, area *ptr, area *restore)
+_mark (value obj, area *ptr, area *restore, area *fixups)
{
- char *header = Hp_val (obj);
- assert (Wosize_hp (header) > 0); // Always true? (XXX)
+ // XXX This assertion might fail if someone tries to mark an object
+ // which is already ancient.
+ assert (Is_young (obj) || Is_in_heap (obj));
- // We can't handle out-of-heap objects.
- // XXX Since someone might try to mark an ancient object, they
- // might get this error, so we should try to do better here.
- assert (Is_in_heap (obj));
+ char *header = Hp_val (obj);
// If we've already visited this object, just return its offset
// in the out-of-heap memory.
if (memcmp (header, &visited, sizeof visited) == 0)
return (Long_val (Field (obj, 0)));
+ // XXX Actually this fails if you try to persist a zero-length
+ // array. Needs to be fixed, but it breaks some rather important
+ // functions below.
+ assert (Wosize_hp (header) > 0);
+
// Offset where we will store this object in the out-of-heap memory.
size_t offset = ptr->n;
for (i = 0; i < nr_words; ++i) {
value field = Field (obj, i);
- if (Is_block (field)) {
- size_t field_offset = mark (field, ptr, restore);
+ if (Is_block (field) &&
+ (Is_young (field) || Is_in_heap (field))) {
+ size_t field_offset = _mark (field, ptr, restore, fixups);
if (field_offset == -1) return -1; // Propagate out of memory errors.
// Since the recursive call to mark above can reallocate the
// Don't store absolute pointers yet because realloc will
// move the memory around. Store a fake pointer instead.
- // We'll fix up these fake pointers afterwards.
- Field (obj_copy, i) = (field_offset + sizeof (header_t)) << 2;
+ // We'll fix up these fake pointers afterwards in do_fixups.
+ Field (obj_copy, i) = field_offset + sizeof (header_t);
+
+ size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
+ area_append (fixups, &fixup, sizeof fixup);
}
}
}
}
}
-CAMLprim value
-ancient_mark (value obj)
+// Fixup fake pointers.
+static void
+do_fixups (area *ptr, area *fixups)
{
- CAMLparam1 (obj);
- CAMLlocal1 (proxy);
+ long i;
+ for (i = 0; i < fixups->n; i += sizeof (size_t))
+ {
+ size_t fixup = *(size_t *)(fixups->ptr + i);
+ size_t offset = *(size_t *)(ptr->ptr + fixup);
+ void *real_ptr = ptr->ptr + offset;
+ *(value *)(ptr->ptr + fixup) = (value) real_ptr;
+ }
+}
+
+static void *
+mark (value obj,
+ void *(*realloc)(void *data, void *ptr, size_t size),
+ void (*free)(void *data, void *ptr),
+ void *data)
+{
area ptr; // This will be the out of heap area.
- area_init (&ptr);
+ area_init_custom (&ptr, realloc, free, data);
area restore; // Headers to be fixed up after.
area_init (&restore);
+ area fixups; // List of fake pointers to be fixed up.
+ area_init (&fixups);
- if (mark (obj, &ptr, &restore) == -1) {
+ if (_mark (obj, &ptr, &restore, &fixups) == -1) {
// Ran out of memory. Recover and throw an exception.
+ area_free (&fixups);
do_restore (&ptr, &restore);
area_free (&restore);
area_free (&ptr);
// Update all fake pointers in the out of heap area to make them real
// pointers.
- size_t i;
- for (i = 0; i < ptr.n; )
- {
- // Out of heap area is: header, fields, header, fields, ...
- // The header of each object tells us how many fields it has.
- char *header = ptr.ptr + i;
- size_t bytes = Bhsize_hp (header);
- value obj = Val_hp (header);
-
- int can_scan = Tag_val (obj) < No_scan_tag;
- if (can_scan) {
- mlsize_t nr_words = Wosize_hp (header);
- mlsize_t j;
-
- for (j = 0; j < nr_words; ++j) {
- value field = Field (obj, j);
-
- if (Is_block (field)) {
- size_t field_offset = field >> 2;
- void *field_ptr = ptr.ptr + field_offset;
- Field (obj, j) = (value) field_ptr;
- }
- }
- }
+ do_fixups (&ptr, &fixups);
+ area_free (&fixups);
- i += bytes; // Skip to next object.
- }
+ return ptr.ptr;
+}
+
+static void *
+my_realloc (void *data __attribute__((unused)), void *ptr, size_t size)
+{
+ return realloc (ptr, size);
+}
+
+static void
+my_free (void *data __attribute__((unused)), void *ptr)
+{
+ return free (ptr);
+}
+
+CAMLprim value
+ancient_mark (value obj)
+{
+ CAMLparam1 (obj);
+ CAMLlocal1 (proxy);
+
+ void *ptr = mark (obj, my_realloc, my_free, 0);
- // Replace obj with a proxy.
+ // Return the proxy.
proxy = caml_alloc (1, Abstract_tag);
- Field (proxy, 0) = (value) ptr.ptr;
+ Field (proxy, 0) = (value) ptr;
CAMLreturn (proxy);
}
if (Is_long (v)) caml_invalid_argument ("deleted");
// Otherwise v is a pointer to the out of heap malloc'd object.
- assert (!Is_in_heap (v));
+ assert (!Is_young (v) && !Is_in_heap (v));
free ((void *) v);
// Replace the proxy (a pointer) with an int 0 so we know it's
CAMLreturn (Val_unit);
}
+
+CAMLprim value
+ancient_is_ancient (value obj)
+{
+ CAMLparam1 (obj);
+ CAMLlocal1 (v);
+
+ v = Is_young (obj) || Is_in_heap (obj) ? Val_false : Val_true;
+
+ CAMLreturn (v);
+}
+
+CAMLprim value
+ancient_attach (value fdv, value baseaddrv)
+{
+ CAMLparam2 (fdv, baseaddrv);
+ CAMLlocal1 (mdv);
+
+ int fd = Int_val (fdv);
+ void *baseaddr = (void *) Nativeint_val (baseaddrv);
+ void *md = mmalloc_attach (fd, baseaddr);
+ if (md == 0) {
+ perror ("mmalloc_attach");
+ caml_failwith ("mmalloc_attach");
+ }
+
+ mdv = caml_alloc (1, Abstract_tag);
+ Field (mdv, 0) = (value) md;
+
+ CAMLreturn (mdv);
+}
+
+CAMLprim value
+ancient_detach (value mdv)
+{
+ CAMLparam1 (mdv);
+
+ void *md = (void *) Field (mdv, 0);
+
+ if (mmalloc_detach (md) != 0) {
+ perror ("mmalloc_detach");
+ caml_failwith ("mmalloc_detach");
+ }
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ancient_share (value mdv, value keyv, value obj)
+{
+ CAMLparam3 (mdv, keyv, obj);
+ CAMLlocal1 (proxy);
+
+ void *md = (void *) Field (mdv, 0);
+ int key = Int_val (keyv);
+
+ // Existing key exists? Free it.
+ void *old_obj = mmalloc_getkey (md, key);
+ if (old_obj != 0) mfree (md, old_obj);
+ mmalloc_setkey (md, key, 0);
+
+ void *ptr = mark (obj, mrealloc, mfree, md);
+
+ mmalloc_setkey (md, key, ptr);
+
+ // Return the proxy.
+ proxy = caml_alloc (1, Abstract_tag);
+ Field (proxy, 0) = (value) ptr;
+
+ CAMLreturn (proxy);
+}
+
+CAMLprim value
+ancient_get (value mdv, value keyv)
+{
+ CAMLparam2 (mdv, keyv);
+ CAMLlocal1 (proxy);
+
+ void *md = (void *) Field (mdv, 0);
+ int key = Int_val (keyv);
+
+ void *ptr = mmalloc_getkey (md, key);
+ if (!ptr) caml_raise_not_found ();
+
+ // Return the proxy.
+ proxy = caml_alloc (1, Abstract_tag);
+ Field (proxy, 0) = (value) ptr;
+
+ CAMLreturn (proxy);
+}
git.annexia.org / ocaml-ancient.git / blobdiff