ancient_c.c

   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 $
   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/major_gc.h:
  18 #ifdef __alpha
  19 typedef int page_table_entry;
  20 #else
  21 typedef char page_table_entry;
  22 #endif
  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;
  27
  28 #define In_heap 1
  29 #define Not_in_heap 0
  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)])
  35
  36 // Area is an expandable buffer, allocated on the C heap.
  37 typedef struct area {
  38   void *ptr;                    // Start of area.
  39   size_t n;                     // Current position.
  40   size_t size;                  // Allocated size.
  41 } area;
  42
  43 static inline void
  44 area_init (area *a)
  45 {
  46   a->ptr = 0;
  47   a->n =
  48   a->size = 0;
  49 }
  50
  51 static inline int
  52 area_append (area *a, const void *obj, size_t size)
  53 {
  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.
  58   }
  59   memcpy (a->ptr + a->n, obj, size);
  60   a->n += size;
  61   return 0;
  62 }
  63
  64 static inline void
  65 area_shrink (area *a)
  66 {
  67   if (a->n != a->size) {
  68     a->size = a->n;
  69     a->ptr = realloc (a->ptr, a->size);
  70     assert (a->ptr); // Getting smaller, so shouldn't really fail.
  71   }
  72 }
  73
  74 static inline void
  75 area_free (area *a)
  76 {
  77   free (a->ptr);
  78   a->n =
  79   a->size = 0;
  80 }
  81
  82 struct restore_item {
  83   char *header;
  84   value field_zero;
  85 };
  86
  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
  90 // value. (XXX)
  91 static header_t visited = (unsigned long) -1;
  92
  93 // The general plan here:
  94 //
  95 // 1. Starting at [obj], copy it to our out-of-heap memory area
  96 // defined by [ptr].
  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.
 102 //
 103 // XXX Recursive function will probably fall over once we apply it to
 104 // large, deeply recursive structures.  Should be replaced with something
 105 // iterative.
 106 static size_t
 107 mark (value obj, area *ptr, area *restore)
 108 {
 109   char *header = Hp_val (obj);
 110   assert (Wosize_hp (header) > 0); // Always true? (XXX)
 111
 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));
 116
 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)));
 121
 122   // Offset where we will store this object in the out-of-heap memory.
 123   size_t offset = ptr->n;
 124
 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.
 129
 130   // Scan the fields looking for pointers to blocks.
 131   int can_scan = Tag_val (obj) < No_scan_tag;
 132   if (can_scan) {
 133     mlsize_t nr_words = Wosize_hp (header);
 134     mlsize_t i;
 135
 136     for (i = 0; i < nr_words; ++i) {
 137       value field = Field (obj, i);
 138
 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.
 142
 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);
 147
 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;
 152       }
 153     }
 154   }
 155
 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.
 159   // Observations:
 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);
 172
 173   memcpy (header, (void *)&visited, sizeof visited);
 174   Field (obj, 0) = Val_long (offset);
 175
 176   return offset;
 177 }
 178
 179 // See comments immediately above.
 180 static void
 181 do_restore (area *ptr, area *restore)
 182 {
 183   mlsize_t i;
 184   for (i = 0; i < restore->n; i += sizeof (struct restore_item))
 185     {
 186       struct restore_item *restore_item =
 187         (struct restore_item *)(restore->ptr + i);
 188       assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
 189
 190       value obj = Val_hp (restore_item->header);
 191       size_t offset = Long_val (Field (obj, 0));
 192
 193       char *obj_copy_header = ptr->ptr + offset;
 194       //value obj_copy = Val_hp (obj_copy_header);
 195
 196       // Restore the original header.
 197       memcpy (restore_item->header, obj_copy_header, sizeof visited);
 198
 199       // Restore the original zeroth field.
 200       Field (obj, 0) = restore_item->field_zero;
 201     }
 202 }
 203
 204 CAMLprim value
 205 ancient_mark (value obj)
 206 {
 207   CAMLparam1 (obj);
 208   CAMLlocal1 (proxy);
 209
 210   area ptr; // This will be the out of heap area.
 211   area_init (&ptr);
 212   area restore; // Headers to be fixed up after.
 213   area_init (&restore);
 214
 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);
 219     area_free (&ptr);
 220     caml_failwith ("out of memory");
 221   }
 222   area_shrink (&ptr);
 223
 224   // Restore Caml heap structures.
 225   do_restore (&ptr, &restore);
 226   area_free (&restore);
 227
 228   // Update all fake pointers in the out of heap area to make them real
 229   // pointers.
 230   size_t i;
 231   for (i = 0; i < ptr.n; )
 232     {
 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);
 238
 239       int can_scan = Tag_val (obj) < No_scan_tag;
 240       if (can_scan) {
 241         mlsize_t nr_words = Wosize_hp (header);
 242         mlsize_t j;
 243
 244         for (j = 0; j < nr_words; ++j) {
 245           value field = Field (obj, j);
 246
 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;
 251           }
 252         }
 253       }
 254
 255       i += bytes; // Skip to next object.
 256     }
 257
 258   // Replace obj with a proxy.
 259   proxy = caml_alloc (1, Abstract_tag);
 260   Field (proxy, 0) = (value) ptr.ptr;
 261
 262   CAMLreturn (proxy);
 263 }
 264
 265 CAMLprim value
 266 ancient_follow (value obj)
 267 {
 268   CAMLparam1 (obj);
 269   CAMLlocal1 (v);
 270
 271   v = Field (obj, 0);
 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.
 274
 275   CAMLreturn (v);
 276 }
 277
 278 CAMLprim value
 279 ancient_delete (value obj)
 280 {
 281   CAMLparam1 (obj);
 282   CAMLlocal1 (v);
 283
 284   v = Field (obj, 0);
 285   if (Is_long (v)) caml_invalid_argument ("deleted");
 286
 287   // Otherwise v is a pointer to the out of heap malloc'd object.
 288   assert (!Is_in_heap (v));
 289   free ((void *) v);
 290
 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);
 294
 295   CAMLreturn (Val_unit);
 296 }