From: rich <rich>
Date: Mon, 9 Oct 2006 14:43:00 +0000 (+0000)
Subject: Added *_info functions, allowing us to get an accurate picture
X-Git-Tag: 0.9.0~12
X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=792c2793cfc5591bad16cf6972dfa9afaf3fe56e;p=ocaml-ancient.git

Added *_info functions, allowing us to get an accurate picture
of how much space is being used by each allocation.
---

diff --git a/ancient.ml b/ancient.ml
index f8b7088..640e0d4 100644
--- a/ancient.ml
+++ b/ancient.ml
@@ -1,10 +1,16 @@
 (* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient.ml,v 1.5 2006-10-09 12:18:05 rich Exp $
+ * $Id: ancient.ml,v 1.6 2006-10-09 14:43:00 rich Exp $
  *)
 
 type 'a ancient
 
-external mark : 'a -> 'a ancient = "ancient_mark"
+type info = {
+  i_size : int;
+}
+
+external mark_info : 'a -> 'a ancient * info = "ancient_mark_info"
+
+let mark obj = fst (mark_info obj)
 
 external follow : 'a ancient -> 'a = "ancient_follow"
 
@@ -18,7 +24,10 @@ external attach : Unix.file_descr -> nativeint -> md = "ancient_attach"
 
 external detach : md -> unit = "ancient_detach"
 
-external share : md -> int -> 'a -> 'a ancient = "ancient_share"
+external share_info : md -> int -> 'a -> 'a ancient * info
+  = "ancient_share_info"
+
+let share md key obj = fst (share_info md key obj)
 
 external get : md -> int -> 'a ancient = "ancient_get"
 
diff --git a/ancient.mli b/ancient.mli
index f77a4b4..37a1cb3 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.6 2006-10-09 12:18:05 rich Exp $
+  * $Id: ancient.mli,v 1.7 2006-10-09 14:43:00 rich Exp $
   *)
 
 type 'a ancient
@@ -115,3 +115,19 @@ val get : md -> int -> 'a ancient
     *)
 
 val max_key : int
+
+(** {6 Additional information} *)
+
+type info = {
+  i_size : int;				(** Allocated size, bytes. *)
+}
+  (** Extra information fields.  See {!Ancient.mark_info} and
+    * {!Ancient.share_info}.
+    *)
+
+val mark_info : 'a -> 'a ancient * info
+  (** Same as {!Ancient.mark}, but also returns some extra information. *)
+
+val share_info : md -> int -> 'a -> 'a ancient * info
+  (** Same as {!Ancient.share}, but also returns some extra information. *)
+
diff --git a/ancient_c.c b/ancient_c.c
index 95383be..e00b008 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.8 2006-10-09 12:18:05 rich Exp $
+ * $Id: ancient_c.c,v 1.9 2006-10-09 14:43:00 rich Exp $
  */
 
 #include <string.h>
@@ -210,7 +210,8 @@ _mark (value obj, area *ptr, area *restore, area *fixups)
   // what was in that field before.
   // (3) We can overwrite the header with all 1's to indicate that
   // we've visited (but see notes on 'static header_t visited' above).
-  // (4) All objects in OCaml are at least one word long (we hope!).
+  // (4) All objects in OCaml are at least one word long (XXX - actually
+  // this is not true).
   struct restore_item restore_item;
   restore_item.header = header;
   restore_item.field_zero = Field (obj, 0);
@@ -264,9 +265,10 @@ do_fixups (area *ptr, area *fixups)
 
 static void *
 mark (value obj,
-	 void *(*realloc)(void *data, void *ptr, size_t size),
-	 void (*free)(void *data, void *ptr),
-	 void *data)
+      void *(*realloc)(void *data, void *ptr, size_t size),
+      void (*free)(void *data, void *ptr),
+      void *data,
+      size_t *r_size)
 {
   area ptr; // This will be the out of heap area.
   area_init_custom (&ptr, realloc, free, data);
@@ -294,6 +296,7 @@ mark (value obj,
   do_fixups (&ptr, &fixups);
   area_free (&fixups);
 
+  if (r_size) *r_size = ptr.size;
   return ptr.ptr;
 }
 
@@ -310,18 +313,27 @@ my_free (void *data __attribute__((unused)), void *ptr)
 }
 
 CAMLprim value
-ancient_mark (value obj)
+ancient_mark_info (value obj)
 {
   CAMLparam1 (obj);
-  CAMLlocal1 (proxy);
+  CAMLlocal3 (proxy, info, rv);
 
-  void *ptr = mark (obj, my_realloc, my_free, 0);
+  size_t size;
+  void *ptr = mark (obj, my_realloc, my_free, 0, &size);
 
-  // Return the proxy.
+  // Make the proxy.
   proxy = caml_alloc (1, Abstract_tag);
   Field (proxy, 0) = (value) ptr;
 
-  CAMLreturn (proxy);
+  // Make the info struct.
+  info = caml_alloc (1, 0);
+  Field (info, 0) = Val_long (size);
+
+  rv = caml_alloc (2, 0);
+  Field (rv, 0) = proxy;
+  Field (rv, 1) = info;
+
+  CAMLreturn (rv);
 }
 
 CAMLprim value
@@ -404,10 +416,10 @@ ancient_detach (value mdv)
 }
 
 CAMLprim value
-ancient_share (value mdv, value keyv, value obj)
+ancient_share_info (value mdv, value keyv, value obj)
 {
   CAMLparam3 (mdv, keyv, obj);
-  CAMLlocal1 (proxy);
+  CAMLlocal3 (proxy, info, rv);
 
   void *md = (void *) Field (mdv, 0);
   int key = Int_val (keyv);
@@ -417,15 +429,24 @@ ancient_share (value mdv, value keyv, value obj)
   if (old_obj != 0) mfree (md, old_obj);
   mmalloc_setkey (md, key, 0);
 
-  void *ptr = mark (obj, mrealloc, mfree, md);
+  size_t size;
+  void *ptr = mark (obj, mrealloc, mfree, md, &size);
 
   mmalloc_setkey (md, key, ptr);
 
-  // Return the proxy.
+  // Make the proxy.
   proxy = caml_alloc (1, Abstract_tag);
   Field (proxy, 0) = (value) ptr;
 
-  CAMLreturn (proxy);
+  // Make the info struct.
+  info = caml_alloc (1, 0);
+  Field (info, 0) = Val_long (size);
+
+  rv = caml_alloc (2, 0);
+  Field (rv, 0) = proxy;
+  Field (rv, 1) = info;
+
+  CAMLreturn (rv);
 }
 
 CAMLprim value