Documentation notes update/.

[ocaml-ancient.git] / ancient_c.c

diff --git a/ancient_c.c b/ancient_c.c
index 95383be..ea2ca55 100644 (file)
--- 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.8 2006-10-09 12:18:05 rich Exp $
+ * $Id: ancient_c.c,v 1.10 2006-10-13 12:28:20 rich Exp $
  */
 
 #include <string.h>
@@ -210,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);
@@ -264,9 +265,10 @@ do_fixups (area *ptr, area *fixups)
 
 static void *
 mark (value obj,
-        void *(*realloc)(void *data, void *ptr, size_t size),
-        void (*free)(void *data, void *ptr),
-        void *data)
+      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);
@@ -294,6 +296,7 @@ mark (value obj,
   do_fixups (&ptr, &fixups);
   area_free (&fixups);
 
+  if (r_size) *r_size = ptr.size;
   return ptr.ptr;
 }
 
@@ -310,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 = 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
@@ -369,6 +381,18 @@ ancient_is_ancient (value obj)
 }
 
 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);
@@ -403,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;
+  }
 
-  void *ptr = mark (obj, mrealloc, mfree, md);
+  // 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;
+  }
 
-  mmalloc_setkey (md, key, ptr);
+  // Do the mark.
+  size_t size;
+  void *ptr = mark (obj, mrealloc, mfree, md, &size);
 
-  // Return the proxy.
+  // Add the key to the keytable.
+  keytable->keys[key] = ptr;
+
+  // 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
@@ -437,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);