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   while (a->n + size > a->size) {
 137     if (a->size == 0) a->size = 256; else a->size <<= 1;
 138     a->ptr =
 139       a->realloc
 140       ? a->realloc (a->data, a->ptr, a->size)
 141       : realloc (a->ptr, a->size);
 142     if (a->ptr == 0) return -1; // Out of memory.
 143   }
 144   memcpy (a->ptr + a->n, obj, size);
 145   a->n += size;
 146   return 0;
 147 }
 148
 149 static inline void
 150 area_shrink (area *a)
 151 {
 152   if (a->n != a->size) {
 153     a->size = a->n;
 154     a->ptr =
 155       a->realloc
 156       ? a->realloc (a->data, a->ptr, a->size)
 157       : realloc (a->ptr, a->size);
 158     assert (a->ptr); // Getting smaller, so shouldn't really fail.
 159   }
 160 }
 161
 162 static inline void
 163 area_free (area *a)
 164 {
 165   if (a->free) a->free (a->data, a->ptr);
 166   else free (a->ptr);
 167   a->n =
 168   a->size = 0;
 169 }
 170
 171 struct restore_item {
 172   char *header;
 173   value field_zero;
 174 };
 175
 176 // When a block is visited, we overwrite the header with all 1's.
 177 // This is not quite an impossible value - one could imagine an
 178 // enormous custom block where the header could take on this
 179 // value. (XXX)
 180 static header_t visited = (unsigned long) -1;
 181
 182 // The general plan here:
 183 //
 184 // 1. Starting at [obj], copy it to our out-of-heap memory area
 185 // defined by [ptr].
 186 // 2. Recursively visit subnodes of [obj] and do the same.
 187 // 3. As we copy each object, we avoid circularity by setting that
 188 // object's header to a special 'visited' value.  However since these
 189 // are objects in the Caml heap we have to restore the original
 190 // headers at the end, which is the purpose of the [restore] area.
 191 // 4. We use realloc to allocate the memory for the copy, but because
 192 // the memory can move around, we cannot store absolute pointers.
 193 // Instead we store offsets and fix them up later.  This is the
 194 // purpose of the [fixups] area.
 195 //
 196 // XXX Large, deeply recursive structures cause a stack overflow.
 197 // Temporary solution: 'ulimit -s unlimited'.  This function should
 198 // be replaced with something iterative.
 199 static size_t
 200 _mark (value obj, area *ptr, area *restore, area *fixups)
 201 {
 202   // XXX This assertion might fail if someone tries to mark an object
 203   // which is already ancient.
 204   assert (Is_in_heap_or_young (obj));
 205
 206   char *header = Hp_val (obj);
 207
 208   // If we've already visited this object, just return its offset
 209   // in the out-of-heap memory.
 210   if (memcmp (header, &visited, sizeof visited) == 0)
 211     return (Long_val (Field (obj, 0)));
 212
 213   // XXX Actually this fails if you try to persist a zero-length
 214   // array.  Needs to be fixed, but it breaks some rather important
 215   // functions below.
 216   assert (Wosize_hp (header) > 0);
 217
 218   // Offset where we will store this object in the out-of-heap memory.
 219   size_t offset = ptr->n;
 220
 221   // Copy the object out of the OCaml heap.
 222   size_t bytes = Bhsize_hp (header);
 223   if (area_append (ptr, header, bytes) == -1)
 224     return -1;                  // Error out of memory.
 225
 226   // Scan the fields looking for pointers to blocks.
 227   int can_scan = Tag_val (obj) < No_scan_tag;
 228   if (can_scan) {
 229     mlsize_t nr_words = Wosize_hp (header);
 230     mlsize_t i;
 231
 232     for (i = 0; i < nr_words; ++i) {
 233       value field = Field (obj, i);
 234
 235       if (Is_block (field) &&
 236           Is_in_heap_or_young (field)) {
 237         size_t field_offset = _mark (field, ptr, restore, fixups);
 238         if (field_offset == -1) return -1; // Propagate out of memory errors.
 239
 240         // Since the recursive call to mark above can reallocate the
 241         // area, we need to recompute these each time round the loop.
 242         char *obj_copy_header = ptr->ptr + offset;
 243         value obj_copy = Val_hp (obj_copy_header);
 244
 245         // Don't store absolute pointers yet because realloc will
 246         // move the memory around.  Store a fake pointer instead.
 247         // We'll fix up these fake pointers afterwards in do_fixups.
 248         Field (obj_copy, i) = field_offset + sizeof (header_t);
 249
 250         size_t fixup = (void *)&Field(obj_copy, i) - ptr->ptr;
 251         area_append (fixups, &fixup, sizeof fixup);
 252       }
 253     }
 254   }
 255
 256   // Mark this object as having been "visited", but keep track of
 257   // what was there before so it can be restored.  We also need to
 258   // record the offset.
 259   // Observations:
 260   // (1) What was in the header before is kept in the out-of-heap
 261   // copy, so we don't explicitly need to remember that.
 262   // (2) We can keep the offset in the zeroth field, but since
 263   // the code above might have modified the copy, we need to remember
 264   // what was in that field before.
 265   // (3) We can overwrite the header with all 1's to indicate that
 266   // we've visited (but see notes on 'static header_t visited' above).
 267   // (4) All objects in OCaml are at least one word long (XXX - actually
 268   // this is not true).
 269   struct restore_item restore_item;
 270   restore_item.header = header;
 271   restore_item.field_zero = Field (obj, 0);
 272   area_append (restore, &restore_item, sizeof restore_item);
 273
 274   memcpy (header, (void *)&visited, sizeof visited);
 275   Field (obj, 0) = Val_long (offset);
 276
 277   return offset;
 278 }
 279
 280 // See comments immediately above.
 281 static void
 282 do_restore (area *ptr, area *restore)
 283 {
 284   mlsize_t i;
 285   for (i = 0; i < restore->n; i += sizeof (struct restore_item))
 286     {
 287       struct restore_item *restore_item =
 288         (struct restore_item *)(restore->ptr + i);
 289       assert (memcmp (restore_item->header, &visited, sizeof visited) == 0);
 290
 291       value obj = Val_hp (restore_item->header);
 292       size_t offset = Long_val (Field (obj, 0));
 293
 294       char *obj_copy_header = ptr->ptr + offset;
 295       //value obj_copy = Val_hp (obj_copy_header);
 296
 297       // Restore the original header.
 298       memcpy (restore_item->header, obj_copy_header, sizeof visited);
 299
 300       // Restore the original zeroth field.
 301       Field (obj, 0) = restore_item->field_zero;
 302     }
 303 }
 304
 305 // Fixup fake pointers.
 306 static void
 307 do_fixups (area *ptr, area *fixups)
 308 {
 309   long i;
 310
 311   for (i = 0; i < fixups->n; i += sizeof (size_t))
 312     {
 313       size_t fixup = *(size_t *)(fixups->ptr + i);
 314       size_t offset = *(size_t *)(ptr->ptr + fixup);
 315       void *real_ptr = ptr->ptr + offset;
 316       *(value *)(ptr->ptr + fixup) = (value) real_ptr;
 317     }
 318 }
 319
 320 static void *
 321 mark (value obj,
 322       void *(*realloc)(void *data, void *ptr, size_t size),
 323       void (*free)(void *data, void *ptr),
 324       void *data,
 325       size_t *r_size)
 326 {
 327   area ptr; // This will be the out of heap area.
 328   area_init_custom (&ptr, realloc, free, data);
 329   area restore; // Headers to be fixed up after.
 330   area_init (&restore);
 331   area fixups; // List of fake pointers to be fixed up.
 332   area_init (&fixups);
 333
 334   if (_mark (obj, &ptr, &restore, &fixups) == -1) {
 335     // Ran out of memory.  Recover and throw an exception.
 336     area_free (&fixups);
 337     do_restore (&ptr, &restore);
 338     area_free (&restore);
 339     area_free (&ptr);
 340     caml_failwith ("out of memory");
 341   }
 342   area_shrink (&ptr);
 343
 344   // Restore Caml heap structures.
 345   do_restore (&ptr, &restore);
 346   area_free (&restore);
 347
 348   // Update all fake pointers in the out of heap area to make them real
 349   // pointers.
 350   do_fixups (&ptr, &fixups);
 351   area_free (&fixups);
 352
 353   if (r_size) *r_size = ptr.size;
 354   return ptr.ptr;
 355 }
 356
 357 static void *
 358 my_realloc (void *data __attribute__((unused)), void *ptr, size_t size)
 359 {
 360   return realloc (ptr, size);
 361 }
 362
 363 static void
 364 my_free (void *data __attribute__((unused)), void *ptr)
 365 {
 366   return free (ptr);
 367 }
 368
 369 CAMLprim value
 370 ancient_mark_info (value obj)
 371 {
 372   CAMLparam1 (obj);
 373   CAMLlocal3 (proxy, info, rv);
 374
 375   size_t size;
 376   void *ptr = mark (obj, my_realloc, my_free, 0, &size);
 377
 378   // Make the proxy.
 379   proxy = caml_alloc (1, Abstract_tag);
 380   Field (proxy, 0) = (value) ptr;
 381
 382   // Make the info struct.
 383   info = caml_alloc (1, 0);
 384   Field (info, 0) = Val_long (size);
 385
 386   rv = caml_alloc (2, 0);
 387   Field (rv, 0) = proxy;
 388   Field (rv, 1) = info;
 389
 390   CAMLreturn (rv);
 391 }
 392
 393 CAMLprim value
 394 ancient_follow (value obj)
 395 {
 396   CAMLparam1 (obj);
 397   CAMLlocal1 (v);
 398
 399   v = Field (obj, 0);
 400   if (Is_long (v)) caml_invalid_argument ("deleted");
 401   v = Val_hp (v); // v points to the header; make it point to the object.
 402
 403   CAMLreturn (v);
 404 }
 405
 406 CAMLprim value
 407 ancient_delete (value obj)
 408 {
 409   CAMLparam1 (obj);
 410   CAMLlocal1 (v);
 411
 412   v = Field (obj, 0);
 413   if (Is_long (v)) caml_invalid_argument ("deleted");
 414
 415   // Otherwise v is a pointer to the out of heap malloc'd object.
 416   assert (!Is_in_heap_or_young (v));
 417   free ((void *) v);
 418
 419   // Replace the proxy (a pointer) with an int 0 so we know it's
 420   // been deleted in future.
 421   Field (obj, 0) = Val_long (0);
 422
 423   CAMLreturn (Val_unit);
 424 }
 425
 426 CAMLprim value
 427 ancient_is_ancient (value obj)
 428 {
 429   CAMLparam1 (obj);
 430   CAMLlocal1 (v);
 431
 432   v = Is_in_heap_or_young (obj) ? Val_false : Val_true;
 433
 434   CAMLreturn (v);
 435 }
 436
 437 CAMLprim value
 438 ancient_address_of (value obj)
 439 {
 440   CAMLparam1 (obj);
 441   CAMLlocal1 (v);
 442
 443   if (Is_block (obj)) v = caml_copy_nativeint ((intnat) obj);
 444   else v = caml_copy_nativeint (0);
 445
 446   CAMLreturn (v);
 447 }
 448
 449 CAMLprim value
 450 ancient_attach (value fdv, value baseaddrv)
 451 {
 452   CAMLparam2 (fdv, baseaddrv);
 453   CAMLlocal1 (mdv);
 454
 455   int fd = Int_val (fdv);
 456   void *baseaddr = (void *) Nativeint_val (baseaddrv);
 457   void *md = mmalloc_attach (fd, baseaddr);
 458   if (md == 0) {
 459     perror ("mmalloc_attach");
 460     caml_failwith ("mmalloc_attach");
 461   }
 462
 463   mdv = caml_alloc (1, Abstract_tag);
 464   Field (mdv, 0) = (value) md;
 465
 466   CAMLreturn (mdv);
 467 }
 468
 469 CAMLprim value
 470 ancient_detach (value mdv)
 471 {
 472   CAMLparam1 (mdv);
 473
 474   void *md = (void *) Field (mdv, 0);
 475
 476   if (mmalloc_detach (md) != 0) {
 477     perror ("mmalloc_detach");
 478     caml_failwith ("mmalloc_detach");
 479   }
 480
 481   CAMLreturn (Val_unit);
 482 }
 483
 484 struct keytable {
 485   void **keys;
 486   int allocated;
 487 };
 488
 489 CAMLprim value
 490 ancient_share_info (value mdv, value keyv, value obj)
 491 {
 492   CAMLparam3 (mdv, keyv, obj);
 493   CAMLlocal3 (proxy, info, rv);
 494
 495   void *md = (void *) Field (mdv, 0);
 496   int key = Int_val (keyv);
 497
 498   // Get the key table.
 499   struct keytable *keytable = mmalloc_getkey (md, 0);
 500   if (keytable == 0) {
 501     keytable = mmalloc (md, sizeof (struct keytable));
 502     if (keytable == 0) caml_failwith ("out of memory");
 503     keytable->keys = 0;
 504     keytable->allocated = 0;
 505     mmalloc_setkey (md, 0, keytable);
 506   }
 507
 508   // Existing key exists?  Free it.
 509   if (key < keytable->allocated && keytable->keys[key] != 0) {
 510     mfree (md, keytable->keys[key]);
 511     keytable->keys[key] = 0;
 512   }
 513
 514   // Keytable large enough?  If not, realloc it.
 515   if (key >= keytable->allocated) {
 516     int allocated = keytable->allocated == 0 ? 32 : keytable->allocated * 2;
 517     void **keys = mrealloc (md, keytable->keys, allocated * sizeof (void *));
 518     if (keys == 0) caml_failwith ("out of memory");
 519     int i;
 520     for (i = keytable->allocated; i < allocated; ++i) keys[i] = 0;
 521     keytable->keys = keys;
 522     keytable->allocated = allocated;
 523   }
 524
 525   // Do the mark.
 526   size_t size;
 527   void *ptr = mark (obj, mrealloc, mfree, md, &size);
 528
 529   // Add the key to the keytable.
 530   keytable->keys[key] = ptr;
 531
 532   // Make the proxy.
 533   proxy = caml_alloc (1, Abstract_tag);
 534   Field (proxy, 0) = (value) ptr;
 535
 536   // Make the info struct.
 537   info = caml_alloc (1, 0);
 538   Field (info, 0) = Val_long (size);
 539
 540   rv = caml_alloc (2, 0);
 541   Field (rv, 0) = proxy;
 542   Field (rv, 1) = info;
 543
 544   CAMLreturn (rv);
 545 }
 546
 547 CAMLprim value
 548 ancient_get (value mdv, value keyv)
 549 {
 550   CAMLparam2 (mdv, keyv);
 551   CAMLlocal1 (proxy);
 552
 553   void *md = (void *) Field (mdv, 0);
 554   int key = Int_val (keyv);
 555
 556   // Key exists?
 557   struct keytable *keytable = mmalloc_getkey (md, 0);
 558   if (keytable == 0 || key >= keytable->allocated || keytable->keys[key] == 0)
 559     caml_raise_not_found ();
 560   void *ptr = keytable->keys[key];
 561
 562   // Return the proxy.
 563   proxy = caml_alloc (1, Abstract_tag);
 564   Field (proxy, 0) = (value) ptr;
 565
 566   CAMLreturn (proxy);
 567 }