From 817742e3a1d5fc8b02d2140a3c74e695ade71434 Mon Sep 17 00:00:00 2001 From: rich Date: Wed, 27 Sep 2006 15:36:18 +0000 Subject: [PATCH] Implemented share/attach/detach; not tested yet - just checking in because there are no regressions with the previous code. --- MANIFEST | 28 ++++++++++ Makefile | 16 ++++-- ancient.ml | 8 ++- ancient.mli | 41 ++++++++++++++- ancient_c.c | 143 ++++++++++++++++++++++++++++++++++++++++++++++++---- mmalloc/Makefile.in | 2 +- 6 files changed, 219 insertions(+), 19 deletions(-) diff --git a/MANIFEST b/MANIFEST index db915e9..2ae48c3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -7,5 +7,33 @@ Makefile Makefile.config MANIFEST META.in +mmalloc/ansidecl.h +mmalloc/attach.c +mmalloc/ChangeLog +mmalloc/configure +mmalloc/configure.in +mmalloc/COPYING.LIB +mmalloc/.cvsignore +mmalloc/detach.c +mmalloc/keys.c +mmalloc/MAINTAINERS +mmalloc/Makefile.in +mmalloc/mcalloc.c +mmalloc/mfree.c +mmalloc/mmalloc.c +mmalloc/mmalloc.h +mmalloc/mmalloc.texi +mmalloc/mmap-sup.c +mmalloc/mm.c +mmalloc/mmcheck.c +mmalloc/mmemalign.c +mmalloc/mmprivate.h +mmalloc/mmstats.c +mmalloc/mmtrace.awk +mmalloc/mmtrace.c +mmalloc/mrealloc.c +mmalloc/mvalloc.c +mmalloc/sbrk-sup.c +mmalloc/TODO test_ancient.ml test_ancient_weblogs.ml diff --git a/Makefile b/Makefile index 9115302..f029f43 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # Mark objects as 'ancient' so they are taken out of the OCaml heap. -# $Id: Makefile,v 1.4 2006-09-27 14:05:07 rich Exp $ +# $Id: Makefile,v 1.5 2006-09-27 15:36:18 rich Exp $ include Makefile.config @@ -24,7 +24,7 @@ OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) OCAMLOPTLIBS := -linkpkg weblogs.cmxa endif -TARGETS := ancient.cma ancient.cmxa META test_ancient.opt +TARGETS := mmalloc ancient.cma ancient.cmxa META test_ancient.opt ifeq ($(TEST_WEBLOGS),1) TARGETS += test_ancient_weblogs.opt @@ -33,10 +33,10 @@ endif all: $(TARGETS) ancient.cma: ancient.cmo ancient_c.o - ocamlmklib -o ancient $^ + ocamlmklib -o ancient -Lmmalloc -lmmalloc $^ ancient.cmxa: ancient.cmx ancient_c.o - ocamlmklib -o ancient $^ + ocamlmklib -o ancient -Lmmalloc -lmmalloc $^ test_ancient.opt: ancient.cmxa test_ancient.cmx LIBRARY_PATH=.:$$LIBRARY_PATH \ @@ -48,6 +48,11 @@ test_ancient_weblogs.opt: ancient.cmxa test_ancient_weblogs.cmx ocamlfind ocamlopt $(OCAMLOPTFLAGS) $(OCAMLOPTPACKAGES) $(OCAMLOPTLIBS) -o $@ $^ endif +# Build the mmalloc library. + +mmalloc: + $(MAKE) -C mmalloc + # Common rules for building OCaml objects. .mli.cmi: @@ -68,6 +73,7 @@ META: META.in Makefile.config clean: rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so *~ core META *.opt + $(MAKE) -C mmalloc clean # Dependencies. @@ -140,6 +146,6 @@ doc: mkdir html -ocamlfind ocamldoc $(OCAMLDOCFLAGS) -d html ancient.ml{i,} -.PHONY: depend dist check-manifest dpkg doc +.PHONY: depend dist check-manifest dpkg doc mmalloc .SUFFIXES: .cmo .cmi .cmx .ml .mli diff --git a/ancient.ml b/ancient.ml index 09e3ee2..e0cd968 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.1 2006-09-27 12:07:07 rich Exp $ + * $Id: ancient.ml,v 1.2 2006-09-27 15:36:18 rich Exp $ *) type 'a ancient @@ -9,3 +9,9 @@ external mark : 'a -> 'a ancient = "ancient_mark" external follow : 'a ancient -> 'a = "ancient_follow" external delete : 'a ancient -> unit = "ancient_delete" + +external share : Unix.file_descr -> 'a -> 'a ancient = "ancient_share" + +external attach : Unix.file_descr -> 'a ancient = "ancient_attach" + +external detach : 'a ancient -> unit = "ancient_detach" diff --git a/ancient.mli b/ancient.mli index 9f574db..8740706 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.1 2006-09-27 12:07:07 rich Exp $ + * $Id: ancient.mli,v 1.2 2006-09-27 15:36:18 rich Exp $ *) type 'a ancient @@ -29,3 +29,42 @@ val delete : 'a ancient -> unit * * Forgetting to delete an ancient object results in a memory leak. *) + +(** {6 Shared memory mappings} *) + +val share : Unix.file_descr -> 'a -> 'a ancient + (** [share fd 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}). + * + * Shared mappings created this way may be shared between + * other OCaml processes which can access the underlying + * file. See {!Ancient.attach}, {!Ancient.detach}. + * + * Do not call {!Ancient.delete} on a mapping created like this. + * Instead, call {!Ancient.detach} and, if necessary, delete the + * underlying file. + *) + +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. + * + * 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. + * + * 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. + * + * @raise [Invalid_argument "detached"] if the object has been detached. + *) diff --git a/ancient_c.c b/ancient_c.c index b39e9d9..fb69881 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.2 2006-09-27 14:05:07 rich Exp $ + * $Id: ancient_c.c,v 1.3 2006-09-27 15:36:18 rich Exp $ */ #include @@ -11,6 +11,8 @@ #include #include +#include "mmalloc/mmalloc.h" + // From byterun/misc.h: typedef char * addr; @@ -45,6 +47,11 @@ typedef struct area { void *ptr; // Start of area. size_t n; // Current position. size_t size; // Allocated size. + + // If this area requires custom realloc function, these will be non-null. + void *(*realloc)(void *data, void *ptr, size_t size); + void (*free)(void *data, void *ptr); + void *data; } area; static inline void @@ -53,6 +60,21 @@ area_init (area *a) a->ptr = 0; a->n = a->size = 0; + a->realloc = 0; + a->free = 0; + a->data = 0; +} + +static inline void +area_init_custom (area *a, + void *(*realloc)(void *data, void *ptr, size_t size), + void (*free)(void *data, void *ptr), + void *data) +{ + area_init (a); + a->realloc = realloc; + a->free = free; + a->data = data; } static inline int @@ -60,7 +82,10 @@ area_append (area *a, const void *obj, size_t size) { while (a->n + size > a->size) { if (a->size == 0) a->size = 256; else a->size <<= 1; - a->ptr = realloc (a->ptr, a->size); + a->ptr = + a->realloc + ? a->realloc (a->data, a->ptr, a->size) + : realloc (a->ptr, a->size); if (a->ptr == 0) return -1; // Out of memory. } memcpy (a->ptr + a->n, obj, size); @@ -73,7 +98,10 @@ area_shrink (area *a) { if (a->n != a->size) { a->size = a->n; - a->ptr = realloc (a->ptr, a->size); + a->ptr = + a->realloc + ? a->realloc (a->data, a->ptr, a->size) + : realloc (a->ptr, a->size); assert (a->ptr); // Getting smaller, so shouldn't really fail. } } @@ -81,7 +109,8 @@ area_shrink (area *a) static inline void area_free (area *a) { - free (a->ptr); + if (a->free) a->free (a->data, a->ptr); + else free (a->ptr); a->n = a->size = 0; } @@ -120,9 +149,8 @@ mark (value obj, area *ptr, area *restore, area *fixups) char *header = Hp_val (obj); assert (Wosize_hp (header) > 0); // Always true? (XXX) - // We can't handle out-of-heap objects. - // XXX Since someone might try to mark an ancient object, they - // might get this error, so we should try to do better here. + // XXX This assertion might fail if someone tries to mark an object + // which is already ancient. assert (Is_young (obj) || Is_in_heap (obj)); // If we've already visited this object, just return its offset @@ -231,14 +259,17 @@ do_fixups (area *ptr, area *fixups) } } -CAMLprim value -ancient_mark (value obj) +static CAMLprim value +do_mark (value obj, + void *(*realloc)(void *data, void *ptr, size_t size), + void (*free)(void *data, void *ptr), + void *data) { CAMLparam1 (obj); CAMLlocal1 (proxy); area ptr; // This will be the out of heap area. - area_init (&ptr); + area_init_custom (&ptr, realloc, free, data); area restore; // Headers to be fixed up after. area_init (&restore); area fixups; // List of fake pointers to be fixed up. @@ -246,8 +277,8 @@ ancient_mark (value obj) if (mark (obj, &ptr, &restore, &fixups) == -1) { // Ran out of memory. Recover and throw an exception. - do_restore (&ptr, &restore); area_free (&fixups); + do_restore (&ptr, &restore); area_free (&restore); area_free (&ptr); caml_failwith ("out of memory"); @@ -270,6 +301,29 @@ ancient_mark (value obj) CAMLreturn (proxy); } +static void * +my_realloc (void *data __attribute__((unused)), void *ptr, size_t size) +{ + return realloc (ptr, size); +} + +static void +my_free (void *data __attribute__((unused)), void *ptr) +{ + return free (ptr); +} + +CAMLprim value +ancient_mark (value obj) +{ + CAMLparam1 (obj); + CAMLlocal1 (proxy); + + proxy = do_mark (obj, my_realloc, my_free, 0); + + CAMLreturn (proxy); +} + CAMLprim value ancient_follow (value obj) { @@ -302,3 +356,70 @@ ancient_delete (value obj) CAMLreturn (Val_unit); } + +CAMLprim value +ancient_share (value fdv, value obj) +{ + CAMLparam2 (fdv, obj); + CAMLlocal1 (proxy); + + int fd = Int_val (fd); + void *md = mmalloc_attach (fd, 0); + if (md == 0) { + perror ("mmalloc_attach"); + caml_failwith ("mmalloc_attach"); + } + + proxy = do_mark (obj, mrealloc, mfree, md); + + // Save the address of the object within the mmalloc area. We need + // it when attaching. + mmalloc_setkey (md, 0, (void *) Field (proxy, 0)); + + CAMLreturn (proxy); +} + +CAMLprim value +ancient_attach (value fdv) +{ + CAMLparam1 (fdv); + CAMLlocal1 (proxy); + + int fd = Int_val (fd); + void *md = mmalloc_attach (fd, 0); + if (md == 0) { + perror ("mmalloc_attach"); + caml_failwith ("mmalloc_attach"); + } + + proxy = caml_alloc (2, Abstract_tag); + Field (proxy, 0) = (value) mmalloc_getkey (md, 0); + Field (proxy, 1) = (value) md; + + CAMLreturn (proxy); +} + +CAMLprim value +ancient_detach (value obj) +{ + CAMLparam1 (obj); + CAMLlocal1 (v); + + int size = Wosize_val (obj); + if (size < 2) caml_failwith ("Ancient.detach: not an attached object"); + + v = Field (obj, 0); + if (Is_long (v)) caml_invalid_argument ("detached"); + + void *md = (void *) Field (obj, 1); + if (mmalloc_detach (md) != 0) { + perror ("mmalloc_detach"); + caml_failwith ("mmalloc_detach"); + } + + // Replace the proxy (a pointer) with an int 0 so we know it's + // been detached in future. + Field (obj, 0) = Val_long (0); + + CAMLreturn (Val_unit); +} diff --git a/mmalloc/Makefile.in b/mmalloc/Makefile.in index b05aea7..b243fed 100644 --- a/mmalloc/Makefile.in +++ b/mmalloc/Makefile.in @@ -54,7 +54,7 @@ INSTALL_DATA = @INSTALL_DATA@ AR = @AR@ AR_FLAGS = qv -CFLAGS = -g +CFLAGS = -g -fPIC MAKEINFO = makeinfo RANLIB = @RANLIB@ RM = rm -- 1.8.3.1