X-Git-Url: http://git.annexia.org/?p=ocaml-ancient.git;a=blobdiff_plain;f=ancient_c.c;h=ea2ca558f285997e243324f84e8d7db9a6a0145f;hp=a32f776277a29fca28024446a88f13f016c6a572;hb=a1534eec44a5d11dde2f7271afbe0192d1b72b1b;hpb=c3bd88fb6d9ede9d14cd24cd70b5b9352002ecc2 diff --git a/ancient_c.c b/ancient_c.c index a32f776..ea2ca55 100644 --- a/ancient_c.c +++ b/ancient_c.c @@ -1,5 +1,5 @@ /* Mark objects as 'ancient' so they are taken out of the OCaml heap. - * $Id: ancient_c.c,v 1.6 2006-09-28 12:40:07 rich Exp $ + * $Id: ancient_c.c,v 1.10 2006-10-13 12:28:20 rich Exp $ */ #include @@ -32,7 +32,6 @@ typedef char 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 @@ -144,20 +143,24 @@ static header_t visited = (unsigned long) -1; // 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; @@ -177,7 +180,7 @@ mark (value obj, area *ptr, area *restore, area *fixups) 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 @@ -187,7 +190,7 @@ mark (value obj, area *ptr, area *restore, area *fixups) // 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; @@ -207,7 +210,8 @@ mark (value obj, area *ptr, area *restore, area *fixups) // 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); @@ -260,10 +264,11 @@ do_fixups (area *ptr, area *fixups) } 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); @@ -272,7 +277,7 @@ do_mark (value obj, 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); @@ -291,6 +296,7 @@ do_mark (value obj, do_fixups (&ptr, &fixups); area_free (&fixups); + if (r_size) *r_size = ptr.size; return ptr.ptr; } @@ -307,18 +313,27 @@ my_free (void *data __attribute__((unused)), void *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 @@ -355,6 +370,29 @@ ancient_delete (value obj) } 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_address_of (value obj) +{ + 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); @@ -389,29 +427,67 @@ ancient_detach (value mdv) 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 @@ -423,8 +499,11 @@ ancient_get (value mdv, value keyv) 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);