Fixed the problem with segfaults - actually a bug/limitation in

Linux mmap(2) - mmap was placing the new segment just before
libc with only a tiny bit of headroom, so when the file grew
by gigabytes, it trashed libc and other vital libraries.  Allow
the base address to be specified to get around this.

Don't override standard malloc/free.  Not sure if this makes any
difference, but I'd prefer mmalloc to do its own thing.

Test program now imports whole of Perrys logfiles.

diff --git a/Makefile.config b/Makefile.config
index 3ab3033..9fafcec 100644 (file)
--- 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.3 2006-09-27 18:39:44 rich Exp $
+# $Id: Makefile.config,v 1.4 2006-09-28 12:40:07 rich Exp $
 
 PACKAGE := ancient
-VERSION := 0.0.3
+VERSION := 0.0.4
 
 ifeq ($(shell hostname),oirase)
 TEST_WEBLOGS   := 1

diff --git a/ancient.ml b/ancient.ml
index ab357e2..dfce30c 100644 (file)
--- 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.3 2006-09-27 18:39:44 rich Exp $
+ * $Id: ancient.ml,v 1.4 2006-09-28 12:40:07 rich Exp $
  *)
 
 type 'a ancient
@@ -12,7 +12,7 @@ external delete : 'a ancient -> unit = "ancient_delete"
 
 type md
 
-external attach : Unix.file_descr -> md = "ancient_attach"
+external attach : Unix.file_descr -> nativeint -> md = "ancient_attach"
 
 external detach : md -> unit = "ancient_detach"
 

diff --git a/ancient.mli b/ancient.mli
index 50d6c8a..191447e 100644 (file)
--- 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.3 2006-09-27 18:39:44 rich Exp $
+  * $Id: ancient.mli,v 1.4 2006-09-28 12:40:07 rich Exp $
   *)
 
 type 'a ancient
@@ -35,13 +35,28 @@ val delete : 'a ancient -> unit
 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.
+val attach : Unix.file_descr -> nativeint -> md
+  (** [attach fd baseaddr] 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}.
+    * (for example you could create this using {!Unix.openfile} and
+    * passing the flags [O_RDWR], [O_TRUNC], [O_CREAT]).
+    * One or more objects can then be shared in this file
+    * using {!Unix.share}.
+    *
+    * For new files, [baseaddr] specifies the virtual address to
+    * map the file.  Specifying [Nativeint.zero] ([0n]) here lets [mmap(2)]
+    * choose this, but on some platforms (notably Linux/AMD64)
+    * [mmap] chooses very unwisely, tending to map the memory
+    * just before [libc] with hardly any headroom to grow.  If
+    * you encounter this sort of problem (usually a segfault or
+    * illegal instruction inside libc), then look at [/proc/PID/maps]
+    * and choose a more suitable address.
+    *
+    * If the file was created previously, then the [baseaddr] is
+    * ignored.  The underlying [mmalloc] library will map the
+    * file in at the same place as before.
     *)
 
 val detach : md -> unit
@@ -72,6 +87,9 @@ val share : md -> int -> 'a -> 'a ancient
     * 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.
+    * (Other processes should not even call {!Ancient.get} while
+    * this is happening, but it seems safe to be just reading an
+    * ancient object from the file).
     *)
 
 val get : md -> int -> 'a ancient
@@ -79,7 +97,8 @@ val get : md -> int -> 'a ancient
     * attached file.
     *
     * The key is in the range [0..1023] (the limit is hard-coded in
-    * [mmalloc/mmprivate.h]).
+    * [mmalloc/mmprivate.h]).  If you do not wish to use this feature,
+    * just pass [0] as the key when sharing / getting.
     *
     * You need to annotate the returned object with the correct
     * type.  As with the Marshal module, there is no type checking,

diff --git a/ancient_c.c b/ancient_c.c
index 708a496..a32f776 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.5 2006-09-27 18:39:44 rich Exp $
+ * $Id: ancient_c.c,v 1.6 2006-09-28 12:40:07 rich Exp $
  */
 
 #include <string.h>
@@ -355,13 +355,14 @@ ancient_delete (value obj)
 }
 
 CAMLprim value
-ancient_attach (value fdv)
+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");

diff --git a/mmalloc/mcalloc.c b/mmalloc/mcalloc.c
index c9fcc07..83f5029 100644 (file)
--- a/mmalloc/mcalloc.c
+++ b/mmalloc/mcalloc.c
@@ -39,6 +39,8 @@ mcalloc (md, nmemb, size)
   return (result);
 }
 
