/* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient_c.c,v 1.4 2006-09-27 16:01:47 rich Exp $
+ * $Id: ancient_c.c,v 1.6 2006-09-28 12:40:07 rich Exp $
*/
#include <string.h>
void *ptr = do_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;
}
CAMLprim value
-ancient_share (value fdv, value obj)
+ancient_attach (value fdv, value baseaddrv)
{
- CAMLparam2 (fdv, obj);
- CAMLlocal1 (proxy);
+ 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");
}
- void *ptr = do_mark (obj, mrealloc, mfree, md);
+ mdv = caml_alloc (1, Abstract_tag);
+ Field (mdv, 0) = (value) md;
- // Save the address of the object within the mmalloc area. We need
- // it when attaching.
- mmalloc_setkey (md, 0, ptr);
+ CAMLreturn (mdv);
+}
- proxy = caml_alloc (2, Abstract_tag);
- Field (proxy, 0) = (value) ptr;
- Field (proxy, 1) = (value) md;
+CAMLprim value
+ancient_detach (value mdv)
+{
+ CAMLparam1 (mdv);
- CAMLreturn (proxy);
+ void *md = (void *) Field (mdv, 0);
+
+ if (mmalloc_detach (md) != 0) {
+ perror ("mmalloc_detach");
+ caml_failwith ("mmalloc_detach");
+ }
+
+ CAMLreturn (Val_unit);
}
CAMLprim value
-ancient_attach (value fdv)
+ancient_share (value mdv, value keyv, value obj)
{
- CAMLparam1 (fdv);
+ CAMLparam3 (mdv, keyv, obj);
CAMLlocal1 (proxy);
- int fd = Int_val (fdv);
- void *md = mmalloc_attach (fd, 0);
- if (md == 0) {
- perror ("mmalloc_attach");
- caml_failwith ("mmalloc_attach");
- }
+ 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);
- proxy = caml_alloc (2, Abstract_tag);
- Field (proxy, 0) = (value) mmalloc_getkey (md, 0);
- Field (proxy, 1) = (value) md;
+ 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_detach (value obj)
+ancient_get (value mdv, value keyv)
{
- CAMLparam1 (obj);
- CAMLlocal1 (v);
-
- mlsize_t size = Wosize_val (obj);
- if (size < 2) caml_failwith ("Ancient.detach: not an attached object");
+ CAMLparam2 (mdv, keyv);
+ CAMLlocal1 (proxy);
- v = Field (obj, 0);
- if (Is_long (v)) caml_invalid_argument ("detached");
+ void *md = (void *) Field (mdv, 0);
+ int key = Int_val (keyv);
- void *md = (void *) Field (obj, 1);
- if (mmalloc_detach (md) != 0) {
- perror ("mmalloc_detach");
- caml_failwith ("mmalloc_detach");
- }
+ void *ptr = mmalloc_getkey (md, key);
+ if (!ptr) caml_raise_not_found ();
- // Replace the proxy (a pointer) with an int 0 so we know it's
- // been detached in future.
- Field (obj, 0) = Val_long (0);
+ // Return the proxy.
+ proxy = caml_alloc (1, Abstract_tag);
+ Field (proxy, 0) = (value) ptr;
- CAMLreturn (Val_unit);
+ CAMLreturn (proxy);
}