1 /* Mark objects as 'ancient' so they are taken out of the OCaml heap.
2 * $Id: ancient_c.c,v 1.8 2006-10-09 12:18:05 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 // From byterun/misc.h:
19 // From byterun/minor_gc.c:
20 CAMLextern char *caml_young_start;
21 CAMLextern char *caml_young_end;
22 #define Is_young(val) \
23 (assert (Is_block (val)), \
24 (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start)
26 // From byterun/major_gc.h:
28 typedef int page_table_entry;
30 typedef char page_table_entry;
32 CAMLextern char *caml_heap_start;
33 CAMLextern char *caml_heap_end;
34 CAMLextern page_table_entry *caml_page_table;
38 #define Page(p) ((uintnat) (p) >> Page_log)
39 #define Is_in_heap(p) \
40 (assert (Is_block ((value) (p))), \
41 (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
42 && caml_page_table [Page (p)])
44 // Area is an expandable buffer, allocated on the C heap.
46 void *ptr; // Start of area.
47 size_t n; // Current position.
48 size_t size; // Allocated size.
50 // If this area requires custom realloc function, these will be non-null.
51 void *(*realloc)(void *data, void *ptr, size_t size);
52 void (*free)(void *data, void *ptr);
68 area_init_custom (area *a,
69 void *(*realloc)(void *data, void *ptr, size_t size),
70 void (*free)(void *data, void *ptr),
80 area_append (area *a, const void *obj, size_t size)
82 while (a->n + size > a->size) {
83 if (a->size == 0) a->size = 256; else a->size <<= 1;
86 ? a->realloc (a->data, a->ptr, a->size)
87 : realloc (a->ptr, a->size);
88 if (a->ptr == 0) return -1; // Out of memory.
90 memcpy (a->ptr + a->n, obj, size);
98 if (a->n != a->size) {
102 ? a->realloc (a->data, a->ptr, a->size)
103 : realloc (a->ptr, a->size);
104 assert (a->ptr); // Getting smaller, so shouldn't really fail.
111 if (a->free) a->free (a->data, a->ptr);
117 struct restore_item {
122 // When a block is visited, we overwrite the header with all 1's.
123 // This is not quite an impossible value - one could imagine an
124 // enormous custom block where the header could take on this
126 static header_t visited = (unsigned long) -1;
128 // The general plan here:
130 // 1. Starting at [obj], copy it to our out-of-heap memory area
132 // 2. Recursively visit subnodes of [obj] and do the same.
133 // 3. As we copy each object, we avoid circularity by setting that
134 // object's header to a special 'visited' value. However since these
135 // are objects in the Caml heap we have to restore the original
136 // headers at the end, which is the purpose of the [restore] area.
137 // 4. We use realloc to allocate the memory for the copy, but because
138 // the memory can move around, we cannot store absolute pointers.
139 // Instead we store offsets and fix them up later. This is the
140 // purpose of the [fixups] area.
142 // XXX Large, deeply recursive structures cause a stack overflow.
143 // Temporary solution: 'ulimit -s unlimited'. This function should
144 // be replaced with something iterative.
146 _mark (value obj, area *ptr, area *restore, area *fixups)
148 // XXX This assertion might fail if someone tries to mark an object
149 // which is already ancient.
150 assert (Is_young (obj) || Is_in_heap (obj));
152 char *header = Hp_val (obj);
154 // If we've already visited this object, just return its offset
155 // in the out-of-heap memory.
156 if (memcmp (header, &visited, sizeof visited) == 0)
157 return (Long_val (Field (obj, 0)));
159 // XXX Actually this fails if you try to persist a zero-length
160 // array. Needs to be fixed, but it breaks some rather important
162 assert (Wosize_hp (header) > 0);
164 // Offset where we will store this object in the out-of-heap memory.
165 size_t offset = ptr->n;
167 // Copy the object out of the OCaml heap.
168 size_t bytes = Bhsize_hp (header);
169 if (area_append (ptr, header, bytes) == -1)
170 return -1; // Error out of memory.
172 // Scan the fields looking for pointers to blocks.
173 int can_scan = Tag_val (obj) < No_scan_tag;
175 mlsize_t nr_words = Wosize_hp (header);
178 for (i = 0; i < nr_words; ++i) {
179 value field = Field (obj, i);
181 if (Is_block (field) &&
182 (Is_young (field) || Is_in_heap (field))) {
183 size_t field_offset = _mark (field, ptr, restore, fixups);
184 if (field_offset == -1) return -1; // Propagate out of memory errors.
186 // Since the recursive call to mark above can reallocate the
187 // area, we need to recompute these each time round the loop.
188 char *obj_copy_header = ptr->ptr + offset;
189 value obj_copy = Val_hp (obj_copy_header);
191 // Don't store absolute pointers yet because realloc will
192 // move the memory around. Store a fake pointer instead.
193 // We'll fix up these fake pointers afterwards in do_fixups.
194 Field (obj_copy, i) = field_offset + sizeof (header_t);
196 size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
197 area_append (fixups, &fixup, sizeof fixup);
202 // Mark this object as having been "visited", but keep track of
203 // what was there before so it can be restored. We also need to
204 // record the offset.
206 // (1) What was in the header before is kept in the out-of-heap
207 // copy, so we don't explicitly need to remember that.
208 // (2) We can keep the offset in the zeroth field, but since
209 // the code above might have modified the copy, we need to remember
210 // what was in that field before.
211 // (3) We can overwrite the header with all 1's to indicate that
212 // we've visited (but see notes on 'static header_t visited' above).
213 // (4) All objects in OCaml are at least one word long (we hope!).
214 struct restore_item restore_item;
215 restore_item.header = header;
216 restore_item.field_zero = Field (obj, 0);
217 area_append (restore, &restore_item, sizeof restore_item);
219 memcpy (header, (void *)&visited, sizeof visited);
220 Field (obj, 0) = Val_long (offset);
225 // See comments immediately above.
227 do_restore (area *ptr, area *restore)
230 for (i = 0; i < restore->n; i += sizeof (struct restore_item))
232 struct restore_item *restore_item =
233 (struct restore_item *)(restore->ptr + i);
234 assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
236 value obj = Val_hp (restore_item->header);
237 size_t offset = Long_val (Field (obj, 0));
239 char *obj_copy_header = ptr->ptr + offset;
240 //value obj_copy = Val_hp (obj_copy_header);
242 // Restore the original header.
243 memcpy (restore_item->header, obj_copy_header, sizeof visited);
245 // Restore the original zeroth field.
246 Field (obj, 0) = restore_item->field_zero;
250 // Fixup fake pointers.
252 do_fixups (area *ptr, area *fixups)
256 for (i = 0; i < fixups->n; i += sizeof (size_t))
258 size_t fixup = *(size_t *)(fixups->ptr + i);
259 size_t offset = *(size_t *)(ptr->ptr + fixup);
260 void *real_ptr = ptr->ptr + offset;
261 *(value *)(ptr->ptr + fixup) = (value) real_ptr;
267 void *(*realloc)(void *data, void *ptr, size_t size),
268 void (*free)(void *data, void *ptr),
271 area ptr; // This will be the out of heap area.
272 area_init_custom (&ptr, realloc, free, data);
273 area restore; // Headers to be fixed up after.
274 area_init (&restore);
275 area fixups; // List of fake pointers to be fixed up.
278 if (_mark (obj, &ptr, &restore, &fixups) == -1) {
279 // Ran out of memory. Recover and throw an exception.
281 do_restore (&ptr, &restore);
282 area_free (&restore);
284 caml_failwith ("out of memory");
288 // Restore Caml heap structures.
289 do_restore (&ptr, &restore);
290 area_free (&restore);
292 // Update all fake pointers in the out of heap area to make them real
294 do_fixups (&ptr, &fixups);
301 my_realloc (void *data __attribute__((unused)), void *ptr, size_t size)
303 return realloc (ptr, size);
307 my_free (void *data __attribute__((unused)), void *ptr)
313 ancient_mark (value obj)
318 void *ptr = mark (obj, my_realloc, my_free, 0);
321 proxy = caml_alloc (1, Abstract_tag);
322 Field (proxy, 0) = (value) ptr;
328 ancient_follow (value obj)
334 if (Is_long (v)) caml_invalid_argument ("deleted");
335 v = Val_hp (v); // v points to the header; make it point to the object.
341 ancient_delete (value obj)
347 if (Is_long (v)) caml_invalid_argument ("deleted");
349 // Otherwise v is a pointer to the out of heap malloc'd object.
350 assert (!Is_young (v) && !Is_in_heap (v));
353 // Replace the proxy (a pointer) with an int 0 so we know it's
354 // been deleted in future.
355 Field (obj, 0) = Val_long (0);
357 CAMLreturn (Val_unit);
361 ancient_is_ancient (value obj)
366 v = Is_young (obj) || Is_in_heap (obj) ? Val_false : Val_true;
372 ancient_attach (value fdv, value baseaddrv)
374 CAMLparam2 (fdv, baseaddrv);
377 int fd = Int_val (fdv);
378 void *baseaddr = (void *) Nativeint_val (baseaddrv);
379 void *md = mmalloc_attach (fd, baseaddr);
381 perror ("mmalloc_attach");
382 caml_failwith ("mmalloc_attach");
385 mdv = caml_alloc (1, Abstract_tag);
386 Field (mdv, 0) = (value) md;
392 ancient_detach (value mdv)
396 void *md = (void *) Field (mdv, 0);
398 if (mmalloc_detach (md) != 0) {
399 perror ("mmalloc_detach");
400 caml_failwith ("mmalloc_detach");
403 CAMLreturn (Val_unit);
407 ancient_share (value mdv, value keyv, value obj)
409 CAMLparam3 (mdv, keyv, obj);
412 void *md = (void *) Field (mdv, 0);
413 int key = Int_val (keyv);
415 // Existing key exists? Free it.
416 void *old_obj = mmalloc_getkey (md, key);
417 if (old_obj != 0) mfree (md, old_obj);
418 mmalloc_setkey (md, key, 0);
420 void *ptr = mark (obj, mrealloc, mfree, md);
422 mmalloc_setkey (md, key, ptr);
425 proxy = caml_alloc (1, Abstract_tag);
426 Field (proxy, 0) = (value) ptr;
432 ancient_get (value mdv, value keyv)
434 CAMLparam2 (mdv, keyv);
437 void *md = (void *) Field (mdv, 0);
438 int key = Int_val (keyv);
440 void *ptr = mmalloc_getkey (md, key);
441 if (!ptr) caml_raise_not_found ();
444 proxy = caml_alloc (1, Abstract_tag);
445 Field (proxy, 0) = (value) ptr;