ancient_c.c

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