X-Git-Url: http://git.annexia.org/?p=ocaml-ancient.git;a=blobdiff_plain;f=ancient_c.c;h=95383be8e7033401ac70a97bfacbe2204c27bf9a;hp=708a49654e625db804d35cf8ad2c1eb569b739f6;hb=2f2d5af5cf03640650c8b49933c36665fdf52d61;hpb=a34a08d6401b6b67c9d5d1260d816c8ea8b85558;ds=sidebyside

diff --git a/ancient_c.c b/ancient_c.c
index 708a496..95383be 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.5 2006-09-27 18:39:44 rich Exp $
+ * $Id: ancient_c.c,v 1.8 2006-10-09 12:18:05 rich Exp $
  */
 
 #include <string.h>
@@ -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;
@@ -260,7 +263,7 @@ do_fixups (area *ptr, area *fixups)
 }
 
 static void *
-do_mark (value obj,
+mark (value obj,
 	 void *(*realloc)(void *data, void *ptr, size_t size),
 	 void (*free)(void *data, void *ptr),
 	 void *data)
@@ -272,7 +275,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);
@@ -312,7 +315,7 @@ ancient_mark (value obj)
   CAMLparam1 (obj);
   CAMLlocal1 (proxy);
 
-  void *ptr = do_mark (obj, my_realloc, my_free, 0);
+  void *ptr = mark (obj, my_realloc, my_free, 0);
 
   // Return the proxy.
   proxy = caml_alloc (1, Abstract_tag);
@@ -355,13 +358,25 @@ ancient_delete (value obj)
 }
 
 CAMLprim value
-ancient_attach (value fdv)
+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_attach (value fdv, value baseaddrv)
 {
-  CAMLparam1 (fdv);
+  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");
@@ -402,7 +417,7 @@ ancient_share (value mdv, value keyv, value obj)
   if (old_obj != 0) mfree (md, old_obj);
   mmalloc_setkey (md, key, 0);
 
-  void *ptr = do_mark (obj, mrealloc, mfree, md);
+  void *ptr = mark (obj, mrealloc, mfree, md);
 
   mmalloc_setkey (md, key, ptr);