/* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient_c.c,v 1.3 2006-09-27 15:36:18 rich Exp $
+ * $Id: ancient_c.c,v 1.8 2006-10-09 12:18:05 rich Exp $
*/
#include <string.h>
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
// Temporary solution: 'ulimit -s unlimited'. This function should
// be replaced with something iterative.
static size_t
-mark (value obj, area *ptr, area *restore, area *fixups)
+_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));
+ 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;
if (Is_block (field) &&
(Is_young (field) || Is_in_heap (field))) {
- size_t field_offset = mark (field, ptr, restore, fixups);
+ 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.
+ // 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;
}
}
-static CAMLprim value
-do_mark (value obj,
+static void *
+mark (value obj,
void *(*realloc)(void *data, void *ptr, size_t size),
void (*free)(void *data, void *ptr),
void *data)
{
- CAMLparam1 (obj);
- CAMLlocal1 (proxy);
-
area ptr; // This will be the out of heap area.
area_init_custom (&ptr, realloc, free, data);
area restore; // Headers to be fixed up after.
area fixups; // List of fake pointers to be fixed up.
area_init (&fixups);
- if (mark (obj, &ptr, &restore, &fixups) == -1) {
+ if (_mark (obj, &ptr, &restore, &fixups) == -1) {
// Ran out of memory. Recover and throw an exception.
area_free (&fixups);
do_restore (&ptr, &restore);
do_fixups (&ptr, &fixups);
area_free (&fixups);
- // Replace obj with a proxy.
- proxy = caml_alloc (1, Abstract_tag);
- Field (proxy, 0) = (value) ptr.ptr;
-
- CAMLreturn (proxy);
+ return ptr.ptr;
}
static void *
CAMLparam1 (obj);
CAMLlocal1 (proxy);
- proxy = do_mark (obj, my_realloc, my_free, 0);
+ void *ptr = mark (obj, my_realloc, my_free, 0);
+
+ // Return the proxy.
+ proxy = caml_alloc (1, Abstract_tag);
+ Field (proxy, 0) = (value) ptr;
CAMLreturn (proxy);
}
}
CAMLprim value
-ancient_share (value fdv, value obj)
+ancient_is_ancient (value obj)
{
- CAMLparam2 (fdv, obj);
- CAMLlocal1 (proxy);
-
- int fd = Int_val (fd);
- void *md = mmalloc_attach (fd, 0);
- if (md == 0) {
- perror ("mmalloc_attach");
- caml_failwith ("mmalloc_attach");
- }
-
- proxy = do_mark (obj, mrealloc, mfree, md);
+ CAMLparam1 (obj);
+ CAMLlocal1 (v);
- // Save the address of the object within the mmalloc area. We need
- // it when attaching.
- mmalloc_setkey (md, 0, (void *) Field (proxy, 0));
+ v = Is_young (obj) || Is_in_heap (obj) ? Val_false : Val_true;
- CAMLreturn (proxy);
+ CAMLreturn (v);
}
CAMLprim value
-ancient_attach (value fdv)
+ancient_attach (value fdv, value baseaddrv)
{
- CAMLparam1 (fdv);
- CAMLlocal1 (proxy);
+ CAMLparam2 (fdv, baseaddrv);
+ CAMLlocal1 (mdv);
- int fd = Int_val (fd);
- void *md = mmalloc_attach (fd, 0);
+ 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");
}
- proxy = caml_alloc (2, Abstract_tag);
- Field (proxy, 0) = (value) mmalloc_getkey (md, 0);
- Field (proxy, 1) = (value) md;
+ mdv = caml_alloc (1, Abstract_tag);
+ Field (mdv, 0) = (value) md;
- CAMLreturn (proxy);
+ CAMLreturn (mdv);
}
CAMLprim value
-ancient_detach (value obj)
+ancient_detach (value mdv)
{
- CAMLparam1 (obj);
- CAMLlocal1 (v);
+ CAMLparam1 (mdv);
- int size = Wosize_val (obj);
- if (size < 2) caml_failwith ("Ancient.detach: not an attached object");
+ void *md = (void *) Field (mdv, 0);
- v = Field (obj, 0);
- if (Is_long (v)) caml_invalid_argument ("detached");
-
- void *md = (void *) Field (obj, 1);
if (mmalloc_detach (md) != 0) {
perror ("mmalloc_detach");
caml_failwith ("mmalloc_detach");
}
- // Replace the proxy (a pointer) with an int 0 so we know it's
- // been detached in future.
- Field (obj, 0) = Val_long (0);
-
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