From: rich <rich>
Date: Wed, 27 Sep 2006 18:39:44 +0000 (+0000)
Subject: Buggy version - can't find the segfault right now.
X-Git-Tag: 0.9.0~20
X-Git-Url: http://git.annexia.org/?p=ocaml-ancient.git;a=commitdiff_plain;h=a34a08d6401b6b67c9d5d1260d816c8ea8b85558

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

diff --git a/.cvsignore b/.cvsignore
index dd782b9..3d83ddb 100644
--- a/.cvsignore
+++ b/.cvsignore
@@ -10,4 +10,5 @@ META
 ancient-*.tar.gz
 test_ancient_shared.data
 test_ancient_shared.out1
-test_ancient_shared.out2
\ No newline at end of file
+test_ancient_shared.out2
+test_ancient_weblogs.data
\ No newline at end of file
diff --git a/Makefile.config b/Makefile.config
index 10ba562..3ab3033 100644
--- a/Makefile.config
+++ b/Makefile.config
@@ -1,8 +1,8 @@
 # Mark objects as 'ancient' so they are taken out of the OCaml heap.
-# $Id: Makefile.config,v 1.2 2006-09-27 14:05:07 rich Exp $
+# $Id: Makefile.config,v 1.3 2006-09-27 18:39:44 rich Exp $
 
 PACKAGE := ancient
-VERSION := 0.0.2
+VERSION := 0.0.3
 
 ifeq ($(shell hostname),oirase)
 TEST_WEBLOGS	:= 1
diff --git a/ancient.ml b/ancient.ml
index e0cd968..ab357e2 100644
--- a/ancient.ml
+++ b/ancient.ml
@@ -1,5 +1,5 @@
 (* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient.ml,v 1.2 2006-09-27 15:36:18 rich Exp $
+ * $Id: ancient.ml,v 1.3 2006-09-27 18:39:44 rich Exp $
  *)
 
 type 'a ancient
@@ -10,8 +10,12 @@ external follow : 'a ancient -> 'a = "ancient_follow"
 
 external delete : 'a ancient -> unit = "ancient_delete"
 
-external share : Unix.file_descr -> 'a -> 'a ancient = "ancient_share"
+type md
 
-external attach : Unix.file_descr -> 'a ancient = "ancient_attach"
+external attach : Unix.file_descr -> md = "ancient_attach"
 
-external detach : 'a ancient -> unit = "ancient_detach"
+external detach : md -> unit = "ancient_detach"
+
+external share : md -> int -> 'a -> 'a ancient = "ancient_share"
+
+external get : md -> int -> 'a ancient = "ancient_get"
diff --git a/ancient.mli b/ancient.mli
index 8740706..50d6c8a 100644
--- a/ancient.mli
+++ b/ancient.mli
@@ -1,5 +1,5 @@
 (** Mark objects as 'ancient' so they are taken out of the OCaml heap.
-  * $Id: ancient.mli,v 1.2 2006-09-27 15:36:18 rich Exp $
+  * $Id: ancient.mli,v 1.3 2006-09-27 18:39:44 rich Exp $
   *)
 
 type 'a ancient
@@ -32,39 +32,59 @@ val delete : 'a ancient -> unit
 
 (** {6 Shared memory mappings} *)
 
-val share : Unix.file_descr -> 'a -> 'a ancient
-  (** [share fd obj] does the same as {!Ancient.mark} except
+type md
+  (** Memory descriptor handle. *)
+
+val attach : Unix.file_descr -> md
+  (** [attach fd] attaches to a new or existing file which may contain
+    * shared objects.
+    *
+    * Initially [fd] should be a read/writable, zero-length file
+    * (see {!Unix.openfile}).  One or more objects can then be
+    * shared in this file using {!Unix.share}.
+    *)
+
+val detach : md -> unit
+  (** [detach md] detaches from an existing file, and closes it.
+    *)
+
+val share : md -> int -> 'a -> 'a ancient
+  (** [share md key obj] does the same as {!Ancient.mark} except
     * that instead of copying the object into local memory, it
-    * writes it into memory which is backed by the file [fd].
-    * [fd] should be a writable, zero-length file (see
-    * {!Unix.openfile}).
+    * writes it into memory which is backed by the attached file.
     *
     * Shared mappings created this way may be shared between
     * other OCaml processes which can access the underlying
     * file.  See {!Ancient.attach}, {!Ancient.detach}.
     *
+    * More than one object can be stored in a file.  They are
+    * indexed using integers in the range [0..1023] (the limit
+    * is hard-coded in [mmalloc/mmprivate.h]).  The [key] parameter
+    * controls which object is written/overwritten by [share].
+    * If you do not wish to use this feature, just pass [0]
+    * as the key.
+    *
     * Do not call {!Ancient.delete} on a mapping created like this.
     * Instead, call {!Ancient.detach} and, if necessary, delete the
     * underlying file.
+    *
+    * Caution when sharing files/objects between processes:
+    * The underlying [mmalloc] library does not do any sort of
+    * locking, so all calls to [share] must ensure that they have
+    * exclusive access to the underlying file while in progress.
     *)
 
-val attach : Unix.file_descr -> 'a ancient
-  (** [attach fd] takes an existing file which was created by
-    * {!Ancient.share} and accesses the object contained
-    * in it.
+val get : md -> int -> 'a ancient
+  (** [get md key] returns the object indexed by [key] in the
+    * attached file.
     *
-    * You need to force the return type to be the correct type
-    * for the object contained in the file.  As with Marshal,
-    * the type is not checked, and if it is wrong a segfault
-    * is likely.
+    * The key is in the range [0..1023] (the limit is hard-coded in
+    * [mmalloc/mmprivate.h]).
     *
-    * Do not call {!Ancient.delete} on a mapping created like this.
-    * Instead, call {!Ancient.detach} and, if necessary, delete the
-    * underlying file.
-    *)
-
-val detach : 'a ancient -> unit
-  (** [detach obj] detaches from a shared mapping.
+    * You need to annotate the returned object with the correct
+    * type.  As with the Marshal module, there is no type checking,
+    * and setting the wrong type will likely cause a segfault
+    * or undefined behaviour.
     *
-    * @raise [Invalid_argument "detached"] if the object has been detached.
+    * @raises [Not_found] if no object is associated with the key.
     *)
diff --git a/ancient_c.c b/ancient_c.c
index eb4908e..708a496 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.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);
 }
