1 /* Mark objects as 'ancient' so they are taken out of the OCaml heap.
2 * $Id: ancient_c.c,v 1.11 2006-10-31 14:39:50 rich Exp $
8 #include <caml/config.h>
9 #include <caml/memory.h>
10 #include <caml/alloc.h>
11 #include <caml/mlvalues.h>
12 #include <caml/fail.h>
14 #include "mmalloc/mmalloc.h"
16 // uintnat, intnat only appeared in Caml 3.09.x.
17 #if OCAML_VERSION_MAJOR == 3 && OCAML_VERSION_MINOR < 9
18 typedef unsigned long uintnat;
22 /* We need the macro 'Is_in_young_or_heap' which tell us if a block
23 * address is within the OCaml minor or major heaps. This comes out
24 * of the guts of OCaml.
27 #if OCAML_VERSION_MAJOR == 3 && OCAML_VERSION_MINOR <= 10
28 // Up to OCaml 3.10 there was a single contiguous page table.
30 // From byterun/misc.h:
33 // From byterun/minor_gc.h:
34 CAMLextern char *caml_young_start;
35 CAMLextern char *caml_young_end;
36 #define Is_young(val) \
37 (assert (Is_block (val)), \
38 (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start)
40 // From byterun/major_gc.h:
42 typedef int page_table_entry;
44 typedef char page_table_entry;
46 CAMLextern char *caml_heap_start;
47 CAMLextern char *caml_heap_end;
48 CAMLextern page_table_entry *caml_page_table;
52 #define Page(p) ((uintnat) (p) >> Page_log)
53 #define Is_in_heap(p) \
54 (assert (Is_block ((value) (p))), \
55 (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
56 && caml_page_table [Page (p)])
58 #define Is_in_heap_or_young(p) (Is_young (p) || Is_in_heap (p))
60 #else /* OCaml >= 3.11 */
62 // GC was rewritten in OCaml 3.11 so there is no longer a
63 // single contiguous page table.
65 // From byterun/memory.h:
69 #define In_static_data 4
70 #define In_code_area 8
74 /* 64 bits: Represent page table as a sparse hash table */
75 int caml_page_table_lookup(void * addr);
76 #define Classify_addr(a) (caml_page_table_lookup((void *)(a)))
80 /* 32 bits: Represent page table as a 2-level array */
81 #define Pagetable2_log 11
82 #define Pagetable2_size (1 << Pagetable2_log)
83 #define Pagetable1_log (Page_log + Pagetable2_log)
84 #define Pagetable1_size (1 << (32 - Pagetable1_log))
85 CAMLextern unsigned char * caml_page_table[Pagetable1_size];
87 #define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log)
88 #define Pagetable_index2(a) \
89 ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1))
90 #define Classify_addr(a) \
91 caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)]
95 #define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young))
97 #endif /* OCaml >= 3.11 */
99 // Area is an expandable buffer, allocated on the C heap.
100 typedef struct area {
101 void *ptr; // Start of area.
102 size_t n; // Current position.
103 size_t size; // Allocated size.
105 // If this area requires custom realloc function, these will be non-null.
106 void *(*realloc)(void *data, void *ptr, size_t size);
107 void (*free)(void *data, void *ptr);
123 area_init_custom (area *a,
124 void *(*realloc)(void *data, void *ptr, size_t size),
125 void (*free)(void *data, void *ptr),
129 a->realloc = realloc;
135 area_append (area *a, const void *obj, size_t size)
137 while (a->n + size > a->size) {
138 if (a->size == 0) a->size = 256; else a->size <<= 1;
141 ? a->realloc (a->data, a->ptr, a->size)
142 : realloc (a->ptr, a->size);
143 if (a->ptr == 0) return -1; // Out of memory.
145 memcpy (a->ptr + a->n, obj, size);
151 area_shrink (area *a)
153 if (a->n != a->size) {
157 ? a->realloc (a->data, a->ptr, a->size)
158 : realloc (a->ptr, a->size);
159 assert (a->ptr); // Getting smaller, so shouldn't really fail.
166 if (a->free) a->free (a->data, a->ptr);
172 struct restore_item {
177 // When a block is visited, we overwrite the header with all 1's.
178 // This is not quite an impossible value - one could imagine an
179 // enormous custom block where the header could take on this
181 static header_t visited = (unsigned long) -1;
183 // The general plan here:
185 // 1. Starting at [obj], copy it to our out-of-heap memory area
187 // 2. Recursively visit subnodes of [obj] and do the same.
188 // 3. As we copy each object, we avoid circularity by setting that
189 // object's header to a special 'visited' value. However since these
190 // are objects in the Caml heap we have to restore the original
191 // headers at the end, which is the purpose of the [restore] area.
192 // 4. We use realloc to allocate the memory for the copy, but because
193 // the memory can move around, we cannot store absolute pointers.
194 // Instead we store offsets and fix them up later. This is the
195 // purpose of the [fixups] area.
197 // XXX Large, deeply recursive structures cause a stack overflow.
198 // Temporary solution: 'ulimit -s unlimited'. This function should
199 // be replaced with something iterative.
201 _mark (value obj, area *ptr, area *restore, area *fixups)
203 // XXX This assertion might fail if someone tries to mark an object
204 // which is already ancient.
205 assert (Is_in_heap_or_young (obj));
207 char *header = Hp_val (obj);
209 // If we've already visited this object, just return its offset
210 // in the out-of-heap memory.
211 if (memcmp (header, &visited, sizeof visited) == 0)
212 return (Long_val (Field (obj, 0)));
214 // XXX Actually this fails if you try to persist a zero-length
215 // array. Needs to be fixed, but it breaks some rather important
217 assert (Wosize_hp (header) > 0);
219 // Offset where we will store this object in the out-of-heap memory.
220 size_t offset = ptr->n;
222 // Copy the object out of the OCaml heap.
223 size_t bytes = Bhsize_hp (header);
224 if (area_append (ptr, header, bytes) == -1)
225 return -1; // Error out of memory.
227 // Scan the fields looking for pointers to blocks.
228 int can_scan = Tag_val (obj) < No_scan_tag;
230 mlsize_t nr_words = Wosize_hp (header);
233 for (i = 0; i < nr_words; ++i) {
234 value field = Field (obj, i);
236 if (Is_block (field) &&
237 Is_in_heap_or_young (field)) {
238 size_t field_offset = _mark (field, ptr, restore, fixups);
239 if (field_offset == -1) return -1; // Propagate out of memory errors.
241 // Since the recursive call to mark above can reallocate the
242 // area, we need to recompute these each time round the loop.
243 char *obj_copy_header = ptr->ptr + offset;
244 value obj_copy = Val_hp (obj_copy_header);
246 // Don't store absolute pointers yet because realloc will
247 // move the memory around. Store a fake pointer instead.
248 // We'll fix up these fake pointers afterwards in do_fixups.
249 Field (obj_copy, i) = field_offset + sizeof (header_t);
251 size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
252 area_append (fixups, &fixup, sizeof fixup);
257 // Mark this object as having been "visited", but keep track of
258 // what was there before so it can be restored. We also need to
259 // record the offset.
261 // (1) What was in the header before is kept in the out-of-heap
262 // copy, so we don't explicitly need to remember that.
263 // (2) We can keep the offset in the zeroth field, but since
264 // the code above might have modified the copy, we need to remember
265 // what was in that field before.
266 // (3) We can overwrite the header with all 1's to indicate that
267 // we've visited (but see notes on 'static header_t visited' above).
268 // (4) All objects in OCaml are at least one word long (XXX - actually
269 // this is not true).
270 struct restore_item restore_item;
271 restore_item.header = header;
272 restore_item.field_zero = Field (obj, 0);
273 area_append (restore, &restore_item, sizeof restore_item);
275 memcpy (header, (void *)&visited, sizeof visited);
276 Field (obj, 0) = Val_long (offset);
281 // See comments immediately above.
283 do_restore (area *ptr, area *restore)
286 for (i = 0; i < restore->n; i += sizeof (struct restore_item))
288 struct restore_item *restore_item =
289 (struct restore_item *)(restore->ptr + i);
290 assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
292 value obj = Val_hp (restore_item->header);
293 size_t offset = Long_val (Field (obj, 0));
295 char *obj_copy_header = ptr->ptr + offset;
296 //value obj_copy = Val_hp (obj_copy_header);
298 // Restore the original header.
299 memcpy (restore_item->header, obj_copy_header, sizeof visited);
301 // Restore the original zeroth field.
302 Field (obj, 0) = restore_item->field_zero;
306 // Fixup fake pointers.
308 do_fixups (area *ptr, area *fixups)
312 for (i = 0; i < fixups->n; i += sizeof (size_t))
314 size_t fixup = *(size_t *)(fixups->ptr + i);
315 size_t offset = *(size_t *)(ptr->ptr + fixup);
316 void *real_ptr = ptr->ptr + offset;
317 *(value *)(ptr->ptr + fixup) = (value) real_ptr;
323 void *(*realloc)(void *data, void *ptr, size_t size),
324 void (*free)(void *data, void *ptr),
328 area ptr; // This will be the out of heap area.
329 area_init_custom (&ptr, realloc, free, data);
330 area restore; // Headers to be fixed up after.
331 area_init (&restore);
332 area fixups; // List of fake pointers to be fixed up.
335 if (_mark (obj, &ptr, &restore, &fixups) == -1) {
336 // Ran out of memory. Recover and throw an exception.
338 do_restore (&ptr, &restore);
339 area_free (&restore);
341 caml_failwith ("out of memory");
345 // Restore Caml heap structures.
346 do_restore (&ptr, &restore);
347 area_free (&restore);
349 // Update all fake pointers in the out of heap area to make them real
351 do_fixups (&ptr, &fixups);
354 if (r_size) *r_size = ptr.size;
359 my_realloc (void *data __attribute__((unused)), void *ptr, size_t size)
361 return realloc (ptr, size);
365 my_free (void *data __attribute__((unused)), void *ptr)
371 ancient_mark_info (value obj)
374 CAMLlocal3 (proxy, info, rv);
377 void *ptr = mark (obj, my_realloc, my_free, 0, &size);
380 proxy = caml_alloc (1, Abstract_tag);
381 Field (proxy, 0) = (value) ptr;
383 // Make the info struct.
384 info = caml_alloc (1, 0);
385 Field (info, 0) = Val_long (size);
387 rv = caml_alloc (2, 0);
388 Field (rv, 0) = proxy;
389 Field (rv, 1) = info;
395 ancient_follow (value obj)
401 if (Is_long (v)) caml_invalid_argument ("deleted");
402 v = Val_hp (v); // v points to the header; make it point to the object.
408 ancient_delete (value obj)
414 if (Is_long (v)) caml_invalid_argument ("deleted");
416 // Otherwise v is a pointer to the out of heap malloc'd object.
417 assert (!Is_in_heap_or_young (v));
420 // Replace the proxy (a pointer) with an int 0 so we know it's
421 // been deleted in future.
422 Field (obj, 0) = Val_long (0);
424 CAMLreturn (Val_unit);
428 ancient_is_ancient (value obj)
433 v = Is_in_heap_or_young (obj) ? Val_false : Val_true;
439 ancient_address_of (value obj)
444 if (Is_block (obj)) v = caml_copy_nativeint ((intnat) obj);
445 else v = caml_copy_nativeint (0);
451 ancient_attach (value fdv, value baseaddrv)
453 CAMLparam2 (fdv, baseaddrv);
456 int fd = Int_val (fdv);
457 void *baseaddr = (void *) Nativeint_val (baseaddrv);
458 void *md = mmalloc_attach (fd, baseaddr);
460 perror ("mmalloc_attach");
461 caml_failwith ("mmalloc_attach");
464 mdv = caml_alloc (1, Abstract_tag);
465 Field (mdv, 0) = (value) md;
471 ancient_detach (value mdv)
475 void *md = (void *) Field (mdv, 0);
477 if (mmalloc_detach (md) != 0) {
478 perror ("mmalloc_detach");
479 caml_failwith ("mmalloc_detach");
482 CAMLreturn (Val_unit);
491 ancient_share_info (value mdv, value keyv, value obj)
493 CAMLparam3 (mdv, keyv, obj);
494 CAMLlocal3 (proxy, info, rv);
496 void *md = (void *) Field (mdv, 0);
497 int key = Int_val (keyv);
499 // Get the key table.
500 struct keytable *keytable = mmalloc_getkey (md, 0);
502 keytable = mmalloc (md, sizeof (struct keytable));
503 if (keytable == 0) caml_failwith ("out of memory");
505 keytable->allocated = 0;
506 mmalloc_setkey (md, 0, keytable);
509 // Existing key exists? Free it.
510 if (key < keytable->allocated && keytable->keys[key] != 0) {
511 mfree (md, keytable->keys[key]);
512 keytable->keys[key] = 0;
515 // Keytable large enough? If not, realloc it.
516 if (key >= keytable->allocated) {
517 int allocated = keytable->allocated == 0 ? 32 : keytable->allocated * 2;
518 void **keys = mrealloc (md, keytable->keys, allocated * sizeof (void *));
519 if (keys == 0) caml_failwith ("out of memory");
521 for (i = keytable->allocated; i < allocated; ++i) keys[i] = 0;
522 keytable->keys = keys;
523 keytable->allocated = allocated;
528 void *ptr = mark (obj, mrealloc, mfree, md, &size);
530 // Add the key to the keytable.
531 keytable->keys[key] = ptr;
534 proxy = caml_alloc (1, Abstract_tag);
535 Field (proxy, 0) = (value) ptr;
537 // Make the info struct.
538 info = caml_alloc (1, 0);
539 Field (info, 0) = Val_long (size);
541 rv = caml_alloc (2, 0);
542 Field (rv, 0) = proxy;
543 Field (rv, 1) = info;
549 ancient_get (value mdv, value keyv)
551 CAMLparam2 (mdv, keyv);
554 void *md = (void *) Field (mdv, 0);
555 int key = Int_val (keyv);
558 struct keytable *keytable = mmalloc_getkey (md, 0);
559 if (keytable == 0 || key >= keytable->allocated || keytable->keys[key] == 0)
560 caml_raise_not_found ();
561 void *ptr = keytable->keys[key];
564 proxy = caml_alloc (1, Abstract_tag);
565 Field (proxy, 0) = (value) ptr;