ancient_c.c

   1 /* Mark objects as 'ancient' so they are taken out of the OCaml heap.
   2  * $Id: ancient_c.c,v 1.2 2006-09-27 14:05:07 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 // From byterun/misc.h:
  15 typedef char * addr;
  16
  17 // From byterun/minor_gc.c:
  18 CAMLextern char *caml_young_start;
  19 CAMLextern char *caml_young_end;
  20 #define Is_young(val) \
  21   (assert (Is_block (val)),                                             \
  22    (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start)
  23
  24 // From byterun/major_gc.h:
  25 #ifdef __alpha
  26 typedef int page_table_entry;
  27 #else
  28 typedef char page_table_entry;
  29 #endif
  30 CAMLextern char *caml_heap_start;
  31 CAMLextern char *caml_heap_end;
  32 CAMLextern page_table_entry *caml_page_table;
  33 extern asize_t caml_page_low, caml_page_high;
  34
  35 #define In_heap 1
  36 #define Not_in_heap 0
  37 #define Page(p) ((uintnat) (p) >> Page_log)
  38 #define Is_in_heap(p) \
  39   (assert (Is_block ((value) (p))),                                     \
  40    (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
  41    && caml_page_table [Page (p)])
  42
  43 // Area is an expandable buffer, allocated on the C heap.
  44 typedef struct area {
  45   void *ptr;                    // Start of area.
  46   size_t n;                     // Current position.
  47   size_t size;                  // Allocated size.
  48 } area;
  49
  50 static inline void
  51 area_init (area *a)
  52 {
  53   a->ptr = 0;
  54   a->n =
  55   a->size = 0;
  56 }
  57
  58 static inline int
  59 area_append (area *a, const void *obj, size_t size)
  60 {
  61   while (a->n + size > a->size) {
  62     if (a->size == 0) a->size = 256; else a->size <<= 1;
  63     a->ptr = realloc (a->ptr, a->size);
  64     if (a->ptr == 0) return -1; // Out of memory.
  65   }
  66   memcpy (a->ptr + a->n, obj, size);
  67   a->n += size;
  68   return 0;
  69 }
  70
  71 static inline void
  72 area_shrink (area *a)
  73 {
  74   if (a->n != a->size) {
  75     a->size = a->n;
  76     a->ptr = realloc (a->ptr, a->size);
  77     assert (a->ptr); // Getting smaller, so shouldn't really fail.
  78   }
  79 }
  80
  81 static inline void
  82 area_free (area *a)
  83 {
  84   free (a->ptr);
  85   a->n =
  86   a->size = 0;
  87 }
  88
  89 struct restore_item {
  90   char *header;
  91   value field_zero;
  92 };
  93
  94 // When a block is visited, we overwrite the header with all 1's.
  95 // This is not quite an impossible value - one could imagine an
  96 // enormous custom block where the header could take on this
  97 // value. (XXX)
  98 static header_t visited = (unsigned long) -1;
  99
 100 // The general plan here:
 101 //
 102 // 1. Starting at [obj], copy it to our out-of-heap memory area
 103 // defined by [ptr].
 104 // 2. Recursively visit subnodes of [obj] and do the same.
 105 // 3. As we copy each object, we avoid circularity by setting that
 106 // object's header to a special 'visited' value.  However since these
 107 // are objects in the Caml heap we have to restore the original
 108 // headers at the end, which is the purpose of the [restore] area.
 109 // 4. We use realloc to allocate the memory for the copy, but because
 110 // the memory can move around, we cannot store absolute pointers.
 111 // Instead we store offsets and fix them up later.  This is the
 112 // purpose of the [fixups] area.
 113 //
 114 // XXX Large, deeply recursive structures cause a stack overflow.
 115 // Temporary solution: 'ulimit -s unlimited'.  This function should
 116 // be replaced with something iterative.
 117 static size_t
 118 mark (value obj, area *ptr, area *restore, area *fixups)
 119 {
 120   char *header = Hp_val (obj);
 121   assert (Wosize_hp (header) > 0); // Always true? (XXX)
 122
 123   // We can't handle out-of-heap objects.
 124   // XXX Since someone might try to mark an ancient object, they
 125   // might get this error, so we should try to do better here.
 126   assert (Is_young (obj) || Is_in_heap (obj));
 127
 128   // If we've already visited this object, just return its offset
 129   // in the out-of-heap memory.
 130   if (memcmp (header, &visited, sizeof visited) == 0)
 131     return (Long_val (Field (obj, 0)));
 132
 133   // Offset where we will store this object in the out-of-heap memory.
 134   size_t offset = ptr->n;
 135
 136   // Copy the object out of the OCaml heap.
 137   size_t bytes = Bhsize_hp (header);
 138   if (area_append (ptr, header, bytes) == -1)
 139     return -1;                  // Error out of memory.
 140
 141   // Scan the fields looking for pointers to blocks.
 142   int can_scan = Tag_val (obj) < No_scan_tag;
 143   if (can_scan) {
 144     mlsize_t nr_words = Wosize_hp (header);
 145     mlsize_t i;
 146
 147     for (i = 0; i < nr_words; ++i) {
 148       value field = Field (obj, i);
 149
 150       if (Is_block (field) &&
 151           (Is_young (field) || Is_in_heap (field))) {
 152         size_t field_offset = mark (field, ptr, restore, fixups);
 153         if (field_offset == -1) return -1; // Propagate out of memory errors.
 154
 155         // Since the recursive call to mark above can reallocate the
 156         // area, we need to recompute these each time round the loop.
 157         char *obj_copy_header = ptr->ptr + offset;
 158         value obj_copy = Val_hp (obj_copy_header);
 159
 160         // Don't store absolute pointers yet because realloc will
 161         // move the memory around.  Store a fake pointer instead.
 162         // We'll fix up these fake pointers afterwards.
 163         Field (obj_copy, i) = field_offset + sizeof (header_t);
 164
 165         size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
 166         area_append (fixups, &fixup, sizeof fixup);
 167       }
 168     }
 169   }
 170
 171   // Mark this object as having been "visited", but keep track of
 172   // what was there before so it can be restored.  We also need to
 173   // record the offset.
 174   // Observations:
 175   // (1) What was in the header before is kept in the out-of-heap
 176   // copy, so we don't explicitly need to remember that.
 177   // (2) We can keep the offset in the zeroth field, but since
 178   // the code above might have modified the copy, we need to remember
 179   // what was in that field before.
 180   // (3) We can overwrite the header with all 1's to indicate that
 181   // we've visited (but see notes on 'static header_t visited' above).
 182   // (4) All objects in OCaml are at least one word long (we hope!).
 183   struct restore_item restore_item;
 184   restore_item.header = header;
 185   restore_item.field_zero = Field (obj, 0);
 186   area_append (restore, &restore_item, sizeof restore_item);
 187
 188   memcpy (header, (void *)&visited, sizeof visited);
 189   Field (obj, 0) = Val_long (offset);
 190
 191   return offset;
 192 }
 193
 194 // See comments immediately above.
 195 static void
 196 do_restore (area *ptr, area *restore)
 197 {
 198   mlsize_t i;
 199   for (i = 0; i < restore->n; i += sizeof (struct restore_item))
 200     {
 201       struct restore_item *restore_item =
 202         (struct restore_item *)(restore->ptr + i);
 203       assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
 204
 205       value obj = Val_hp (restore_item->header);
 206       size_t offset = Long_val (Field (obj, 0));
 207
 208       char *obj_copy_header = ptr->ptr + offset;
 209       //value obj_copy = Val_hp (obj_copy_header);
 210
 211       // Restore the original header.
 212       memcpy (restore_item->header, obj_copy_header, sizeof visited);
 213
 214       // Restore the original zeroth field.
 215       Field (obj, 0) = restore_item->field_zero;
 216     }
 217 }
 218
 219 // Fixup fake pointers.
 220 static void
 221 do_fixups (area *ptr, area *fixups)
 222 {
 223   long i;
 224
 225   for (i = 0; i < fixups->n; i += sizeof (size_t))
 226     {
 227       size_t fixup = *(size_t *)(fixups->ptr + i);
 228       size_t offset = *(size_t *)(ptr->ptr + fixup);
 229       void *real_ptr = ptr->ptr + offset;
 230       *(value *)(ptr->ptr + fixup) = (value) real_ptr;
 231     }
 232 }
 233
 234 CAMLprim value
 235 ancient_mark (value obj)
 236 {
 237   CAMLparam1 (obj);
 238   CAMLlocal1 (proxy);
 239
 240   area ptr; // This will be the out of heap area.
 241   area_init (&ptr);
 242   area restore; // Headers to be fixed up after.
 243   area_init (&restore);
 244   area fixups; // List of fake pointers to be fixed up.
 245   area_init (&fixups);
 246
 247   if (mark (obj, &ptr, &restore, &fixups) == -1) {
 248     // Ran out of memory.  Recover and throw an exception.
 249     do_restore (&ptr, &restore);
 250     area_free (&fixups);
 251     area_free (&restore);
 252     area_free (&ptr);
 253     caml_failwith ("out of memory");
 254   }
 255   area_shrink (&ptr);
 256
 257   // Restore Caml heap structures.
 258   do_restore (&ptr, &restore);
 259   area_free (&restore);
 260
 261   // Update all fake pointers in the out of heap area to make them real
 262   // pointers.
 263   do_fixups (&ptr, &fixups);
 264   area_free (&fixups);
 265
 266   // Replace obj with a proxy.
 267   proxy = caml_alloc (1, Abstract_tag);
 268   Field (proxy, 0) = (value) ptr.ptr;
 269
 270   CAMLreturn (proxy);
 271 }
 272
 273 CAMLprim value
 274 ancient_follow (value obj)
 275 {
 276   CAMLparam1 (obj);
 277   CAMLlocal1 (v);
 278
 279   v = Field (obj, 0);
 280   if (Is_long (v)) caml_invalid_argument ("deleted");
 281   v = Val_hp (v); // v points to the header; make it point to the object.
 282
 283   CAMLreturn (v);
 284 }
 285
 286 CAMLprim value
 287 ancient_delete (value obj)
 288 {
 289   CAMLparam1 (obj);
 290   CAMLlocal1 (v);
 291
 292   v = Field (obj, 0);
 293   if (Is_long (v)) caml_invalid_argument ("deleted");
 294
 295   // Otherwise v is a pointer to the out of heap malloc'd object.
 296   assert (!Is_young (v) && !Is_in_heap (v));
 297   free ((void *) v);
 298
 299   // Replace the proxy (a pointer) with an int 0 so we know it's
 300   // been deleted in future.
 301   Field (obj, 0) = Val_long (0);
 302
 303   CAMLreturn (Val_unit);
 304 }