/* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient_c.c,v 1.5 2006-09-27 18:39:44 rich Exp $
*/
#include <string.h>
#include "mmalloc/mmalloc.h"
+// uintnat, intnat only appeared in Caml 3.09.x.
+#if OCAML_VERSION_MAJOR == 3 && OCAML_VERSION_MINOR < 9
+typedef unsigned long uintnat;
+typedef long intnat;
+#endif
+
+/* We need the macro 'Is_in_young_or_heap' which tell us if a block
+ * address is within the OCaml minor or major heaps. This comes out
+ * of the guts of OCaml.
+ */
+
+#if OCAML_VERSION_MAJOR == 3 && OCAML_VERSION_MINOR <= 10
+// Up to OCaml 3.10 there was a single contiguous page table.
+
// From byterun/misc.h:
typedef char * addr;
-// From byterun/minor_gc.c:
+// From byterun/minor_gc.h:
CAMLextern char *caml_young_start;
CAMLextern char *caml_young_end;
#define Is_young(val) \
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
(addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
&& caml_page_table [Page (p)])
+#define Is_in_heap_or_young(p) (Is_young (p) || Is_in_heap (p))
+
+#else /* OCaml >= 3.11 */
+
+// GC was rewritten in OCaml 3.11 so there is no longer a
+// single contiguous page table.
+
+// From byterun/memory.h:
+#define Not_in_heap 0
+#define In_heap 1
+#define In_young 2
+#define In_static_data 4
+#define In_code_area 8
+
+#ifdef ARCH_SIXTYFOUR
+
+/* 64 bits: Represent page table as a sparse hash table */
+int caml_page_table_lookup(void * addr);
+#define Classify_addr(a) (caml_page_table_lookup((void *)(a)))
+
+#else
+
+/* 32 bits: Represent page table as a 2-level array */
+#define Pagetable2_log 11
+#define Pagetable2_size (1 << Pagetable2_log)
+#define Pagetable1_log (Page_log + Pagetable2_log)
+#define Pagetable1_size (1 << (32 - Pagetable1_log))
+CAMLextern unsigned char * caml_page_table[Pagetable1_size];
+
+#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log)
+#define Pagetable_index2(a) \
+ ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1))
+#define Classify_addr(a) \
+ caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)]
+
+#endif
+
+#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young))
+
+#endif /* OCaml >= 3.11 */
+
// Area is an expandable buffer, allocated on the C heap.
typedef struct area {
void *ptr; // Start of area.
static inline int
area_append (area *a, const void *obj, size_t size)
{
+ void *ptr;
while (a->n + size > a->size) {
if (a->size == 0) a->size = 256; else a->size <<= 1;
- a->ptr =
+ 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.
+ if (ptr == 0) return -1; // Out of memory.
+ a->ptr = ptr;
}
memcpy (a->ptr + a->n, obj, size);
a->n += size;
// 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));
+ assert (Is_in_heap_or_young (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;
value field = Field (obj, i);
if (Is_block (field) &&
- (Is_young (field) || Is_in_heap (field))) {
- size_t field_offset = mark (field, ptr, restore, fixups);
+ Is_in_heap_or_young (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.
+ // 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;
// what was in that field before.
// (3) We can overwrite the header with all 1's to indicate that
// we've visited (but see notes on 'static header_t visited' above).
- // (4) All objects in OCaml are at least one word long (we hope!).
+ // (4) All objects in OCaml are at least one word long (XXX - actually
+ // this is not true).
struct restore_item restore_item;
restore_item.header = header;
restore_item.field_zero = Field (obj, 0);
}
static void *
-do_mark (value obj,
- void *(*realloc)(void *data, void *ptr, size_t size),
- void (*free)(void *data, void *ptr),
- void *data)
+mark (value obj,
+ void *(*realloc)(void *data, void *ptr, size_t size),
+ void (*free)(void *data, void *ptr),
+ void *data,
+ size_t *r_size)
{
area ptr; // This will be the out of heap area.
area_init_custom (&ptr, realloc, free, data);
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);
+ if (r_size) *r_size = ptr.size;
return ptr.ptr;
}
}
CAMLprim value
-ancient_mark (value obj)
+ancient_mark_info (value obj)
{
CAMLparam1 (obj);
- CAMLlocal1 (proxy);
+ CAMLlocal3 (proxy, info, rv);
- void *ptr = do_mark (obj, my_realloc, my_free, 0);
+ size_t size;
+ void *ptr = mark (obj, my_realloc, my_free, 0, &size);
- // Return the proxy.
+ // Make the proxy.
proxy = caml_alloc (1, Abstract_tag);
Field (proxy, 0) = (value) ptr;
- CAMLreturn (proxy);
+ // Make the info struct.
+ info = caml_alloc (1, 0);
+ Field (info, 0) = Val_long (size);
+
+ rv = caml_alloc (2, 0);
+ Field (rv, 0) = proxy;
+ Field (rv, 1) = info;
+
+ CAMLreturn (rv);
}
CAMLprim value
if (Is_long (v)) caml_invalid_argument ("deleted");
// Otherwise v is a pointer to the out of heap malloc'd object.
- assert (!Is_young (v) && !Is_in_heap (v));
+ assert (!Is_in_heap_or_young (v));
free ((void *) v);
// Replace the proxy (a pointer) with an int 0 so we know it's
}
CAMLprim value
-ancient_attach (value fdv)
+ancient_is_ancient (value obj)
+{
+ CAMLparam1 (obj);
+ CAMLlocal1 (v);
+
+ v = Is_in_heap_or_young (obj) ? Val_false : Val_true;
+
+ CAMLreturn (v);
+}
+
+CAMLprim value
+ancient_address_of (value obj)
{
- CAMLparam1 (fdv);
+ CAMLparam1 (obj);
+ CAMLlocal1 (v);
+
+ if (Is_block (obj)) v = caml_copy_nativeint ((intnat) obj);
+ else v = caml_copy_nativeint (0);
+
+ CAMLreturn (v);
+}
+
+CAMLprim value
+ancient_attach (value fdv, value baseaddrv)
+{
+ CAMLparam2 (fdv, baseaddrv);
CAMLlocal1 (mdv);
int fd = Int_val (fdv);
- void *md = mmalloc_attach (fd, 0);
+ void *baseaddr = (void *) Nativeint_val (baseaddrv);
+ void *md = mmalloc_attach (fd, baseaddr);
if (md == 0) {
perror ("mmalloc_attach");
caml_failwith ("mmalloc_attach");
CAMLreturn (Val_unit);
}
+struct keytable {
+ void **keys;
+ int allocated;
+};
+
CAMLprim value
-ancient_share (value mdv, value keyv, value obj)
+ancient_share_info (value mdv, value keyv, value obj)
{
CAMLparam3 (mdv, keyv, obj);
- CAMLlocal1 (proxy);
+ CAMLlocal3 (proxy, info, rv);
void *md = (void *) Field (mdv, 0);
int key = Int_val (keyv);
+ // Get the key table.
+ struct keytable *keytable = mmalloc_getkey (md, 0);
+ if (keytable == 0) {
+ keytable = mmalloc (md, sizeof (struct keytable));
+ if (keytable == 0) caml_failwith ("out of memory");
+ keytable->keys = 0;
+ keytable->allocated = 0;
+ mmalloc_setkey (md, 0, keytable);
+ }
+
// 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);
+ if (key < keytable->allocated && keytable->keys[key] != 0) {
+ mfree (md, keytable->keys[key]);
+ keytable->keys[key] = 0;
+ }
+
+ // Keytable large enough? If not, realloc it.
+ if (key >= keytable->allocated) {
+ int allocated = keytable->allocated == 0 ? 32 : keytable->allocated * 2;
+ void **keys = mrealloc (md, keytable->keys, allocated * sizeof (void *));
+ if (keys == 0) caml_failwith ("out of memory");
+ int i;
+ for (i = keytable->allocated; i < allocated; ++i) keys[i] = 0;
+ keytable->keys = keys;
+ keytable->allocated = allocated;
+ }
- void *ptr = do_mark (obj, mrealloc, mfree, md);
+ // Do the mark.
+ size_t size;
+ void *ptr = mark (obj, mrealloc, mfree, md, &size);
- mmalloc_setkey (md, key, ptr);
+ // Add the key to the keytable.
+ keytable->keys[key] = ptr;
- // Return the proxy.
+ // Make the proxy.
proxy = caml_alloc (1, Abstract_tag);
Field (proxy, 0) = (value) ptr;
- CAMLreturn (proxy);
+ // Make the info struct.
+ info = caml_alloc (1, 0);
+ Field (info, 0) = Val_long (size);
+
+ rv = caml_alloc (2, 0);
+ Field (rv, 0) = proxy;
+ Field (rv, 1) = info;
+
+ CAMLreturn (rv);
}
CAMLprim value
void *md = (void *) Field (mdv, 0);
int key = Int_val (keyv);
- void *ptr = mmalloc_getkey (md, key);
- if (!ptr) caml_raise_not_found ();
+ // Key exists?
+ struct keytable *keytable = mmalloc_getkey (md, 0);
+ if (keytable == 0 || key >= keytable->allocated || keytable->keys[key] == 0)
+ caml_raise_not_found ();
+ void *ptr = keytable->keys[key];
// Return the proxy.
proxy = caml_alloc (1, Abstract_tag);
git.annexia.org / ocaml-ancient.git / blobdiff