ancient_c.c

   1 /* Mark objects as 'ancient' so they are taken out of the OCaml heap.
   2  * $Id: ancient_c.c,v 1.11 2006-10-31 14:39:50 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 // uintnat, intnat only appeared in Caml 3.09.x.
  17 #if OCAML_VERSION_MAJOR == 3 && OCAML_VERSION_MINOR < 9
  18 typedef unsigned long uintnat;
  19 typedef long intnat;
  20 #endif
  21
  22 // From byterun/misc.h:
  23 typedef char * addr;
  24
  25 // From byterun/minor_gc.h:
  26 CAMLextern char *caml_young_start;
  27 CAMLextern char *caml_young_end;
  28 #define Is_young(val) \
  29   (assert (Is_block (val)),                                             \
  30    (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start)
  31
  32 // From byterun/major_gc.h:
  33 #ifdef __alpha
  34 typedef int page_table_entry;
  35 #else
  36 typedef char page_table_entry;
  37 #endif
  38 CAMLextern char *caml_heap_start;
  39 CAMLextern char *caml_heap_end;
  40 CAMLextern page_table_entry *caml_page_table;
  41
  42 #define In_heap 1
  43 #define Not_in_heap 0
  44 #define Page(p) ((uintnat) (p) >> Page_log)
  45 #define Is_in_heap(p) \
  46   (assert (Is_block ((value) (p))),                                     \
  47    (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \
  48    && caml_page_table [Page (p)])
  49
  50 // Area is an expandable buffer, allocated on the C heap.
  51 typedef struct area {
  52   void *ptr;                    // Start of area.
  53   size_t n;                     // Current position.
  54   size_t size;                  // Allocated size.
  55
  56   // If this area requires custom realloc function, these will be non-null.
  57   void *(*realloc)(void *data, void *ptr, size_t size);
  58   void (*free)(void *data, void *ptr);
  59   void *data;
  60 } area;
  61
  62 static inline void
  63 area_init (area *a)
  64 {
  65   a->ptr = 0;
  66   a->n =
  67   a->size = 0;
  68   a->realloc = 0;
  69   a->free = 0;
  70   a->data = 0;
  71 }
  72
  73 static inline void
  74 area_init_custom (area *a,
  75                   void *(*realloc)(void *data, void *ptr, size_t size),
  76                   void (*free)(void *data, void *ptr),
  77                   void *data)
  78 {
  79   area_init (a);
  80   a->realloc = realloc;
  81   a->free = free;
  82   a->data = data;
  83 }
  84
  85 static inline int
  86 area_append (area *a, const void *obj, size_t size)
  87 {
  88   while (a->n + size > a->size) {
  89     if (a->size == 0) a->size = 256; else a->size <<= 1;
  90     a->ptr =
  91       a->realloc
  92       ? a->realloc (a->data, a->ptr, a->size)
  93       : realloc (a->ptr, a->size);
  94     if (a->ptr == 0) return -1; // Out of memory.
  95   }
  96   memcpy (a->ptr + a->n, obj, size);
  97   a->n += size;
  98   return 0;
  99 }
 100
 101 static inline void
 102 area_shrink (area *a)
 103 {
 104   if (a->n != a->size) {
 105     a->size = a->n;
 106     a->ptr =
 107       a->realloc
 108       ? a->realloc (a->data, a->ptr, a->size)
 109       : realloc (a->ptr, a->size);
 110     assert (a->ptr); // Getting smaller, so shouldn't really fail.
 111   }
 112 }
 113
 114 static inline void
 115 area_free (area *a)
 116 {
 117   if (a->free) a->free (a->data, a->ptr);
 118   else free (a->ptr);
 119   a->n =
 120   a->size = 0;
 121 }
 122
 123 struct restore_item {
 124   char *header;
 125   value field_zero;
 126 };
 127
 128 // When a block is visited, we overwrite the header with all 1's.
 129 // This is not quite an impossible value - one could imagine an
 130 // enormous custom block where the header could take on this
 131 // value. (XXX)
 132 static header_t visited = (unsigned long) -1;
 133
 134 // The general plan here:
 135 //
 136 // 1. Starting at [obj], copy it to our out-of-heap memory area
 137 // defined by [ptr].
 138 // 2. Recursively visit subnodes of [obj] and do the same.
 139 // 3. As we copy each object, we avoid circularity by setting that
 140 // object's header to a special 'visited' value.  However since these
 141 // are objects in the Caml heap we have to restore the original
 142 // headers at the end, which is the purpose of the [restore] area.
 143 // 4. We use realloc to allocate the memory for the copy, but because
 144 // the memory can move around, we cannot store absolute pointers.
 145 // Instead we store offsets and fix them up later.  This is the
 146 // purpose of the [fixups] area.
 147 //
 148 // XXX Large, deeply recursive structures cause a stack overflow.
 149 // Temporary solution: 'ulimit -s unlimited'.  This function should
 150 // be replaced with something iterative.
 151 static size_t
 152 _mark (value obj, area *ptr, area *restore, area *fixups)
 153 {
 154   // XXX This assertion might fail if someone tries to mark an object
 155   // which is already ancient.
 156   assert (Is_young (obj) || Is_in_heap (obj));
 157
 158   char *header = Hp_val (obj);
 159
 160   // If we've already visited this object, just return its offset
 161   // in the out-of-heap memory.
 162   if (memcmp (header, &visited, sizeof visited) == 0)
 163     return (Long_val (Field (obj, 0)));
 164
 165   // XXX Actually this fails if you try to persist a zero-length
 166   // array.  Needs to be fixed, but it breaks some rather important
 167   // functions below.
 168   assert (Wosize_hp (header) > 0);
 169
 170   // Offset where we will store this object in the out-of-heap memory.
 171   size_t offset = ptr->n;
 172
 173   // Copy the object out of the OCaml heap.
 174   size_t bytes = Bhsize_hp (header);
 175   if (area_append (ptr, header, bytes) == -1)
 176     return -1;                  // Error out of memory.
 177
 178   // Scan the fields looking for pointers to blocks.
 179   int can_scan = Tag_val (obj) < No_scan_tag;
 180   if (can_scan) {
 181     mlsize_t nr_words = Wosize_hp (header);
 182     mlsize_t i;
 183
 184     for (i = 0; i < nr_words; ++i) {
 185       value field = Field (obj, i);
 186
 187       if (Is_block (field) &&
 188           (Is_young (field) || Is_in_heap (field))) {
 189         size_t field_offset = _mark (field, ptr, restore, fixups);
 190         if (field_offset == -1) return -1; // Propagate out of memory errors.
 191
 192         // Since the recursive call to mark above can reallocate the
 193         // area, we need to recompute these each time round the loop.
 194         char *obj_copy_header = ptr->ptr + offset;
 195         value obj_copy = Val_hp (obj_copy_header);
 196
 197         // Don't store absolute pointers yet because realloc will
 198         // move the memory around.  Store a fake pointer instead.
 199         // We'll fix up these fake pointers afterwards in do_fixups.
 200         Field (obj_copy, i) = field_offset + sizeof (header_t);
 201
 202         size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
 203         area_append (fixups, &fixup, sizeof fixup);
 204       }
 205     }
 206   }
 207
 208   // Mark this object as having been "visited", but keep track of
 209   // what was there before so it can be restored.  We also need to
 210   // record the offset.
 211   // Observations:
 212   // (1) What was in the header before is kept in the out-of-heap
 213   // copy, so we don't explicitly need to remember that.
 214   // (2) We can keep the offset in the zeroth field, but since
 215   // the code above might have modified the copy, we need to remember
 216   // what was in that field before.
 217   // (3) We can overwrite the header with all 1's to indicate that
 218   // we've visited (but see notes on 'static header_t visited' above).
 219   // (4) All objects in OCaml are at least one word long (XXX - actually
 220   // this is not true).
 221   struct restore_item restore_item;
 222   restore_item.header = header;
 223   restore_item.field_zero = Field (obj, 0);
 224   area_append (restore, &restore_item, sizeof restore_item);
 225
 226   memcpy (header, (void *)&visited, sizeof visited);
 227   Field (obj, 0) = Val_long (offset);
 228
 229   return offset;
 230 }
 231
 232 // See comments immediately above.
 233 static void
 234 do_restore (area *ptr, area *restore)
 235 {
 236   mlsize_t i;
 237   for (i = 0; i < restore->n; i += sizeof (struct restore_item))
 238     {
 239       struct restore_item *restore_item =
 240         (struct restore_item *)(restore->ptr + i);
 241       assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
 242
 243       value obj = Val_hp (restore_item->header);
 244       size_t offset = Long_val (Field (obj, 0));
 245
 246       char *obj_copy_header = ptr->ptr + offset;
 247       //value obj_copy = Val_hp (obj_copy_header);
 248
 249       // Restore the original header.
 250       memcpy (restore_item->header, obj_copy_header, sizeof visited);
 251
 252       // Restore the original zeroth field.
 253       Field (obj, 0) = restore_item->field_zero;
 254     }
 255 }
 256
 257 // Fixup fake pointers.
 258 static void
 259 do_fixups (area *ptr, area *fixups)
 260 {
 261   long i;
 262
 263   for (i = 0; i < fixups->n; i += sizeof (size_t))
 264     {
 265       size_t fixup = *(size_t *)(fixups->ptr + i);
 266       size_t offset = *(size_t *)(ptr->ptr + fixup);
 267       void *real_ptr = ptr->ptr + offset;
 268       *(value *)(ptr->ptr + fixup) = (value) real_ptr;
 269     }
 270 }
 271
 272 static void *
 273 mark (value obj,
 274       void *(*realloc)(void *data, void *ptr, size_t size),
 275       void (*free)(void *data, void *ptr),
 276       void *data,
 277       size_t *r_size)
 278 {
 279   area ptr; // This will be the out of heap area.
 280   area_init_custom (&ptr, realloc, free, data);
 281   area restore; // Headers to be fixed up after.
 282   area_init (&restore);
 283   area fixups; // List of fake pointers to be fixed up.
 284   area_init (&fixups);
 285
 286   if (_mark (obj, &ptr, &restore, &fixups) == -1) {
 287     // Ran out of memory.  Recover and throw an exception.
 288     area_free (&fixups);
 289     do_restore (&ptr, &restore);
 290     area_free (&restore);
 291     area_free (&ptr);
 292     caml_failwith ("out of memory");
 293   }
 294   area_shrink (&ptr);
 295
 296   // Restore Caml heap structures.
 297   do_restore (&ptr, &restore);
 298   area_free (&restore);
 299
 300   // Update all fake pointers in the out of heap area to make them real
 301   // pointers.
 302   do_fixups (&ptr, &fixups);
 303   area_free (&fixups);
 304
 305   if (r_size) *r_size = ptr.size;
 306   return ptr.ptr;
 307 }
 308
 309 static void *
 310 my_realloc (void *data __attribute__((unused)), void *ptr, size_t size)
 311 {
 312   return realloc (ptr, size);
 313 }
 314
 315 static void
 316 my_free (void *data __attribute__((unused)), void *ptr)
 317 {
 318   return free (ptr);
 319 }
 320
 321 CAMLprim value
 322 ancient_mark_info (value obj)
 323 {
 324   CAMLparam1 (obj);
 325   CAMLlocal3 (proxy, info, rv);
 326
 327   size_t size;
 328   void *ptr = mark (obj, my_realloc, my_free, 0, &size);
 329
 330   // Make the proxy.
 331   proxy = caml_alloc (1, Abstract_tag);
 332   Field (proxy, 0) = (value) ptr;
 333
 334   // Make the info struct.
 335   info = caml_alloc (1, 0);
 336   Field (info, 0) = Val_long (size);
 337
 338   rv = caml_alloc (2, 0);
 339   Field (rv, 0) = proxy;
 340   Field (rv, 1) = info;
 341
 342   CAMLreturn (rv);
 343 }
 344
 345 CAMLprim value
 346 ancient_follow (value obj)
 347 {
 348   CAMLparam1 (obj);
 349   CAMLlocal1 (v);
 350
 351   v = Field (obj, 0);
 352   if (Is_long (v)) caml_invalid_argument ("deleted");
 353   v = Val_hp (v); // v points to the header; make it point to the object.
 354
 355   CAMLreturn (v);
 356 }
 357
 358 CAMLprim value
 359 ancient_delete (value obj)
 360 {
 361   CAMLparam1 (obj);
 362   CAMLlocal1 (v);
 363
 364   v = Field (obj, 0);
 365   if (Is_long (v)) caml_invalid_argument ("deleted");
 366
 367   // Otherwise v is a pointer to the out of heap malloc'd object.
 368   assert (!Is_young (v) && !Is_in_heap (v));
 369   free ((void *) v);
 370
 371   // Replace the proxy (a pointer) with an int 0 so we know it's
 372   // been deleted in future.
 373   Field (obj, 0) = Val_long (0);
 374
 375   CAMLreturn (Val_unit);
 376 }
 377
 378 CAMLprim value
 379 ancient_is_ancient (value obj)
 380 {
 381   CAMLparam1 (obj);
 382   CAMLlocal1 (v);
 383
 384   v = Is_young (obj) || Is_in_heap (obj) ? Val_false : Val_true;
 385
 386   CAMLreturn (v);
 387 }
 388
 389 CAMLprim value
 390 ancient_address_of (value obj)
 391 {
 392   CAMLparam1 (obj);
 393   CAMLlocal1 (v);
 394
 395   if (Is_block (obj)) v = caml_copy_nativeint ((intnat) obj);
 396   else v = caml_copy_nativeint (0);
 397
 398   CAMLreturn (v);
 399 }
 400
 401 CAMLprim value
 402 ancient_attach (value fdv, value baseaddrv)
 403 {
 404   CAMLparam2 (fdv, baseaddrv);
 405   CAMLlocal1 (mdv);
 406
 407   int fd = Int_val (fdv);
 408   void *baseaddr = (void *) Nativeint_val (baseaddrv);
 409   void *md = mmalloc_attach (fd, baseaddr);
 410   if (md == 0) {
 411     perror ("mmalloc_attach");
 412     caml_failwith ("mmalloc_attach");
 413   }
 414
 415   mdv = caml_alloc (1, Abstract_tag);
 416   Field (mdv, 0) = (value) md;
 417
 418   CAMLreturn (mdv);
 419 }
 420
 421 CAMLprim value
 422 ancient_detach (value mdv)
 423 {
 424   CAMLparam1 (mdv);
 425
 426   void *md = (void *) Field (mdv, 0);
 427
 428   if (mmalloc_detach (md) != 0) {
 429     perror ("mmalloc_detach");
 430     caml_failwith ("mmalloc_detach");
 431   }
 432
 433   CAMLreturn (Val_unit);
 434 }
 435
 436 struct keytable {
 437   void **keys;
 438   int allocated;
 439 };
 440
 441 CAMLprim value
 442 ancient_share_info (value mdv, value keyv, value obj)
 443 {
 444   CAMLparam3 (mdv, keyv, obj);
 445   CAMLlocal3 (proxy, info, rv);
 446
 447   void *md = (void *) Field (mdv, 0);
 448   int key = Int_val (keyv);
 449
 450   // Get the key table.
 451   struct keytable *keytable = mmalloc_getkey (md, 0);
 452   if (keytable == 0) {
 453     keytable = mmalloc (md, sizeof (struct keytable));
 454     if (keytable == 0) caml_failwith ("out of memory");
 455     keytable->keys = 0;
 456     keytable->allocated = 0;
 457     mmalloc_setkey (md, 0, keytable);
 458   }
 459
 460   // Existing key exists?  Free it.
 461   if (key < keytable->allocated && keytable->keys[key] != 0) {
 462     mfree (md, keytable->keys[key]);
 463     keytable->keys[key] = 0;
 464   }
 465
 466   // Keytable large enough?  If not, realloc it.
 467   if (key >= keytable->allocated) {
 468     int allocated = keytable->allocated == 0 ? 32 : keytable->allocated * 2;
 469     void **keys = mrealloc (md, keytable->keys, allocated * sizeof (void *));
 470     if (keys == 0) caml_failwith ("out of memory");
 471     int i;
 472     for (i = keytable->allocated; i < allocated; ++i) keys[i] = 0;
 473     keytable->keys = keys;
 474     keytable->allocated = allocated;
 475   }
 476
 477   // Do the mark.
 478   size_t size;
 479   void *ptr = mark (obj, mrealloc, mfree, md, &size);
 480
 481   // Add the key to the keytable.
 482   keytable->keys[key] = ptr;
 483
 484   // Make the proxy.
 485   proxy = caml_alloc (1, Abstract_tag);
 486   Field (proxy, 0) = (value) ptr;
 487
 488   // Make the info struct.
 489   info = caml_alloc (1, 0);
 490   Field (info, 0) = Val_long (size);
 491
 492   rv = caml_alloc (2, 0);
 493   Field (rv, 0) = proxy;
 494   Field (rv, 1) = info;
 495
 496   CAMLreturn (rv);
 497 }
 498
 499 CAMLprim value
 500 ancient_get (value mdv, value keyv)
 501 {
 502   CAMLparam2 (mdv, keyv);
 503   CAMLlocal1 (proxy);
 504
 505   void *md = (void *) Field (mdv, 0);
 506   int key = Int_val (keyv);
 507
 508   // Key exists?
 509   struct keytable *keytable = mmalloc_getkey (md, 0);
 510   if (keytable == 0 || key >= keytable->allocated || keytable->keys[key] == 0)
 511     caml_raise_not_found ();
 512   void *ptr = keytable->keys[key];
 513
 514   // Return the proxy.
 515   proxy = caml_alloc (1, Abstract_tag);
 516   Field (proxy, 0) = (value) ptr;
 517
 518   CAMLreturn (proxy);
 519 }