+#if 0 // RWMJ
+
 /* When using this package, provide a version of malloc/realloc/free built
    on top of it, so that if we use the default sbrk() region we will not
    collide with another malloc package trying to do the same thing, if
@@ -52,3 +54,5 @@ calloc (nmemb, size)
 {
   return (mcalloc ((PTR) NULL, nmemb, size));
 }
+
+#endif

diff --git a/mmalloc/mfree.c b/mmalloc/mfree.c
index c509ac6..9622afc 100644 (file)
--- a/mmalloc/mfree.c
+++ b/mmalloc/mfree.c
@@ -233,6 +233,8 @@ mfree (md, ptr)
     }
 }
 
+#if 0 // RWMJ
+
 /* When using this package, provide a version of malloc/realloc/free built
    on top of it, so that if we use the default sbrk() region we will not
    collide with another malloc package trying to do the same thing, if
@@ -245,3 +247,5 @@ free (ptr)
 {
   mfree ((PTR) NULL, ptr);
 }
+
+#endif

diff --git a/mmalloc/mmalloc.c b/mmalloc/mmalloc.c
index 7c60fe2..bc10e3a 100644 (file)
--- a/mmalloc/mmalloc.c
+++ b/mmalloc/mmalloc.c
@@ -320,6 +320,8 @@ mmalloc (md, size)
   return (result);
 }
 
+#if 0 // RWMJ
+
 /* When using this package, provide a version of malloc/realloc/free built
    on top of it, so that if we use the default sbrk() region we will not
    collide with another malloc package trying to do the same thing, if
@@ -335,3 +337,5 @@ malloc (size)
   result = mmalloc ((PTR) NULL, size);
   return (result);
 }
+
+#endif

diff --git a/mmalloc/mrealloc.c b/mmalloc/mrealloc.c
index e2004aa..2884760 100644 (file)
--- a/mmalloc/mrealloc.c
+++ b/mmalloc/mrealloc.c
@@ -145,6 +145,8 @@ mrealloc (md, ptr, size)
   return (result);
 }
 
+#if 0 // RWMJ
+
 /* When using this package, provide a version of malloc/realloc/free built
    on top of it, so that if we use the default sbrk() region we will not
    collide with another malloc package trying to do the same thing, if
@@ -161,3 +163,5 @@ realloc (ptr, size)
   result = mrealloc ((PTR) NULL, ptr, size);
   return (result);
 }
+
+#endif

diff --git a/mmalloc/mvalloc.c b/mmalloc/mvalloc.c
index e44942f..035a336 100644 (file)
--- a/mmalloc/mvalloc.c
+++ b/mmalloc/mvalloc.c
@@ -42,9 +42,13 @@ mvalloc (md, size)
 }
 
 
+#if 0 // RWMJ
+
 PTR
 valloc (size)
   size_t size;
 {
   return mvalloc ((PTR) NULL, size);
 }
+
+#endif

diff --git a/test_ancient_shared.ml b/test_ancient_shared.ml
index 81d6623..04b3f1b 100644 (file)
--- 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.2 2006-09-27 18:39:44 rich Exp $
+ * $Id: test_ancient_shared.ml,v 1.3 2006-09-28 12:40:07 rich Exp $
  *)
 
 open Printf
@@ -65,12 +65,15 @@ and string_of_marital_status status =
   | Married -> "Married"
   | Divorced -> "Divorced"
 
+(* XXX Linux/AMD64-specific hack to avoid bad mmap(2) allocation. *)
+let baseaddr = Nativeint.of_string "0x440000000000"
+
 let () =
   match List.tl (Array.to_list Sys.argv) with
   | ["read"; share_filename; print_filename] ->
       (* Read data in filename and print. *)
       let fd = Unix.openfile share_filename [Unix.O_RDWR] 0 in
-      let md = Ancient.attach fd in
+      let md = Ancient.attach fd 0n in
 
       eprintf "After attaching %s ...\n" share_filename;
       gc_compact ();
@@ -111,7 +114,7 @@ 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 md = Ancient.attach fd baseaddr in
 
       ignore (Ancient.share md 0 data);
       eprintf "After sharing data to %s ...\n" share_filename;

diff --git a/test_ancient_weblogs.ml b/test_ancient_weblogs.ml
index 011a6d8..30f1e95 100644 (file)
--- 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.2 2006-09-27 18:39:44 rich Exp $
+ * $Id: test_ancient_weblogs.ml,v 1.3 2006-09-28 12:40:07 rich Exp $
  *)
 
 open Printf
@@ -71,11 +71,14 @@ let files =
 
   files
 
+(* XXX Linux/AMD64-specific hack to avoid bad mmap(2) allocation. *)
+let baseaddr = Nativeint.of_string "0x440000000000"
+
 let md =
   let fd =
     Unix.openfile "test_ancient_weblogs.data"
       [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o644 in
-  Ancient.attach fd
+  Ancient.attach fd baseaddr
 
 (* Load each file into memory and make it ancient. *)
 let () =