1 /* Mark objects as 'ancient' so they are taken out of the OCaml heap.
2 * $Id: ancient_c.c,v 1.1 2006-09-27 12:07:07 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 // From byterun/misc.h:
17 // From byterun/major_gc.h:
19 typedef int page_table_entry;
21 typedef char page_table_entry;
23 CAMLextern char *caml_heap_start;
24 CAMLextern char *caml_heap_end;
25 CAMLextern page_table_entry *caml_page_table;
26 extern asize_t caml_page_low, caml_page_high;
30 #define Page(p) ((uintnat) (p) >> Page_log)
31 #define Is_in_heap(p) \
32 (assert (Is_block ((value) (p))), \
33 (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
34 && caml_page_table [Page (p)])
36 // Area is an expandable buffer, allocated on the C heap.
38 void *ptr; // Start of area.
39 size_t n; // Current position.
40 size_t size; // Allocated size.
52 area_append (area *a, const void *obj, size_t size)
54 while (a->n + size > a->size) {
55 if (a->size == 0) a->size = 256; else a->size <<= 1;
56 a->ptr = realloc (a->ptr, a->size);
57 if (a->ptr == 0) return -1; // Out of memory.
59 memcpy (a->ptr + a->n, obj, size);
67 if (a->n != a->size) {
69 a->ptr = realloc (a->ptr, a->size);
70 assert (a->ptr); // Getting smaller, so shouldn't really fail.
87 // When a block is visited, we overwrite the header with all 1's.
88 // This is not quite an impossible value - one could imagine an
89 // enormous custom block where the header could take on this
91 static header_t visited = (unsigned long) -1;
93 // The general plan here:
95 // 1. Starting at [obj], copy it to our out-of-heap memory area
97 // 2. Recursively visit subnodes of [obj] and do the same.
98 // 3. As we copy each object, we avoid circularity by setting that
99 // object's header to a special 'visited' value. However since these
100 // are objects in the Caml heap we have to restore the original
101 // headers at the end, which is the purpose of the [restore] area.
103 // XXX Recursive function will probably fall over once we apply it to
104 // large, deeply recursive structures. Should be replaced with something
107 mark (value obj, area *ptr, area *restore)
109 char *header = Hp_val (obj);
110 assert (Wosize_hp (header) > 0); // Always true? (XXX)
112 // We can't handle out-of-heap objects.
113 // XXX Since someone might try to mark an ancient object, they
114 // might get this error, so we should try to do better here.
115 assert (Is_in_heap (obj));
117 // If we've already visited this object, just return its offset
118 // in the out-of-heap memory.
119 if (memcmp (header, &visited, sizeof visited) == 0)
120 return (Long_val (Field (obj, 0)));
122 // Offset where we will store this object in the out-of-heap memory.
123 size_t offset = ptr->n;
125 // Copy the object out of the OCaml heap.
126 size_t bytes = Bhsize_hp (header);
127 if (area_append (ptr, header, bytes) == -1)
128 return -1; // Error out of memory.
130 // Scan the fields looking for pointers to blocks.
131 int can_scan = Tag_val (obj) < No_scan_tag;
133 mlsize_t nr_words = Wosize_hp (header);
136 for (i = 0; i < nr_words; ++i) {
137 value field = Field (obj, i);
139 if (Is_block (field)) {
140 size_t field_offset = mark (field, ptr, restore);
141 if (field_offset == -1) return -1; // Propagate out of memory errors.
143 // Since the recursive call to mark above can reallocate the
144 // area, we need to recompute these each time round the loop.
145 char *obj_copy_header = ptr->ptr + offset;
146 value obj_copy = Val_hp (obj_copy_header);
148 // Don't store absolute pointers yet because realloc will
149 // move the memory around. Store a fake pointer instead.
150 // We'll fix up these fake pointers afterwards.
151 Field (obj_copy, i) = (field_offset + sizeof (header_t)) << 2;
156 // Mark this object as having been "visited", but keep track of
157 // what was there before so it can be restored. We also need to
158 // record the offset.
160 // (1) What was in the header before is kept in the out-of-heap
161 // copy, so we don't explicitly need to remember that.
162 // (2) We can keep the offset in the zeroth field, but since
163 // the code above might have modified the copy, we need to remember
164 // what was in that field before.
165 // (3) We can overwrite the header with all 1's to indicate that
166 // we've visited (but see notes on 'static header_t visited' above).
167 // (4) All objects in OCaml are at least one word long (we hope!).
168 struct restore_item restore_item;
169 restore_item.header = header;
170 restore_item.field_zero = Field (obj, 0);
171 area_append (restore, &restore_item, sizeof restore_item);
173 memcpy (header, (void *)&visited, sizeof visited);
174 Field (obj, 0) = Val_long (offset);
179 // See comments immediately above.
181 do_restore (area *ptr, area *restore)
184 for (i = 0; i < restore->n; i += sizeof (struct restore_item))
186 struct restore_item *restore_item =
187 (struct restore_item *)(restore->ptr + i);
188 assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
190 value obj = Val_hp (restore_item->header);
191 size_t offset = Long_val (Field (obj, 0));
193 char *obj_copy_header = ptr->ptr + offset;
194 //value obj_copy = Val_hp (obj_copy_header);
196 // Restore the original header.
197 memcpy (restore_item->header, obj_copy_header, sizeof visited);
199 // Restore the original zeroth field.
200 Field (obj, 0) = restore_item->field_zero;
205 ancient_mark (value obj)
210 area ptr; // This will be the out of heap area.
212 area restore; // Headers to be fixed up after.
213 area_init (&restore);
215 if (mark (obj, &ptr, &restore) == -1) {
216 // Ran out of memory. Recover and throw an exception.
217 do_restore (&ptr, &restore);
218 area_free (&restore);
220 caml_failwith ("out of memory");
224 // Restore Caml heap structures.
225 do_restore (&ptr, &restore);
226 area_free (&restore);
228 // Update all fake pointers in the out of heap area to make them real
231 for (i = 0; i < ptr.n; )
233 // Out of heap area is: header, fields, header, fields, ...
234 // The header of each object tells us how many fields it has.
235 char *header = ptr.ptr + i;
236 size_t bytes = Bhsize_hp (header);
237 value obj = Val_hp (header);
239 int can_scan = Tag_val (obj) < No_scan_tag;
241 mlsize_t nr_words = Wosize_hp (header);
244 for (j = 0; j < nr_words; ++j) {
245 value field = Field (obj, j);
247 if (Is_block (field)) {
248 size_t field_offset = field >> 2;
249 void *field_ptr = ptr.ptr + field_offset;
250 Field (obj, j) = (value) field_ptr;
255 i += bytes; // Skip to next object.
258 // Replace obj with a proxy.
259 proxy = caml_alloc (1, Abstract_tag);
260 Field (proxy, 0) = (value) ptr.ptr;
266 ancient_follow (value obj)
272 if (Is_long (v)) caml_invalid_argument ("deleted");
273 v = Val_hp (v); // v points to the header; make it point to the object.
279 ancient_delete (value obj)
285 if (Is_long (v)) caml_invalid_argument ("deleted");
287 // Otherwise v is a pointer to the out of heap malloc'd object.
288 assert (!Is_in_heap (v));
291 // Replace the proxy (a pointer) with an int 0 so we know it's
292 // been deleted in future.
293 Field (obj, 0) = Val_long (0);
295 CAMLreturn (Val_unit);