From a34a08d6401b6b67c9d5d1260d816c8ea8b85558 Mon Sep 17 00:00:00 2001 From: rich Date: Wed, 27 Sep 2006 18:39:44 +0000 Subject: [PATCH] Buggy version - can't find the segfault right now. --- .cvsignore | 3 +- Makefile.config | 4 +-- ancient.ml | 12 ++++--- ancient.mli | 64 +++++++++++++++++++++++------------ ancient_c.c | 89 ++++++++++++++++++++++++++----------------------- mmalloc/mmprivate.h | 2 +- test_ancient_shared.ml | 15 ++++++--- test_ancient_weblogs.ml | 31 ++++++++++------- 8 files changed, 132 insertions(+), 88 deletions(-) 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 @@ -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 -- 1.8.3.1