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 }