Remove the limitation on the number of keys.
[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.10 2006-10-13 12:28:20 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
36 #define In_heap 1
37 #define Not_in_heap 0
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)])
43
44 // Area is an expandable buffer, allocated on the C heap.
45 typedef struct area {
46   void *ptr;                    // Start of area.
47   size_t n;                     // Current position.
48   size_t size;                  // Allocated size.
49
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);
53   void *data;
54 } area;
55
56 static inline void
57 area_init (area *a)
58 {
59   a->ptr = 0;
60   a->n =
61   a->size = 0;
62   a->realloc = 0;
63   a->free = 0;
64   a->data = 0;
65 }
66
67 static inline void
68 area_init_custom (area *a,
69                   void *(*realloc)(void *data, void *ptr, size_t size),
70                   void (*free)(void *data, void *ptr),
71                   void *data)
72 {
73   area_init (a);
74   a->realloc = realloc;
75   a->free = free;
76   a->data = data;
77 }
78
79 static inline int
80 area_append (area *a, const void *obj, size_t size)
81 {
82   while (a->n + size > a->size) {
83     if (a->size == 0) a->size = 256; else a->size <<= 1;
84     a->ptr =
85       a->realloc
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.
89   }
90   memcpy (a->ptr + a->n, obj, size);
91   a->n += size;
92   return 0;
93 }
94
95 static inline void
96 area_shrink (area *a)
97 {
98   if (a->n != a->size) {
99     a->size = a->n;
100     a->ptr =
101       a->realloc
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.
105   }
106 }
107
108 static inline void
109 area_free (area *a)
110 {
111   if (a->free) a->free (a->data, a->ptr);
112   else free (a->ptr);
113   a->n =
114   a->size = 0;
115 }
116
117 struct restore_item {
118   char *header;
119   value field_zero;
120 };
121
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
125 // value. (XXX)
126 static header_t visited = (unsigned long) -1;
127
128 // The general plan here:
129 //
130 // 1. Starting at [obj], copy it to our out-of-heap memory area
131 // defined by [ptr].
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.
141 //
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.
145 static size_t
146 _mark (value obj, area *ptr, area *restore, area *fixups)
147 {
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));
151
152   char *header = Hp_val (obj);
153
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)));
158
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
161   // functions below.
162   assert (Wosize_hp (header) > 0);
163
164   // Offset where we will store this object in the out-of-heap memory.
165   size_t offset = ptr->n;
166
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.
171
172   // Scan the fields looking for pointers to blocks.
173   int can_scan = Tag_val (obj) < No_scan_tag;
174   if (can_scan) {
175     mlsize_t nr_words = Wosize_hp (header);
176     mlsize_t i;
177
178     for (i = 0; i < nr_words; ++i) {
179       value field = Field (obj, i);
180
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.
185
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);
190
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);
195
196         size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
197         area_append (fixups, &fixup, sizeof fixup);
198       }
199     }
200   }
201
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.
205   // Observations:
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 (XXX - actually
214   // this is not true).
215   struct restore_item restore_item;
216   restore_item.header = header;
217   restore_item.field_zero = Field (obj, 0);
218   area_append (restore, &restore_item, sizeof restore_item);
219
220   memcpy (header, (void *)&visited, sizeof visited);
221   Field (obj, 0) = Val_long (offset);
222
223   return offset;
224 }
225
226 // See comments immediately above.
227 static void
228 do_restore (area *ptr, area *restore)
229 {
230   mlsize_t i;
231   for (i = 0; i < restore->n; i += sizeof (struct restore_item))
232     {
233       struct restore_item *restore_item =
234         (struct restore_item *)(restore->ptr + i);
235       assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
236
237       value obj = Val_hp (restore_item->header);
238       size_t offset = Long_val (Field (obj, 0));
239
240       char *obj_copy_header = ptr->ptr + offset;
241       //value obj_copy = Val_hp (obj_copy_header);
242
243       // Restore the original header.
244       memcpy (restore_item->header, obj_copy_header, sizeof visited);
245
246       // Restore the original zeroth field.
247       Field (obj, 0) = restore_item->field_zero;
248     }
249 }
250
251 // Fixup fake pointers.
252 static void
253 do_fixups (area *ptr, area *fixups)
254 {
255   long i;
256
257   for (i = 0; i < fixups->n; i += sizeof (size_t))
258     {
259       size_t fixup = *(size_t *)(fixups->ptr + i);
260       size_t offset = *(size_t *)(ptr->ptr + fixup);
261       void *real_ptr = ptr->ptr + offset;
262       *(value *)(ptr->ptr + fixup) = (value) real_ptr;
263     }
264 }
265
266 static void *
267 mark (value obj,
268       void *(*realloc)(void *data, void *ptr, size_t size),
269       void (*free)(void *data, void *ptr),
270       void *data,
271       size_t *r_size)
272 {
273   area ptr; // This will be the out of heap area.
274   area_init_custom (&ptr, realloc, free, data);
275   area restore; // Headers to be fixed up after.
276   area_init (&restore);
277   area fixups; // List of fake pointers to be fixed up.
278   area_init (&fixups);
279
280   if (_mark (obj, &ptr, &restore, &fixups) == -1) {
281     // Ran out of memory.  Recover and throw an exception.
282     area_free (&fixups);
283     do_restore (&ptr, &restore);
284     area_free (&restore);
285     area_free (&ptr);
286     caml_failwith ("out of memory");
287   }
288   area_shrink (&ptr);
289
290   // Restore Caml heap structures.
291   do_restore (&ptr, &restore);
292   area_free (&restore);
293
294   // Update all fake pointers in the out of heap area to make them real
295   // pointers.
296   do_fixups (&ptr, &fixups);
297   area_free (&fixups);
298
299   if (r_size) *r_size = ptr.size;
300   return ptr.ptr;
301 }
302
303 static void *
304 my_realloc (void *data __attribute__((unused)), void *ptr, size_t size)
305 {
306   return realloc (ptr, size);
307 }
308
309 static void
310 my_free (void *data __attribute__((unused)), void *ptr)
311 {
312   return free (ptr);
313 }
314
315 CAMLprim value
316 ancient_mark_info (value obj)
317 {
318   CAMLparam1 (obj);
319   CAMLlocal3 (proxy, info, rv);
320
321   size_t size;
322   void *ptr = mark (obj, my_realloc, my_free, 0, &size);
323
324   // Make the proxy.
325   proxy = caml_alloc (1, Abstract_tag);
326   Field (proxy, 0) = (value) ptr;
327
328   // Make the info struct.
329   info = caml_alloc (1, 0);
330   Field (info, 0) = Val_long (size);
331
332   rv = caml_alloc (2, 0);
333   Field (rv, 0) = proxy;
334   Field (rv, 1) = info;
335
336   CAMLreturn (rv);
337 }
338
339 CAMLprim value
340 ancient_follow (value obj)
341 {
342   CAMLparam1 (obj);
343   CAMLlocal1 (v);
344
345   v = Field (obj, 0);
346   if (Is_long (v)) caml_invalid_argument ("deleted");
347   v = Val_hp (v); // v points to the header; make it point to the object.
348
349   CAMLreturn (v);
350 }
351
352 CAMLprim value
353 ancient_delete (value obj)
354 {
355   CAMLparam1 (obj);
356   CAMLlocal1 (v);
357
358   v = Field (obj, 0);
359   if (Is_long (v)) caml_invalid_argument ("deleted");
360
361   // Otherwise v is a pointer to the out of heap malloc'd object.
362   assert (!Is_young (v) && !Is_in_heap (v));
363   free ((void *) v);
364
365   // Replace the proxy (a pointer) with an int 0 so we know it's
366   // been deleted in future.
367   Field (obj, 0) = Val_long (0);
368
369   CAMLreturn (Val_unit);
370 }
371
372 CAMLprim value
373 ancient_is_ancient (value obj)
374 {
375   CAMLparam1 (obj);
376   CAMLlocal1 (v);
377
378   v = Is_young (obj) || Is_in_heap (obj) ? Val_false : Val_true;
379
380   CAMLreturn (v);
381 }
382
383 CAMLprim value
384 ancient_address_of (value obj)
385 {
386   CAMLparam1 (obj);
387   CAMLlocal1 (v);
388
389   if (Is_block (obj)) v = caml_copy_nativeint ((intnat) obj);
390   else v = caml_copy_nativeint (0);
391
392   CAMLreturn (v);
393 }
394
395 CAMLprim value
396 ancient_attach (value fdv, value baseaddrv)
397 {
398   CAMLparam2 (fdv, baseaddrv);
399   CAMLlocal1 (mdv);
400
401   int fd = Int_val (fdv);
402   void *baseaddr = (void *) Nativeint_val (baseaddrv);
403   void *md = mmalloc_attach (fd, baseaddr);
404   if (md == 0) {
405     perror ("mmalloc_attach");
406     caml_failwith ("mmalloc_attach");
407   }
408
409   mdv = caml_alloc (1, Abstract_tag);
410   Field (mdv, 0) = (value) md;
411
412   CAMLreturn (mdv);
413 }
414
415 CAMLprim value
416 ancient_detach (value mdv)
417 {
418   CAMLparam1 (mdv);
419
420   void *md = (void *) Field (mdv, 0);
421
422   if (mmalloc_detach (md) != 0) {
423     perror ("mmalloc_detach");
424     caml_failwith ("mmalloc_detach");
425   }
426
427   CAMLreturn (Val_unit);
428 }
429
430 struct keytable {
431   void **keys;
432   int allocated;
433 };
434
435 CAMLprim value
436 ancient_share_info (value mdv, value keyv, value obj)
437 {
438   CAMLparam3 (mdv, keyv, obj);
439   CAMLlocal3 (proxy, info, rv);
440
441   void *md = (void *) Field (mdv, 0);
442   int key = Int_val (keyv);
443
444   // Get the key table.
445   struct keytable *keytable = mmalloc_getkey (md, 0);
446   if (keytable == 0) {
447     keytable = mmalloc (md, sizeof (struct keytable));
448     if (keytable == 0) caml_failwith ("out of memory");
449     keytable->keys = 0;
450     keytable->allocated = 0;
451     mmalloc_setkey (md, 0, keytable);
452   }
453
454   // Existing key exists?  Free it.
455   if (key < keytable->allocated && keytable->keys[key] != 0) {
456     mfree (md, keytable->keys[key]);
457     keytable->keys[key] = 0;
458   }
459
460   // Keytable large enough?  If not, realloc it.
461   if (key >= keytable->allocated) {
462     int allocated = keytable->allocated == 0 ? 32 : keytable->allocated * 2;
463     void **keys = mrealloc (md, keytable->keys, allocated * sizeof (void *));
464     if (keys == 0) caml_failwith ("out of memory");
465     int i;
466     for (i = keytable->allocated; i < allocated; ++i) keys[i] = 0;
467     keytable->keys = keys;
468     keytable->allocated = allocated;
469   }
470
471   // Do the mark.
472   size_t size;
473   void *ptr = mark (obj, mrealloc, mfree, md, &size);
474
475   // Add the key to the keytable.
476   keytable->keys[key] = ptr;
477
478   // Make the proxy.
479   proxy = caml_alloc (1, Abstract_tag);
480   Field (proxy, 0) = (value) ptr;
481
482   // Make the info struct.
483   info = caml_alloc (1, 0);
484   Field (info, 0) = Val_long (size);
485
486   rv = caml_alloc (2, 0);
487   Field (rv, 0) = proxy;
488   Field (rv, 1) = info;
489
490   CAMLreturn (rv);
491 }
492
493 CAMLprim value
494 ancient_get (value mdv, value keyv)
495 {
496   CAMLparam2 (mdv, keyv);
497   CAMLlocal1 (proxy);
498
499   void *md = (void *) Field (mdv, 0);
500   int key = Int_val (keyv);
501
502   // Key exists?
503   struct keytable *keytable = mmalloc_getkey (md, 0);
504   if (keytable == 0 || key >= keytable->allocated || keytable->keys[key] == 0)
505     caml_raise_not_found ();
506   void *ptr = keytable->keys[key];
507
508   // Return the proxy.
509   proxy = caml_alloc (1, Abstract_tag);
510   Field (proxy, 0) = (value) ptr;
511
512   CAMLreturn (proxy);
513 }