Buggy version - can't find the segfault right now.

[ocaml-ancient.git] / ancient_c.c

diff --git a/ancient_c.c b/ancient_c.c
index eb4908e..708a496 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.4 2006-09-27 16:01:47 rich Exp $
+ * $Id: ancient_c.c,v 1.5 2006-09-27 18:39:44 rich Exp $
  */
 
 #include <string.h>
@@ -314,7 +314,7 @@ ancient_mark (value obj)
 
   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;
 
@@ -355,10 +355,10 @@ ancient_delete (value obj)
 }
 
 CAMLprim value
-ancient_share (value fdv, value obj)
+ancient_attach (value fdv)
 {
-  CAMLparam2 (fdv, obj);
-  CAMLlocal1 (proxy);
+  CAMLparam1 (fdv);
+  CAMLlocal1 (mdv);
 
   int fd = Int_val (fdv);
   void *md = mmalloc_attach (fd, 0);
@@ -367,60 +367,67 @@ ancient_share (value fdv, value obj)
     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);
+
+  void *ptr = do_mark (obj, mrealloc, mfree, md);
 
-  proxy = caml_alloc (2, Abstract_tag);
-  Field (proxy, 0) = (value) mmalloc_getkey (md, 0);
-  Field (proxy, 1) = (value) 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);
 }