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