X-Git-Url: http://git.annexia.org/?p=ocaml-ancient.git;a=blobdiff_plain;f=ancient_c.c;h=58735d092eaa363ee84678c1a48acfa1783a529d;hp=8a4e914f1151f48cac10ff84867a184aa2606f7b;hb=HEAD;hpb=d636bf12b0e8a8d6c7f9ad96d24984c24a145930

diff --git a/ancient_c.c b/ancient_c.c
index 8a4e914..58735d0 100644
--- a/ancient_c.c
+++ b/ancient_c.c
@@ -1,5 +1,4 @@
 /* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient_c.c,v 1.11 2006-10-31 14:39:50 rich Exp $
  */
 
 #include <string.h>
@@ -19,6 +18,14 @@ typedef unsigned long uintnat;
 typedef long intnat;
 #endif
 
+/* We need the macro 'Is_in_young_or_heap' which tell us if a block
+ * address is within the OCaml minor or major heaps.  This comes out
+ * of the guts of OCaml.
+ */
+
+#if OCAML_VERSION_MAJOR == 3 && OCAML_VERSION_MINOR <= 10
+// Up to OCaml 3.10 there was a single contiguous page table.
+
 // From byterun/misc.h:
 typedef char * addr;
 
@@ -47,6 +54,47 @@ CAMLextern page_table_entry *caml_page_table;
    (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
    && caml_page_table [Page (p)])
 
+#define Is_in_heap_or_young(p) (Is_young (p) || Is_in_heap (p))
+
+#else /* OCaml >= 3.11 */
+
+// GC was rewritten in OCaml 3.11 so there is no longer a
+// single contiguous page table.
+
+// From byterun/memory.h:
+#define Not_in_heap 0
+#define In_heap 1
+#define In_young 2
+#define In_static_data 4
+#define In_code_area 8
+
+#ifdef ARCH_SIXTYFOUR
+
+/* 64 bits: Represent page table as a sparse hash table */
+int caml_page_table_lookup(void * addr);
+#define Classify_addr(a) (caml_page_table_lookup((void *)(a)))
+
+#else
+
+/* 32 bits: Represent page table as a 2-level array */
+#define Pagetable2_log 11
+#define Pagetable2_size (1 << Pagetable2_log)
+#define Pagetable1_log (Page_log + Pagetable2_log)
+#define Pagetable1_size (1 << (32 - Pagetable1_log))
+CAMLextern unsigned char * caml_page_table[Pagetable1_size];
+
+#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log)
+#define Pagetable_index2(a) \
+  ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1))
+#define Classify_addr(a) \
+  caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)]
+
+#endif
+
+#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young))
+
+#endif /* OCaml >= 3.11 */
+
 // Area is an expandable buffer, allocated on the C heap.
 typedef struct area {
   void *ptr;			// Start of area.
@@ -85,13 +133,15 @@ area_init_custom (area *a,
 static inline int
 area_append (area *a, const void *obj, size_t size)
 {
+  void *ptr;
   while (a->n + size > a->size) {
     if (a->size == 0) a->size = 256; else a->size <<= 1;
-    a->ptr =
+    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.
+    if (ptr == 0) return -1; // Out of memory.
+    a->ptr = ptr;
   }
   memcpy (a->ptr + a->n, obj, size);
   a->n += size;
@@ -153,7 +203,7 @@ _mark (value obj, area *ptr, area *restore, area *fixups)
 {
   // XXX This assertion might fail if someone tries to mark an object
   // which is already ancient.
-  assert (Is_young (obj) || Is_in_heap (obj));
+  assert (Is_in_heap_or_young (obj));
 
   char *header = Hp_val (obj);
 
@@ -185,7 +235,7 @@ _mark (value obj, area *ptr, area *restore, area *fixups)
       value field = Field (obj, i);
 
       if (Is_block (field) &&
-	  (Is_young (field) || Is_in_heap (field))) {
+	  Is_in_heap_or_young (field)) {
 	size_t field_offset = _mark (field, ptr, restore, fixups);
 	if (field_offset == -1) return -1; // Propagate out of memory errors.
 
@@ -365,7 +415,7 @@ ancient_delete (value obj)
   if (Is_long (v)) caml_invalid_argument ("deleted");
 
   // Otherwise v is a pointer to the out of heap malloc'd object.
-  assert (!Is_young (v) && !Is_in_heap (v));
+  assert (!Is_in_heap_or_young (v));
   free ((void *) v);
 
   // Replace the proxy (a pointer) with an int 0 so we know it's
@@ -381,7 +431,7 @@ ancient_is_ancient (value obj)
   CAMLparam1 (obj);
   CAMLlocal1 (v);
 
-  v = Is_young (obj) || Is_in_heap (obj) ? Val_false : Val_true;
+  v = Is_in_heap_or_young (obj) ? Val_false : Val_true;
 
   CAMLreturn (v);
 }