/* Mark objects as 'ancient' so they are taken out of the OCaml heap.
- * $Id: ancient_c.c,v 1.9 2006-10-09 14:43:00 rich Exp $
*/
#include <string.h>
#include "mmalloc/mmalloc.h"
+// uintnat, intnat only appeared in Caml 3.09.x.
+#if OCAML_VERSION_MAJOR == 3 && OCAML_VERSION_MINOR < 9
+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;
-// From byterun/minor_gc.c:
+// From byterun/minor_gc.h:
CAMLextern char *caml_young_start;
CAMLextern char *caml_young_end;
#define Is_young(val) \
(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.
{
// 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);
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.
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
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);
+}
+
+CAMLprim value
+ancient_address_of (value obj)
+{
+ CAMLparam1 (obj);
+ CAMLlocal1 (v);
+
+ if (Is_block (obj)) v = caml_copy_nativeint ((intnat) obj);
+ else v = caml_copy_nativeint (0);
CAMLreturn (v);
}
CAMLreturn (Val_unit);
}
+struct keytable {
+ void **keys;
+ int allocated;
+};
+
CAMLprim value
ancient_share_info (value mdv, value keyv, value obj)
{
void *md = (void *) Field (mdv, 0);
int key = Int_val (keyv);
+ // Get the key table.
+ struct keytable *keytable = mmalloc_getkey (md, 0);
+ if (keytable == 0) {
+ keytable = mmalloc (md, sizeof (struct keytable));
+ if (keytable == 0) caml_failwith ("out of memory");
+ keytable->keys = 0;
+ keytable->allocated = 0;
+ mmalloc_setkey (md, 0, keytable);
+ }
+
// 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);
+ if (key < keytable->allocated && keytable->keys[key] != 0) {
+ mfree (md, keytable->keys[key]);
+ keytable->keys[key] = 0;
+ }
+
+ // Keytable large enough? If not, realloc it.
+ if (key >= keytable->allocated) {
+ int allocated = keytable->allocated == 0 ? 32 : keytable->allocated * 2;
+ void **keys = mrealloc (md, keytable->keys, allocated * sizeof (void *));
+ if (keys == 0) caml_failwith ("out of memory");
+ int i;
+ for (i = keytable->allocated; i < allocated; ++i) keys[i] = 0;
+ keytable->keys = keys;
+ keytable->allocated = allocated;
+ }
+ // Do the mark.
size_t size;
void *ptr = mark (obj, mrealloc, mfree, md, &size);
- mmalloc_setkey (md, key, ptr);
+ // Add the key to the keytable.
+ keytable->keys[key] = ptr;
// Make the proxy.
proxy = caml_alloc (1, Abstract_tag);
void *md = (void *) Field (mdv, 0);
int key = Int_val (keyv);
- void *ptr = mmalloc_getkey (md, key);
- if (!ptr) caml_raise_not_found ();
+ // Key exists?
+ struct keytable *keytable = mmalloc_getkey (md, 0);
+ if (keytable == 0 || key >= keytable->allocated || keytable->keys[key] == 0)
+ caml_raise_not_found ();
+ void *ptr = keytable->keys[key];
// Return the proxy.
proxy = caml_alloc (1, Abstract_tag);