# 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
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
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 \
ocamlfind ocamlopt $(OCAMLOPTFLAGS) $(OCAMLOPTPACKAGES) $(OCAMLOPTLIBS) -o $@ $^
endif
+# Build the mmalloc library.
+
+mmalloc:
+ $(MAKE) -C mmalloc
+
# Common rules for building OCaml objects.
.mli.cmi:
clean:
rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so *~ core META *.opt
+ $(MAKE) -C mmalloc clean
# Dependencies.
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
(** 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
*
* 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.
+ *)
/* 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 <string.h>
#include <caml/mlvalues.h>
#include <caml/fail.h>
+#include "mmalloc/mmalloc.h"
+
// From byterun/misc.h:
typedef char * addr;
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
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
{
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);
{
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.
}
}
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;
}
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
}
}
-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.
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");
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)
{
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);
+}
git.annexia.org / ocaml-ancient.git / commitdiff