X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=ancient_c.c;h=d5b11af7bcecb7316da087d55cec1b1116b1921a;hb=b082c2b2bd7990ed0cfaa07f18aae9597c5a6892;hp=e00b0089d321e9fa388fbe10a287923ee08cff06;hpb=792c2793cfc5591bad16cf6972dfa9afaf3fe56e;p=ocaml-ancient.git diff --git a/ancient_c.c b/ancient_c.c index e00b008..d5b11af 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.9 2006-10-09 14:43:00 rich Exp $ */ #include @@ -13,10 +12,24 @@ #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) \ @@ -41,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. @@ -147,7 +201,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); @@ -179,7 +233,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. @@ -359,7 +413,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 @@ -375,7 +429,19 @@ 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); +} + +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); } @@ -415,6 +481,11 @@ ancient_detach (value mdv) CAMLreturn (Val_unit); } +struct keytable { + void **keys; + int allocated; +}; + CAMLprim value ancient_share_info (value mdv, value keyv, value obj) { @@ -424,15 +495,39 @@ 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); @@ -458,8 +553,11 @@ ancient_get (value mdv, value keyv) 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);