fb69881d30ad09ae9cda4d26a512b3d21d9fc707
[ocaml-ancient.git] / ancient_c.c
1 /* Mark objects as 'ancient' so they are taken out of the OCaml heap.
2  * $Id: ancient_c.c,v 1.3 2006-09-27 15:36:18 rich Exp $
3  */
4
5 #include <string.h>
6 #include <assert.h>
7
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>
13
14 #include "mmalloc/mmalloc.h"
15
16 // From byterun/misc.h:
17 typedef char * addr;
18
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)
25
26 // From byterun/major_gc.h:
27 #ifdef __alpha
28 typedef int page_table_entry;
29 #else
30 typedef char page_table_entry;
31 #endif
32 CAMLextern char *caml_heap_start;
33 CAMLextern char *caml_heap_end;
34 CAMLextern page_table_entry *caml_page_table;
35 extern asize_t caml_page_low, caml_page_high;
36
37 #define In_heap 1
38 #define Not_in_heap 0
39 #define Page(p) ((uintnat) (p) >> Page_log)
40 #define Is_in_heap(p) \
41   (assert (Is_block ((value) (p))),                                     \
42    (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
43    && caml_page_table [Page (p)])
44
45 // Area is an expandable buffer, allocated on the C heap.
46 typedef struct area {
47   void *ptr;                    // Start of area.
48   size_t n;                     // Current position.
49   size_t size;                  // Allocated size.
50
51   // If this area requires custom realloc function, these will be non-null.
52   void *(*realloc)(void *data, void *ptr, size_t size);
53   void (*free)(void *data, void *ptr);
54   void *data;
55 } area;
56
57 static inline void
58 area_init (area *a)
59 {
60   a->ptr = 0;
61   a->n =
62   a->size = 0;
63   a->realloc = 0;
64   a->free = 0;
65   a->data = 0;
66 }
67
68 static inline void
69 area_init_custom (area *a,
70                   void *(*realloc)(void *data, void *ptr, size_t size),
71                   void (*free)(void *data, void *ptr),
72                   void *data)
73 {
74   area_init (a);
75   a->realloc = realloc;
76   a->free = free;
77   a->data = data;
78 }
79
80 static inline int
81 area_append (area *a, const void *obj, size_t size)
82 {
83   while (a->n + size > a->size) {
84     if (a->size == 0) a->size = 256; else a->size <<= 1;
85     a->ptr =
86       a->realloc
87       ? a->realloc (a->data, a->ptr, a->size)
88       : realloc (a->ptr, a->size);
89     if (a->ptr == 0) return -1; // Out of memory.
90   }
91   memcpy (a->ptr + a->n, obj, size);
92   a->n += size;
93   return 0;
94 }
95
96 static inline void
97 area_shrink (area *a)
98 {
99   if (a->n != a->size) {
100     a->size = a->n;
101     a->ptr =
102       a->realloc
103       ? a->realloc (a->data, a->ptr, a->size)
104       : realloc (a->ptr, a->size);
105     assert (a->ptr); // Getting smaller, so shouldn't really fail.
106   }
107 }
108
109 static inline void
110 area_free (area *a)
111 {
112   if (a->free) a->free (a->data, a->ptr);
113   else free (a->ptr);
114   a->n =
115   a->size = 0;
116 }
117
118 struct restore_item {
119   char *header;
120   value field_zero;
121 };
122
123 // When a block is visited, we overwrite the header with all 1's.
124 // This is not quite an impossible value - one could imagine an
125 // enormous custom block where the header could take on this
126 // value. (XXX)
127 static header_t visited = (unsigned long) -1;
128
129 // The general plan here:
130 //
131 // 1. Starting at [obj], copy it to our out-of-heap memory area
132 // defined by [ptr].
133 // 2. Recursively visit subnodes of [obj] and do the same.
134 // 3. As we copy each object, we avoid circularity by setting that
135 // object's header to a special 'visited' value.  However since these
136 // are objects in the Caml heap we have to restore the original
137 // headers at the end, which is the purpose of the [restore] area.
138 // 4. We use realloc to allocate the memory for the copy, but because
139 // the memory can move around, we cannot store absolute pointers.
140 // Instead we store offsets and fix them up later.  This is the
141 // purpose of the [fixups] area.
142 //
143 // XXX Large, deeply recursive structures cause a stack overflow.
144 // Temporary solution: 'ulimit -s unlimited'.  This function should
145 // be replaced with something iterative.
146 static size_t
147 mark (value obj, area *ptr, area *restore, area *fixups)
148 {
149   char *header = Hp_val (obj);
150   assert (Wosize_hp (header) > 0); // Always true? (XXX)
151
152   // XXX This assertion might fail if someone tries to mark an object
153   // which is already ancient.
154   assert (Is_young (obj) || Is_in_heap (obj));
155
156   // If we've already visited this object, just return its offset
157   // in the out-of-heap memory.
158   if (memcmp (header, &visited, sizeof visited) == 0)
159     return (Long_val (Field (obj, 0)));
160
161   // Offset where we will store this object in the out-of-heap memory.
162   size_t offset = ptr->n;
163
164   // Copy the object out of the OCaml heap.
165   size_t bytes = Bhsize_hp (header);
166   if (area_append (ptr, header, bytes) == -1)
167     return -1;                  // Error out of memory.
168
169   // Scan the fields looking for pointers to blocks.
170   int can_scan = Tag_val (obj) < No_scan_tag;
171   if (can_scan) {
172     mlsize_t nr_words = Wosize_hp (header);
173     mlsize_t i;
174
175     for (i = 0; i < nr_words; ++i) {
176       value field = Field (obj, i);
177
178       if (Is_block (field) &&
179           (Is_young (field) || Is_in_heap (field))) {
180         size_t field_offset = mark (field, ptr, restore, fixups);
181         if (field_offset == -1) return -1; // Propagate out of memory errors.
182
183         // Since the recursive call to mark above can reallocate the
184         // area, we need to recompute these each time round the loop.
185         char *obj_copy_header = ptr->ptr + offset;
186         value obj_copy = Val_hp (obj_copy_header);
187
188         // Don't store absolute pointers yet because realloc will
189         // move the memory around.  Store a fake pointer instead.
190         // We'll fix up these fake pointers afterwards.
191         Field (obj_copy, i) = field_offset + sizeof (header_t);
192
193         size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
194         area_append (fixups, &fixup, sizeof fixup);
195       }
196     }
197   }
198
199   // Mark this object as having been "visited", but keep track of
200   // what was there before so it can be restored.  We also need to
201   // record the offset.
202   // Observations:
203   // (1) What was in the header before is kept in the out-of-heap
204   // copy, so we don't explicitly need to remember that.
205   // (2) We can keep the offset in the zeroth field, but since
206   // the code above might have modified the copy, we need to remember
207   // what was in that field before.
208   // (3) We can overwrite the header with all 1's to indicate that
209   // we've visited (but see notes on 'static header_t visited' above).
210   // (4) All objects in OCaml are at least one word long (we hope!).
211   struct restore_item restore_item;
212   restore_item.header = header;
213   restore_item.field_zero = Field (obj, 0);
214   area_append (restore, &restore_item, sizeof restore_item);
215
216   memcpy (header, (void *)&visited, sizeof visited);
217   Field (obj, 0) = Val_long (offset);
218
219   return offset;
220 }
221
222 // See comments immediately above.
223 static void
224 do_restore (area *ptr, area *restore)
225 {
226   mlsize_t i;
227   for (i = 0; i < restore->n; i += sizeof (struct restore_item))
228     {
229       struct restore_item *restore_item =
230         (struct restore_item *)(restore->ptr + i);
231       assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
232
233       value obj = Val_hp (restore_item->header);
234       size_t offset = Long_val (Field (obj, 0));
235
236       char *obj_copy_header = ptr->ptr + offset;
237       //value obj_copy = Val_hp (obj_copy_header);
238
239       // Restore the original header.
240       memcpy (restore_item->header, obj_copy_header, sizeof visited);
241
242       // Restore the original zeroth field.
243       Field (obj, 0) = restore_item->field_zero;
244     }
245 }
246
247 // Fixup fake pointers.
248 static void
249 do_fixups (area *ptr, area *fixups)
250 {
251   long i;
252
253   for (i = 0; i < fixups->n; i += sizeof (size_t))
254     {
255       size_t fixup = *(size_t *)(fixups->ptr + i);
256       size_t offset = *(size_t *)(ptr->ptr + fixup);
257       void *real_ptr = ptr->ptr + offset;
258       *(value *)(ptr->ptr + fixup) = (value) real_ptr;
259     }
260 }
261
262 static CAMLprim value
263 do_mark (value obj,
264          void *(*realloc)(void *data, void *ptr, size_t size),
265          void (*free)(void *data, void *ptr),
266          void *data)
267 {
268   CAMLparam1 (obj);
269   CAMLlocal1 (proxy);
270
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.
276   area_init (&fixups);
277
278   if (mark (obj, &ptr, &restore, &fixups) == -1) {
279     // Ran out of memory.  Recover and throw an exception.
280     area_free (&fixups);
281     do_restore (&ptr, &restore);
282     area_free (&restore);
283     area_free (&ptr);
284     caml_failwith ("out of memory");
285   }
286   area_shrink (&ptr);
287
288   // Restore Caml heap structures.
289   do_restore (&ptr, &restore);
290   area_free (&restore);
291
292   // Update all fake pointers in the out of heap area to make them real
293   // pointers.
294   do_fixups (&ptr, &fixups);
295   area_free (&fixups);
296
297   // Replace obj with a proxy.
298   proxy = caml_alloc (1, Abstract_tag);
299   Field (proxy, 0) = (value) ptr.ptr;
300
301   CAMLreturn (proxy);
302 }
303
304 static void *
305 my_realloc (void *data __attribute__((unused)), void *ptr, size_t size)
306 {
307   return realloc (ptr, size);
308 }
309
310 static void
311 my_free (void *data __attribute__((unused)), void *ptr)
312 {
313   return free (ptr);
314 }
315
316 CAMLprim value
317 ancient_mark (value obj)
318 {
319   CAMLparam1 (obj);
320   CAMLlocal1 (proxy);
321
322   proxy = do_mark (obj, my_realloc, my_free, 0);
323
324   CAMLreturn (proxy);
325 }
326
327 CAMLprim value
328 ancient_follow (value obj)
329 {
330   CAMLparam1 (obj);
331   CAMLlocal1 (v);
332
333   v = Field (obj, 0);
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.
336
337   CAMLreturn (v);
338 }
339
340 CAMLprim value
341 ancient_delete (value obj)
342 {
343   CAMLparam1 (obj);
344   CAMLlocal1 (v);
345
346   v = Field (obj, 0);
347   if (Is_long (v)) caml_invalid_argument ("deleted");
348
349   // Otherwise v is a pointer to the out of heap malloc'd object.
350   assert (!Is_young (v) && !Is_in_heap (v));
351   free ((void *) v);
352
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);
356
357   CAMLreturn (Val_unit);
358 }
359
360 CAMLprim value
361 ancient_share (value fdv, value obj)
362 {
363   CAMLparam2 (fdv, obj);
364   CAMLlocal1 (proxy);
365
366   int fd = Int_val (fd);
367   void *md = mmalloc_attach (fd, 0);
368   if (md == 0) {
369     perror ("mmalloc_attach");
370     caml_failwith ("mmalloc_attach");
371   }
372
373   proxy = do_mark (obj, mrealloc, mfree, md);
374
375   // Save the address of the object within the mmalloc area.  We need
376   // it when attaching.
377   mmalloc_setkey (md, 0, (void *) Field (proxy, 0));
378
379   CAMLreturn (proxy);
380 }
381
382 CAMLprim value
383 ancient_attach (value fdv)
384 {
385   CAMLparam1 (fdv);
386   CAMLlocal1 (proxy);
387
388   int fd = Int_val (fd);
389   void *md = mmalloc_attach (fd, 0);
390   if (md == 0) {
391     perror ("mmalloc_attach");
392     caml_failwith ("mmalloc_attach");
393   }
394
395   proxy = caml_alloc (2, Abstract_tag);
396   Field (proxy, 0) = (value) mmalloc_getkey (md, 0);
397   Field (proxy, 1) = (value) md;
398
399   CAMLreturn (proxy);
400 }
401
402 CAMLprim value
403 ancient_detach (value obj)
404 {
405   CAMLparam1 (obj);
406   CAMLlocal1 (v);
407
408   int size = Wosize_val (obj);
409   if (size < 2) caml_failwith ("Ancient.detach: not an attached object");
410
411   v = Field (obj, 0);
412   if (Is_long (v)) caml_invalid_argument ("detached");
413
414   void *md = (void *) Field (obj, 1);
415   if (mmalloc_detach (md) != 0) {
416     perror ("mmalloc_detach");
417     caml_failwith ("mmalloc_detach");
418   }
419
420   // Replace the proxy (a pointer) with an int 0 so we know it's
421   // been detached in future.
422   Field (obj, 0) = Val_long (0);
423
424   CAMLreturn (Val_unit);
425 }