guile18/libguile/gc-segment.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18 #ifdef HAVE_CONFIG_H
  19 # include <config.h>
  20 #endif
  21
  22 #include <assert.h>
  23 #include <stdio.h>
  24 #include <string.h>
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/pairs.h"
  28 #include "libguile/gc.h"
  29 #include "libguile/private-gc.h"
  30
  31
  32
  33
  34
  35 size_t scm_max_segment_size;
  36
  37 scm_t_heap_segment *
  38 scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl)
  39 {
  40   scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment));
  41
  42   if (!shs)
  43     {
  44       fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n");
  45       abort ();
  46     }
  47
  48   shs->bounds[0] = NULL;
  49   shs->bounds[1] = NULL;
  50   shs->malloced = NULL;
  51   shs->span = fl->span;
  52   shs->freelist  = fl;
  53   shs->next_free_card = NULL;
  54
  55   return shs;
  56 }
  57
  58
  59 void
  60 scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab)
  61 {
  62   scm_t_cell *p = seg->bounds[0];
  63   while (p <  seg->bounds[1])
  64     {
  65       scm_i_card_statistics (p, tab, seg);
  66       p += SCM_GC_CARD_N_CELLS;
  67     }
  68 }
  69
  70
  71
  72 /*
  73   Fill SEGMENT with memory both for data and mark bits.
  74
  75   RETURN:  1 on success, 0 failure
  76  */
  77 int
  78 scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested)
  79 {
  80   /*
  81     round upwards
  82    */
  83   int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
  84   int card_count =1 + (requested / sizeof (scm_t_cell)) /  card_data_cell_count;
  85
  86   /*
  87     one card extra due to alignment
  88   */
  89   size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD
  90     + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG
  91     ;
  92   scm_t_c_bvec_long * bvec_ptr = 0;
  93   scm_t_cell *  memory = 0;
  94
  95   /*
  96     We use calloc to alloc the heap. On GNU libc this is
  97     equivalent to mmapping /dev/zero
  98    */
  99   SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed));
 100
 101   if (memory == NULL)
 102     return 0;
 103
 104   segment->malloced = memory;
 105   segment->bounds[0] = SCM_GC_CARD_UP (memory);
 106   segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;
 107
 108   segment->freelist->heap_size += scm_i_segment_cell_count (segment);
 109
 110   bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1];
 111
 112   /*
 113     Don't init the mem or the bitvector. This is handled by lazy
 114     sweeping.
 115   */
 116
 117   segment->next_free_card = segment->bounds[0];
 118   segment->first_time = 1;
 119   return 1;
 120 }
 121
 122 int
 123 scm_i_segment_card_count (scm_t_heap_segment * seg)
 124 {
 125   return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
 126 }
 127
 128 /*
 129   Return the number of available single-cell data cells.
 130  */
 131 int
 132 scm_i_segment_cell_count (scm_t_heap_segment * seg)
 133 {
 134   return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
 135     + ((seg->span == 2) ? -1 : 0);
 136 }
 137
 138 void
 139 scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
 140 {
 141   scm_t_cell *  markspace = seg->bounds[1];
 142
 143   memset (markspace, 0x00,
 144           scm_i_segment_card_count (seg) *  SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
 145 }
 146
 147 /*
 148   Sweep cards from SEG until we've gathered THRESHOLD cells
 149
 150   RETURN:
 151
 152   Freelist.
 153 */
 154 SCM
 155 scm_i_sweep_some_cards (scm_t_heap_segment *seg)
 156 {
 157   SCM cells = SCM_EOL;
 158   int threshold = 512;
 159   int collected = 0;
 160   int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment* )
 161     = (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;
 162
 163   scm_t_cell * next_free = seg->next_free_card;
 164   int cards_swept = 0;
 165
 166   while (collected < threshold && next_free < seg->bounds[1])
 167     {
 168       collected += (*sweeper) (next_free, &cells, seg);
 169       next_free += SCM_GC_CARD_N_CELLS;
 170       cards_swept ++;
 171     }
 172
 173   scm_gc_cells_swept +=  cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
 174   scm_gc_cells_collected += collected * seg->span;
 175
 176   if (!seg->first_time)
 177     {
 178       scm_gc_cells_allocated_acc +=
 179         (scm_cells_allocated - scm_last_cells_allocated);
 180
 181       scm_cells_allocated -= collected * seg->span;
 182       scm_last_cells_allocated = scm_cells_allocated;
 183     }
 184   seg->freelist->collected += collected  * seg->span;
 185
 186
 187   if(next_free == seg->bounds[1])
 188     {
 189       seg->first_time = 0;
 190     }
 191
 192   seg->next_free_card = next_free;
 193   return cells;
 194 }
 195
 196
 197 /*
 198   Force a sweep of this entire segment. This doesn't modify sweep
 199   statistics, it just frees the memory pointed to by to-be-swept
 200   cells.
 201
 202   Implementation is slightly ugh.
 203
 204   FIXME: if you do scm_i_sweep_segment(), and then allocate from this
 205   segment again, the statistics are off.
 206  */
 207 void
 208 scm_i_sweep_segment (scm_t_heap_segment * seg)
 209 {
 210   scm_t_cell * p = seg->next_free_card;
 211   int yield = scm_gc_cells_collected;
 212   int coll = seg->freelist->collected;
 213   unsigned long alloc = scm_cells_allocated ;
 214   unsigned long last_alloc = scm_last_cells_allocated;
 215   double last_total
 216     = scm_gc_cells_allocated_acc
 217     + (alloc - last_alloc);
 218
 219   while (scm_i_sweep_some_cards (seg) != SCM_EOL)
 220     ;
 221
 222   scm_gc_cells_collected = yield;
 223
 224   /*
 225    * restore old stats.
 226    */
 227   scm_gc_cells_allocated_acc = last_total;
 228   scm_cells_allocated = alloc;
 229   scm_last_cells_allocated = alloc;
 230
 231   seg->freelist->collected = coll;
 232   seg->next_free_card =p;
 233 }
 234
 235 void
 236 scm_i_sweep_all_segments (char const  *reason)
 237 {
 238   int i= 0;
 239
 240   for (i = 0; i < scm_i_heap_segment_table_size; i++)
 241     {
 242       scm_i_sweep_segment (scm_i_heap_segment_table[i]);
 243     }
 244 }
 245
 246
 247 /*
 248   Heap segment table.
 249
 250   The table is sorted by the address of the data itself. This makes
 251   for easy lookups. This is not portable: according to ANSI C,
 252   pointers can only be compared within the same object (i.e. the same
 253   block of malloced memory.). For machines with weird architectures,
 254   this should be revised.
 255
 256   (Apparently, for this reason 1.6 and earlier had macros for pointer
 257   comparison. )
 258
 259   perhaps it is worthwhile to remove the 2nd level of indirection in
 260   the table, but this certainly makes for cleaner code.
 261 */
 262 scm_t_heap_segment ** scm_i_heap_segment_table;
 263 size_t scm_i_heap_segment_table_size;
 264 scm_t_cell *lowest_cell;
 265 scm_t_cell *highest_cell;
 266
 267
 268 void
 269 scm_i_clear_mark_space (void)
 270 {
 271   int i = 0;
 272   for (; i < scm_i_heap_segment_table_size; i++)
 273     {
 274       scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
 275     }
 276 }
 277
 278
 279 /*
 280   RETURN: index of inserted segment.
 281  */
 282 int
 283 scm_i_insert_segment (scm_t_heap_segment * seg)
 284 {
 285   size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
 286   SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
 287                                realloc ((char *)scm_i_heap_segment_table, size)));
 288
 289   /*
 290     We can't alloc 4 more bytes. This is hopeless.
 291    */
 292   if (!scm_i_heap_segment_table)
 293     {
 294       fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
 295       abort ();
 296     }
 297
 298   if (!lowest_cell)
 299     {
 300       lowest_cell = seg->bounds[0];
 301       highest_cell = seg->bounds[1];
 302     }
 303   else
 304     {
 305       lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
 306       highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
 307     }
 308
 309
 310   {
 311     int i = 0;
 312     int j = 0;
 313
 314     while (i < scm_i_heap_segment_table_size
 315            && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
 316       i++;
 317
 318     /*
 319       We insert a new entry; if that happens to be before the
 320       "current" segment of a freelist, we must move the freelist index
 321       as well.
 322     */
 323     if (scm_i_master_freelist.heap_segment_idx >= i)
 324       scm_i_master_freelist.heap_segment_idx ++;
 325     if (scm_i_master_freelist2.heap_segment_idx >= i)
 326       scm_i_master_freelist2.heap_segment_idx ++;
 327
 328     for (j = scm_i_heap_segment_table_size; j > i; --j)
 329       scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];
 330
 331     scm_i_heap_segment_table [i] = seg;
 332     scm_i_heap_segment_table_size ++;
 333
 334     return i;
 335   }
 336 }
 337
 338 SCM
 339 scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl)
 340 {
 341   int i = fl->heap_segment_idx;
 342   SCM collected = SCM_EOL;
 343
 344   if (i == -1)
 345     i++;
 346
 347   for (;
 348        i < scm_i_heap_segment_table_size; i++)
 349     {
 350       if (scm_i_heap_segment_table[i]->freelist != fl)
 351         continue;
 352
 353       collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]);
 354
 355
 356       if (collected != SCM_EOL)       /* Don't increment i */
 357         break;
 358     }
 359
 360   fl->heap_segment_idx = i;
 361
 362   return collected;
 363 }
 364
 365
 366 void
 367 scm_i_reset_segments (void)
 368 {
 369   int i = 0;
 370   for (; i < scm_i_heap_segment_table_size; i++)
 371     {
 372       scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
 373       seg->next_free_card = seg->bounds[0];
 374     }
 375 }
 376
 377 /*
 378   Return a hashtab with counts of live objects, with tags as keys.
 379  */
 380
 381
 382 SCM
 383 scm_i_all_segments_statistics (SCM tab)
 384 {
 385   int i = 0;
 386   for (; i < scm_i_heap_segment_table_size; i++)
 387     {
 388       scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
 389       scm_i_heap_segment_statistics (seg, tab);
 390     }
 391
 392   return tab;
 393 }
 394
 395
 396
 397
 398 /*
 399   Determine whether the given value does actually represent a cell in
 400   some heap segment.  If this is the case, the number of the heap
 401   segment is returned.  Otherwise, -1 is returned.  Binary search is
 402   used to determine the heap segment that contains the cell.
 403
 404
 405   I think this function is too long to be inlined. --hwn
 406 */
 407 long int
 408 scm_i_find_heap_segment_containing_object (SCM obj)
 409 {
 410   if (!CELL_P (obj))
 411     return -1;
 412
 413   if ((scm_t_cell* ) obj < lowest_cell || (scm_t_cell*) obj >= highest_cell)
 414     return -1;
 415
 416
 417     {
 418       scm_t_cell *  ptr = SCM2PTR (obj);
 419       unsigned long int i = 0;
 420       unsigned long int j = scm_i_heap_segment_table_size - 1;
 421
 422       if (ptr < scm_i_heap_segment_table[i]->bounds[0])
 423         return -1;
 424       else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
 425         return -1;
 426       else
 427         {
 428           while (i < j)
 429             {
 430               if (ptr < scm_i_heap_segment_table[i]->bounds[1])
 431                 {
 432                   break;
 433                 }
 434               else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
 435                 {
 436                   i = j;
 437                   break;
 438                 }
 439               else
 440                 {
 441                   unsigned long int k = (i + j) / 2;
 442
 443                   if (k == i)
 444                     return -1;
 445                   else if (ptr <  scm_i_heap_segment_table[k]->bounds[1])
 446                     {
 447                       j = k;
 448                       ++i;
 449                       if (ptr <  scm_i_heap_segment_table[i]->bounds[0])
 450                         return -1;
 451                     }
 452                   else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
 453                     {
 454                       i = k;
 455                       --j;
 456                       if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
 457                         return -1;
 458                     }
 459                 }
 460             }
 461
 462           if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
 463             return -1;
 464           else if (SCM_GC_IN_CARD_HEADERP (ptr))
 465             return -1;
 466           else
 467             return i;
 468         }
 469     }
 470 }
 471
 472
 473 /*
 474   Important entry point: try to grab some memory, and make it into a
 475   segment.
 476
 477   RETURN: the index of the segment.
 478  */
 479 int
 480 scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
 481                             policy_on_error error_policy)
 482 {
 483   size_t len;
 484
 485   {
 486     /* Assure that the new segment is predicted to be large enough.
 487      *
 488      * New yield should at least equal GC fraction of new heap size, i.e.
 489      *
 490      *   y + dh > f * (h + dh)
 491      *
 492      *    y : yield
 493      *    f : min yield fraction
 494      *    h : heap size
 495      *   dh : size of new heap segment
 496      *
 497      * This gives dh > (f * h - y) / (1 - f)
 498      */
 499     float f = freelist->min_yield_fraction / 100.0;
 500     float h = SCM_HEAP_SIZE;
 501     float min_cells
 502       = (f * h - scm_gc_cells_collected) / (1.0 - f);
 503
 504     /* Make heap grow with factor 1.5 */
 505     len =  freelist->heap_size / 2;
 506 #ifdef DEBUGINFO
 507     fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
 508 #endif
 509
 510     if (len < min_cells)
 511       len = (unsigned long) min_cells;
 512     len *= sizeof (scm_t_cell);
 513     /* force new sampling */
 514     freelist->collected = LONG_MAX;
 515   }
 516
 517   if (len > scm_max_segment_size)
 518     len = scm_max_segment_size;
 519   if (len < SCM_MIN_HEAP_SEG_SIZE)
 520     len = SCM_MIN_HEAP_SEG_SIZE;
 521
 522   {
 523     scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
 524
 525     /* Allocate with decaying ambition. */
 526     while (len >= SCM_MIN_HEAP_SEG_SIZE)
 527       {
 528         if (scm_i_initialize_heap_segment_data (seg, len))
 529           {
 530             return scm_i_insert_segment (seg);
 531           }
 532
 533         len /= 2;
 534       }
 535   }
 536
 537   if (error_policy == abort_on_error)
 538     {
 539       fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
 540       abort ();
 541     }
 542   return -1;
 543 }
 544
 545 void
 546 scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist)
 547 {
 548   scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
 549
 550   if (init_heap_size < 1)
 551     {
 552       init_heap_size =  SCM_DEFAULT_INIT_HEAP_SIZE_1;
 553     }
 554
 555   if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
 556     {
 557       freelist->heap_segment_idx = scm_i_insert_segment (seg);
 558     }
 559
 560   /*
 561     Why the fuck  try twice? --hwn
 562    */
 563   if (!seg->malloced)
 564     {
 565       scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
 566     }
 567
 568   if (freelist->min_yield_fraction)
 569     freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
 570                             / 100);
 571 }