X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=ancient_c.c;h=a32f776277a29fca28024446a88f13f016c6a572;hb=c3bd88fb6d9ede9d14cd24cd70b5b9352002ecc2;hp=b39e9d941c7eb2729c8df8db88629f55d72ed32f;hpb=70ed84c05dfe890425592cc207f7a866f0afb04e;p=ocaml-ancient.git diff --git a/ancient_c.c b/ancient_c.c index b39e9d9..a32f776 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.2 2006-09-27 14:05:07 rich Exp $ + * $Id: ancient_c.c,v 1.6 2006-09-28 12:40:07 rich Exp $ */ #include @@ -11,6 +11,8 @@ #include #include +#include "mmalloc/mmalloc.h" + // From byterun/misc.h: typedef char * addr; @@ -45,6 +47,11 @@ typedef struct area { 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 @@ -53,6 +60,21 @@ area_init (area *a) 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 @@ -60,7 +82,10 @@ area_append (area *a, const void *obj, size_t size) { 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); @@ -73,7 +98,10 @@ area_shrink (area *a) { 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. } } @@ -81,7 +109,8 @@ area_shrink (area *a) 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; } @@ -120,9 +149,8 @@ mark (value obj, area *ptr, area *restore, area *fixups) char *header = Hp_val (obj); assert (Wosize_hp (header) > 0); // Always true? (XXX) - // 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. + // XXX This assertion might fail if someone tries to mark an object + // which is already ancient. assert (Is_young (obj) || Is_in_heap (obj)); // If we've already visited this object, just return its offset @@ -231,14 +259,14 @@ do_fixups (area *ptr, area *fixups) } } -CAMLprim value -ancient_mark (value obj) +static void * +do_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 (&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. @@ -246,8 +274,8 @@ ancient_mark (value obj) if (mark (obj, &ptr, &restore, &fixups) == -1) { // Ran out of memory. Recover and throw an exception. - do_restore (&ptr, &restore); area_free (&fixups); + do_restore (&ptr, &restore); area_free (&restore); area_free (&ptr); caml_failwith ("out of memory"); @@ -263,9 +291,32 @@ ancient_mark (value obj) do_fixups (&ptr, &fixups); area_free (&fixups); - // Replace obj with a proxy. + 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 = do_mark (obj, my_realloc, my_free, 0); + + // Return the proxy. proxy = caml_alloc (1, Abstract_tag); - Field (proxy, 0) = (value) ptr.ptr; + Field (proxy, 0) = (value) ptr; CAMLreturn (proxy); } @@ -302,3 +353,82 @@ ancient_delete (value obj) CAMLreturn (Val_unit); } + +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 = do_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); +}