diff --git a/mmalloc/mmprivate.h b/mmalloc/mmprivate.h
index 4576262..6cf3ad5 100644
--- a/mmalloc/mmprivate.h
+++ b/mmalloc/mmprivate.h
@@ -43,7 +43,7 @@ Boston, MA 02111-1307, USA.
 #define MMALLOC_MAGIC		"mmalloc"	/* Mapped file magic number */
 #define MMALLOC_MAGIC_SIZE	8		/* Size of magic number buf */
 #define MMALLOC_VERSION		1		/* Current mmalloc version */
-#define MMALLOC_KEYS		16		/* Keys for application use */
+#define MMALLOC_KEYS		1024		/* Keys for application use */
 
 /* The allocator divides the heap into blocks of fixed size; large
    requests receive one or more whole blocks, and small requests
diff --git a/test_ancient_shared.ml b/test_ancient_shared.ml
index 7be9712..81d6623 100644
--- a/test_ancient_shared.ml
+++ b/test_ancient_shared.ml
@@ -1,5 +1,5 @@
 (* Very basic tests of Ancient module shared functionality.
- * $Id: test_ancient_shared.ml,v 1.1 2006-09-27 16:01:47 rich Exp $
+ * $Id: test_ancient_shared.ml,v 1.2 2006-09-27 18:39:44 rich Exp $
  *)
 
 open Printf
@@ -70,16 +70,20 @@ let () =
   | ["read"; share_filename; print_filename] ->
       (* Read data in filename and print. *)
       let fd = Unix.openfile share_filename [Unix.O_RDWR] 0 in
-      let data : item array Ancient.ancient = Ancient.attach fd in
+      let md = Ancient.attach fd in
 
       eprintf "After attaching %s ...\n" share_filename;
       gc_compact ();
 
+      let data : item array Ancient.ancient = Ancient.get md 0 in
+      eprintf "After getting ...\n";
+      gc_compact ();
+
       let chan = open_out print_filename in
       output_data chan (Ancient.follow data);
       close_out chan;
 
-      Ancient.detach data;
+      Ancient.detach md;
       eprintf "After detaching ...\n";
       gc_compact ()
 
@@ -107,12 +111,13 @@ let () =
       let fd =
 	Unix.openfile share_filename
 	  [Unix.O_CREAT;Unix.O_TRUNC;Unix.O_RDWR] 0o644 in
+      let md = Ancient.attach fd in
 
-      let data = Ancient.share fd data in
+      ignore (Ancient.share md 0 data);
       eprintf "After sharing data to %s ...\n" share_filename;
       gc_compact ();
 
-      Ancient.detach data;
+      Ancient.detach md;
       eprintf "After detaching ...\n";
       gc_compact ()
 
diff --git a/test_ancient_weblogs.ml b/test_ancient_weblogs.ml
index 946075b..011a6d8 100644
--- a/test_ancient_weblogs.ml
+++ b/test_ancient_weblogs.ml
@@ -1,5 +1,5 @@
 (* Load in large weblogs and see if they can still be used.
- * $Id: test_ancient_weblogs.ml,v 1.1 2006-09-27 14:05:07 rich Exp $
+ * $Id: test_ancient_weblogs.ml,v 1.2 2006-09-27 18:39:44 rich Exp $
  *)
 
 open Printf
@@ -71,18 +71,25 @@ let files =
 
   files
 
+let md =
+  let fd =
+    Unix.openfile "test_ancient_weblogs.data"
+      [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o644 in
+  Ancient.attach fd
+
 (* Load each file into memory and make it ancient. *)
 let () =
-  let files =
-    List.map (
-      fun filename ->
-	eprintf "Importing file %s\n%!" filename;
-	let rows =
-	  let rows = Weblogs.import_file filename in
-	  Ancient.mark rows in
-	gc_compact ();
-	rows
-    ) files in
+  List.iteri (
+    fun key filename ->
+      let () =
+	let basename = Filename.basename filename in
+	eprintf "Importing logfile %s\n%!" basename;
+	let rows = Weblogs.import_file filename in
+	ignore (Ancient.share md key rows) in
+      gc_compact ()
+  ) files;
+
+
 
-  ignore (files)
 
+  Ancient.detach md