Back to index

plt-scheme  4.2.1
compact.c
Go to the documentation of this file.
00001 /*
00002   Precise GC for MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1999 Matthew Flatt
00005   All rights reserved.
00006 
00007   Please see the full copyright in the documentation.
00008 */
00009 
00010 #include <stdlib.h>
00011 #include <stdio.h>
00012 #include <string.h>
00013 #include "platforms.h"
00014 #include "gc2.h"
00015 
00016 #define NUMBER_OF_TAGS 512
00017 #include "compactgc_internal.h"
00018 #include "../src/schpriv.h"
00019 
00020 static THREAD_LOCAL CompactGC *GC;
00021 #define GCTYPE CompactGC
00022 #define GC_get_GC() (GC)
00023 #define ofm_malloc malloc
00024 
00025 /**************** Configuration ****************/
00026 
00027 #define GROW_FACTOR 1.5
00028 #define GROW_ADDITION 500000
00029 
00030 #define GENERATIONS 1
00031 
00032 /* Platform-specific disablers (`and'ed with GENERATIONS): */
00033 #define OS_X_GENERATIONS 1
00034 #define WIN32_GENERATIONS 1
00035 
00036 
00037 #ifdef NO_GC_SIGNALS
00038 # undef GENERATIONS
00039 # define GENERATIONS 0
00040 #endif
00041 
00042 #ifdef OS_X
00043 # if GENERATIONS
00044 #  undef GENERATIONS
00045 #  define GENERATIONS OS_X_GENERATIONS
00046 # endif
00047 #endif
00048 
00049 #ifdef _WIN32
00050 # if GENERATIONS
00051 #  undef GENERATIONS
00052 #  define GENERATIONS WIN32_GENERATIONS
00053 /* Under Windows, setting the unhandled-exception handler doesn't work
00054    within Windows callbacks. Perhaps in the future we can fix all
00055    callbacks to insert an appropriate wrapper. For now, we use
00056    AddVectoredExceptionHandler, but that's only available starting
00057    with XP. We detect the presence of AddVectoredExceptionHandler
00058    dynamically (and disable generations if it's not present), but we
00059    also make generations easy to disable entirely above. */
00060 # endif
00061 #endif
00062 
00063 #define USE_FREELIST 0
00064 
00065 /* When USE_FREELIST is on: */
00066 #define COMPACTING SELECTIVELY_COMPACT
00067 # define ALWAYS_COMPACT      2
00068 # define SELECTIVELY_COMPACT 1
00069 # define NEVER_COMPACT       0
00070 #define COMPACT_THRESHOLD 0.2
00071 
00072 #ifdef _WIN32
00073 # include <windows.h>
00074 # define gcINLINE _inline
00075 #endif
00076 #ifdef OSKIT
00077 # undef GENERATIONS
00078 # define GENERATIONS 0
00079 #endif
00080 
00081 #if defined(sparc) || defined(__sparc) || defined(__sparc__)
00082 # define ALIGN_DOUBLES 1
00083 #else
00084 # define ALIGN_DOUBLES 0
00085 #endif
00086 
00087 #define LOG_WORD_SIZE 2
00088 #define WORD_SIZE (1 << LOG_WORD_SIZE)
00089 #define WORD_BIT_COUNT (WORD_SIZE << 3)
00090 
00091 #define INCREMENT_CYCLE_COUNT_GROWTH 1048576
00092 
00093 
00094 #include "gc2_dump.h"
00095 
00096 #define BYTEPTR(x) ((char *)x)
00097 
00098 /* Debugging and performance tools: */
00099 #define TIME 0
00100 #define SEARCH 0
00101 #define CHECKS 0
00102 #define CHECK_STACK_PTRS 0
00103 #define NOISY 0
00104 #define MARK_STATS 0
00105 #define ALLOC_GC_PHASE 0
00106 #define SKIP_FORCED_GC 0
00107 #define RECORD_MARK_SRC 0
00108 #define KEEP_BACKPOINTERS 0
00109 #define DEFINE_MALLOC_FREE 0
00110 
00111 #ifdef MZ_GC_BACKTRACE
00112 # undef KEEP_BACKPOINTERS
00113 # define KEEP_BACKPOINTERS 1
00114 #endif
00115 
00116 #if TIME
00117 # include <sys/time.h>
00118 # include <sys/resource.h>
00119 # include <unistd.h>
00120 #endif
00121 
00122 #include "msgprint.c"
00123 
00124 /**************** Stack for mark phase ****************/
00125 #define MARK_STACK_MAX 4096
00126 static void *mark_stack[MARK_STACK_MAX];
00127 static unsigned short mark_stack_type[MARK_STACK_MAX];
00128 static long mark_stack_pos = 0;
00129 
00130 #if KEEP_BACKPOINTERS
00131 # undef RECORD_MARK_SRC
00132 # define RECORD_MARK_SRC 1
00133 /* Disabled generations, since old-page ifxups would be wrong,
00134    and even if that were fixed, the results would be confusing. */
00135 # undef GENERATIONS
00136 # define GENERATIONS 0
00137 #endif
00138 
00139 #if RECORD_MARK_SRC
00140 static void *mark_src;
00141 static int mark_type;
00142 static void *mark_src_stack[MARK_STACK_MAX];
00143 static int mark_src_type[MARK_STACK_MAX];
00144 
00145 static void *current_mark_src;
00146 static int current_mark_type;
00147 
00148 #define MTYPE_ROOT      6
00149 #define MTYPE_STACK     7
00150 #define MTYPE_FINALIZER 8
00151 #define MTYPE_WEAKLINK  9
00152 #define MTYPE_WEAKLINKX 10
00153 #define MTYPE_IMMOBILE  11
00154 #endif
00155 
00156 /********************* Client hooks *********************/
00157 void (*GC_collect_start_callback)(void);
00158 void (*GC_collect_end_callback)(void);
00159 void (*GC_collect_inform_callback)(int major_gc, long pre_used, long post_used);
00160 void (*GC_out_of_memory)(void);
00161 void (*GC_report_out_of_memory)(void);
00162 unsigned long (*GC_get_thread_stack_base)(void);
00163 
00164 void (*GC_mark_xtagged)(void *obj);
00165 void (*GC_fixup_xtagged)(void *obj);
00166 
00167 THREAD_LOCAL void **GC_variable_stack;
00168 
00169 void **GC_get_variable_stack() { return GC_variable_stack; }
00170 void GC_set_variable_stack(void **p) { GC_variable_stack = p; }
00171 void GC_register_root_custodian(void *_c) {}
00172 
00173 /********************* Type tags *********************/
00174 Type_Tag weak_box_tag = 42; /* set by client */
00175 Type_Tag ephemeron_tag = 42; /* set by client */
00176 Type_Tag weak_array_tag  = 42; /* set by client */
00177 Type_Tag pair_tag  = 42; /* set by client */
00178 
00179 #define gc_on_free_list_tag 511
00180 
00181 
00182 Size_Proc size_table[NUMBER_OF_TAGS];
00183 Mark_Proc mark_table[NUMBER_OF_TAGS];
00184 Fixup_Proc fixup_table[NUMBER_OF_TAGS];
00185 
00186 /****************** Memory Pages ******************/
00187 
00188 /* An MPage (as opposed to the OS's page) is an allocation region
00189    for a particular kind of object (tagged, atomic, array, etc.).
00190    It's also the granluarity of memory-mapping (i.e., taking an 
00191    arbitrary pointer an determining whether it's in the GC's
00192    domain.
00193 
00194    It has an associated offset table, which is mainly used for
00195    updating pointers during the fixup phase.
00196 */
00197 
00198 #if ALIGN_DOUBLES || DEFINE_MALLOC_FREE
00199 # define SQUASH_OFFSETS 0
00200 #else
00201 # define SQUASH_OFFSETS 1
00202 #endif
00203 /* Offsets must fit into 14 bits, saving 2 bits for tags.  But since
00204    the minimum size of an allocation is two words (unless
00205    ALIGN_DOUBLES), we can squash the index array into half as much
00206    space as we might otherwise. For example, let **** and #### be the
00207    offsets for indexes 0 and 3, respectively:
00208 
00209      ---- ---- ---- ---- ----
00210     |****|    |    |####|    |  Unsquashed representation
00211      ---- ---- ---- ---- ----
00212      -- -- -- -- --
00213     |**|**|  |##|##|  Squashed representation
00214      -- -- -- -- -- 
00215 */
00216 
00217 typedef unsigned short OffsetTy;
00218 #if SQUASH_OFFSETS
00219 typedef unsigned char OffsetArrTy;
00220 #else
00221 typedef unsigned short OffsetArrTy;
00222 #endif
00223 
00224 typedef unsigned char mtype_t;  /* object type */
00225 typedef unsigned char mflags_t; /* mark state, etc. */
00226 
00227 typedef struct MPage {
00228   mtype_t type;       /* object type */
00229   mflags_t flags;     /* mark state, etc. */
00230   short alloc_boundary;
00231   short compact_boundary;
00232   short age, refs_age, compact_to_age;
00233   union {
00234     OffsetArrTy *offsets;  /* for small objects */
00235     long size;             /* for one big object */
00236   } u;
00237   union {
00238     void **compact_to;     /* for small objects */
00239     void *bigblock_start;  /* for one big object */
00240   } o;
00241   void *block_start;       /* start of memory in this page */
00242   struct MPage *next, *prev; /* for linked list of pages */
00243 
00244   /* For mark-stack overflow, or slowing mark categories: */
00245   OffsetTy gray_start, gray_end; 
00246   struct MPage *gray_next;
00247 
00248 #if KEEP_BACKPOINTERS
00249   void **backpointer_page;
00250 #endif
00251 } MPage;
00252 
00253 /* Linked list of allocated pages: */
00254 static MPage *first, *last;
00255 
00256 /* For mark-stack overflow, or slowish mark categories. */
00257 static MPage *gray_first;
00258 
00259 /* For memory-mapping: */
00260 MPage **mpage_maps;
00261 
00262 /* MPage size: */
00263 #define LOG_MPAGE_SIZE 14
00264 #define MPAGE_SIZE (1 << LOG_MPAGE_SIZE)
00265 #define MPAGE_WORDS (1 << (LOG_MPAGE_SIZE - LOG_WORD_SIZE))
00266 #define MPAGE_MASK ((1 << LOG_MPAGE_SIZE) - 1)
00267 #define MPAGE_START ~MPAGE_MASK
00268 
00269 #define BIGBLOCK_MIN_SIZE (1 << (LOG_MPAGE_SIZE - 2))
00270 #define FREE_LIST_ARRAY_SIZE (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE)
00271 
00272 /* Offset-page size: */
00273 #define LOG_OPAGE_SIZE (LOG_MPAGE_SIZE - LOG_WORD_SIZE - SQUASH_OFFSETS)
00274 #define OPAGE_SIZE (sizeof(OffsetTy) << LOG_OPAGE_SIZE)
00275 
00276 /* We use a two-level table to map the universe. The MAP_SIZE is the
00277    size of the outer table, so LOG_MAP_SIZE is the number of high-order
00278    bits used to index the table. */
00279 #define LOG_MAP_SIZE 9
00280 #define LOG_MAPS_SIZE (WORD_BIT_COUNT - LOG_MAP_SIZE - LOG_MPAGE_SIZE)
00281 #define MAP_SIZE (1 << LOG_MAP_SIZE)
00282 #define MAPS_SIZE (1 << LOG_MAPS_SIZE)
00283 
00284 /* MASK_MASK followed by MAP_SHIFT gives the 2nd-page index. */
00285 #define MAPS_SHIFT (WORD_BIT_COUNT - LOG_MAPS_SIZE)
00286 #define MAP_MASK ((1 << (LOG_MAP_SIZE + LOG_MPAGE_SIZE)) - 1)
00287 #define MAP_SHIFT LOG_MPAGE_SIZE
00288 
00289 /* Allocation (MPage) types */
00290 #define MTYPE_NONE         0
00291 #define MTYPE_TAGGED       1
00292 #define MTYPE_ATOMIC       2
00293 #define MTYPE_TAGGED_ARRAY 3
00294 #define MTYPE_ARRAY        4
00295 #define MTYPE_XTAGGED      5
00296 #define MTYPE_MALLOCFREE   6
00297 
00298 /* Allocation flags */
00299 
00300 #define COLOR_MASK         0x3
00301 
00302 #define MFLAG_GRAY         0x1
00303 #define MFLAG_BLACK        0x2
00304 
00305 #define NONCOLOR_MASK      0xFC
00306 
00307 #define MFLAG_BIGBLOCK     0x4
00308 #define MFLAG_CONTINUED    0x8
00309 
00310 #define MFLAG_OLD          0x10
00311 #define MFLAG_MODIFIED     0x20
00312 #define MFLAG_INITED       0x40
00313 #define MFLAG_MARK         0x80
00314 
00315 /* Offset table manipulations */
00316 
00317 #define OFFSET_COLOR_UNMASKED(offsets, pos) (offsets[pos])
00318 #define OFFSET_COLOR(offsets, pos) (offsets[pos] & COLOR_MASK)
00319 #define OFFSET_SET_COLOR_UNMASKED(offsets, pos, c) (offsets[pos] = c)
00320 
00321 #if SQUASH_OFFSETS
00322 # define OFFSET_HI_MASK 0xFC
00323 # define OFFSET_LO_MASK 0xFF
00324 # define OFFSET_HI_SHIFT 6
00325 # define OFFSET_SIZE(offsets, pos) (((OffsetTy)(offsets[pos] & OFFSET_HI_MASK) << OFFSET_HI_SHIFT) | (offsets[(pos)+1]))
00326 # define OFFSET_SET_SIZE_UNMASKED(offsets, pos, s) (offsets[pos] = (((s) >> OFFSET_HI_SHIFT) & OFFSET_HI_MASK), offsets[(pos)+1] = ((s) & OFFSET_LO_MASK))
00327 #else
00328 # define OFFSET_SHIFT 2
00329 # define OFFSET_SIZE(offsets, pos) ((offsets[pos]) >> OFFSET_SHIFT)
00330 # define OFFSET_SET_SIZE_UNMASKED(offsets, pos, s) (offsets[pos] = ((s) << OFFSET_SHIFT))
00331 #endif
00332 
00333 /* Special tags */
00334 
00335 #define SKIP ((Type_Tag)0x7000)
00336 #define TAGGED_EOM ((Type_Tag)0x6000)
00337 #define UNTAGGED_EOM   (MPAGE_SIZE + 1)
00338 
00339 /* One MSet for every type of MPage: */
00340 
00341 typedef struct {
00342   void **low, **high;
00343   MPage *malloc_page, *compact_page;
00344   void **compact_to;
00345   OffsetTy compact_to_offset;
00346 #if USE_FREELIST
00347   void *free_lists[FREE_LIST_ARRAY_SIZE];
00348 #endif
00349 } MSet;
00350 
00351 #define NUM_SETS 5
00352 #define NUM_TAGGED_SETS 1
00353 #define NUM_NONATOMIC_SETS 4
00354 static MSet tagged, atomic, array, tagged_array, xtagged;
00355 static MSet *sets[NUM_SETS]; /* First one is tagged, last one is atomic */
00356 
00357 /********************* Statistics *********************/
00358 static long page_allocations = 0;
00359 
00360 static long memory_in_use, gc_threshold = GROW_ADDITION, max_memory_use;
00361 static int prev_memory_in_use, memory_use_growth;
00362 #if USE_FREELIST
00363 static long on_free_list;
00364 # define FREE_LIST_DELTA (on_free_list << LOG_WORD_SIZE)
00365 #else
00366 # define FREE_LIST_DELTA 0
00367 #endif
00368 
00369 #if GENERATIONS
00370 static int generations_available = 1;
00371 static long num_seg_faults;
00372 #endif
00373 
00374 static int cycle_count = 0, compact_count = 0, gc_count = 0;
00375 static int skipped_pages, scanned_pages, young_pages, inited_pages;
00376 
00377 static long iterations;
00378 
00379 #if TIME
00380 static long mark_stackoflw;
00381 #endif
00382 
00383 static int fnl_weak_link_count;
00384 
00385 static int ran_final;
00386 static int running_finals;
00387 
00388 /******************** Misc ********************/
00389 
00390 /* The answer for all 0-byte requests: */
00391 static char zero_sized[4];
00392 
00393 /* Temporary pointer-holder used by routines that allocate */
00394 static void *park[2], *park_save[2];
00395 
00396 static int during_gc, avoid_collection;
00397 
00398 static int resolve_for_fixup = 0;
00399 
00400 static MPage *find_page(void *p);
00401 
00402 #if CHECKS
00403 static void CRASH(int where)
00404 {
00405   GCPRINT(GCOUTF, "crash @%d\n", where);
00406   GCFLUSHOUT();
00407 #ifdef _WIN32
00408   DebugBreak();
00409 #endif
00410   abort();
00411 }
00412 
00413 #if DEFINE_MALLOC_FREE
00414 static void check_not_freed(MPage *page, const void *p);
00415 #endif
00416 
00417 static int just_checking, the_size;
00418 #endif
00419 
00420 #include "my_qsort.c"
00421 
00422 /******************************************************************************/
00423 /*                     OS-specific low-level allocator                        */
00424 /******************************************************************************/
00425 
00426 #define DONT_NEED_MAX_HEAP_SIZE
00427 #include "vm.c"
00428 
00429 
00430 static void *malloc_pages(size_t len, size_t alignment)
00431 {
00432   page_allocations += len;
00433   return vm_malloc_pages(GC->vm, len, alignment, 0);
00434 }
00435 
00436 static void free_pages(void *p, size_t len)
00437 {
00438   page_allocations -= len;
00439   vm_free_pages(GC->vm, p, len);
00440 }
00441 
00442 /******************************************************************************/
00443 /*                              client setup                                  */
00444 /******************************************************************************/
00445 
00446 static unsigned long stack_base;
00447 
00448 void GC_set_stack_base(void *base)
00449 {
00450   stack_base = (unsigned long)base;
00451 }
00452 
00453 void CompactGC_initialize(CompactGC *gc) {
00454   memset(gc, 0, sizeof(CompactGC));
00455   gc->vm = vm_create();
00456 }
00457 
00458 void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox)
00459 {
00460   CompactGC *gc;
00461   weak_box_tag = weakbox;
00462   ephemeron_tag = ephemeron;
00463   weak_array_tag = weakarray;
00464   pair_tag = pair;
00465 
00466   gc = malloc(sizeof(CompactGC));
00467   GC = gc;
00468   CompactGC_initialize(gc);
00469 }
00470 
00471 void GC_register_traversers(Type_Tag tag, Size_Proc size, Mark_Proc mark, Fixup_Proc fixup, 
00472                          int is_constant_size, int is_atomic)
00473 {
00474   if (is_constant_size) {
00475     long v;
00476     v = size(NULL);
00477     if (v < 100)
00478       size = (Size_Proc)v;
00479   }
00480 
00481   size_table[tag] = size;
00482   mark_table[tag] = mark;
00483   fixup_table[tag] = fixup;
00484 }
00485 
00486 /******************************************************************************/
00487 /*                               root table                                   */
00488 /******************************************************************************/
00489 
00490 #include "roots.c"
00491 
00492 void GC_register_thread(void *p, void *c)
00493 {
00494 }
00495 void GC_register_new_thread(void *p, void *c)
00496 {
00497 }
00498 
00499 /******************************************************************************/
00500 /*                             immobile box                                   */
00501 /******************************************************************************/
00502 
00503 /* The ImmobileBox struct is an internal view, only. To a GC client,
00504    an immobile box starts with a longword for a pointer, and the rest
00505    is undefined. */
00506 typedef struct ImmobileBox {
00507   void *p; /* must be first in the record */
00508   struct ImmobileBox *next, *prev;
00509 } ImmobileBox;
00510 
00511 static ImmobileBox *immobile;
00512 
00513 void **GC_malloc_immobile_box(void *p)
00514 {
00515   ImmobileBox *ib;
00516 
00517   ib = (ImmobileBox *)malloc(sizeof(ImmobileBox));
00518   ib->p = p;
00519   ib->next = immobile;
00520   if (immobile)
00521     immobile->prev = ib;
00522   ib->prev = NULL;
00523 
00524   immobile = ib;
00525 
00526   return (void **)ib;
00527 }
00528 
00529 void GC_free_immobile_box(void **b)
00530 {
00531   ImmobileBox *ib = (ImmobileBox *)b;
00532 
00533   if (!ib)
00534     return;
00535 
00536   if (ib->prev)
00537     ib->prev->next = ib->next;
00538   else
00539     immobile = ib->next;
00540   if (ib->next)
00541     ib->next->prev = ib->prev;
00542 
00543   free(ib);
00544 }
00545 
00546 /******************************************************************************/
00547 /*                             free list element                              */
00548 /******************************************************************************/
00549 
00550 #if USE_FREELIST
00551 
00552 static int size_on_free_list(void *p)
00553 {
00554   return ((OffsetTy *)p)[1];
00555 }
00556 
00557 #endif
00558 
00559 /******************************************************************************/
00560 /*                           weak arrays and boxes                            */
00561 /******************************************************************************/
00562 
00563 static int is_marked(CompactGC *gc, void *p);
00564 #define weak_box_resolve(p) (p)
00565 
00566 #include "weak.c"
00567 
00568 /******************************************************************************/
00569 /*                             finalization                                   */
00570 /******************************************************************************/
00571 
00572 static int is_finalizable_page(CompactGC *gc, void *p)
00573 {
00574   MPage *page;
00575   page = find_page(p);
00576   return page && page->type;
00577 }
00578 
00579 #include "fnls.c"
00580 
00581 static Fnl *run_queue, *last_in_queue;
00582 
00583 static void mark_finalizer(Fnl *fnl)
00584 {
00585   gcMARK(fnl->next);
00586   gcMARK(fnl->data);
00587   /* !eager_level => queued for run: */
00588   if (!fnl->eager_level) {
00589     gcMARK(fnl->p);
00590   }
00591 #if CHECKS
00592   if (!fnl->tagged && fnl->size < BIGBLOCK_MIN_SIZE) {
00593     if (((long *)fnl->p)[-1] != fnl->size)
00594       CRASH(2);
00595   }
00596 #endif
00597 }
00598 
00599 static void fixup_finalizer(Fnl *fnl)
00600 {
00601 #if CHECKS
00602   static void *old_fnl_p;
00603   static MPage *old_fnl_page;
00604   
00605   old_fnl_p = fnl->p;
00606   old_fnl_page = find_page(fnl->p);
00607 #endif
00608   
00609   gcFIXUP(fnl->next);
00610   gcFIXUP(fnl->data);
00611   gcFIXUP(fnl->p);
00612 
00613 #if CHECKS
00614   if (!fnl->tagged && fnl->size < BIGBLOCK_MIN_SIZE) {
00615     if (!(((long)fnl->p) & MPAGE_MASK))
00616       CRASH(3);
00617   }
00618 #endif
00619 }
00620 
00621 typedef struct Fnl_Weak_Link {
00622   void *p;
00623   int offset;
00624   void *saved;
00625   struct Fnl_Weak_Link *next;
00626 } Fnl_Weak_Link;
00627 
00628 static Fnl_Weak_Link *fnl_weaks;
00629 
00630 static void mark_finalizer_weak_link(Fnl_Weak_Link *wl)
00631 {
00632   gcMARK(wl->next);
00633 }
00634 
00635 static void fixup_finalizer_weak_link(Fnl_Weak_Link *wl)
00636 {
00637   gcFIXUP(wl->next);
00638   gcFIXUP(wl->p);
00639 }
00640 
00641 void GC_finalization_weak_ptr(void **p, int offset)
00642 {
00643   Fnl_Weak_Link *wl;
00644 
00645 #if CHECKS
00646   if (offset < 0)
00647     CRASH(6);
00648 #endif
00649 
00650   /* Allcation might trigger GC, so we use park: */
00651   park[0] = p;
00652 
00653   wl = (Fnl_Weak_Link *)GC_malloc_atomic(sizeof(Fnl_Weak_Link));
00654 
00655   p = park[0];
00656   park[0] = NULL;
00657 
00658   wl->p = p;
00659   wl->next = fnl_weaks;
00660   wl->offset = offset * sizeof(void*);
00661 
00662   fnl_weaks = wl;
00663 
00664   fnl_weak_link_count++;
00665 }
00666 
00667 /******************************************************************************/
00668 /*                             alloc state info                               */
00669 /******************************************************************************/
00670 
00671 /* Works anytime: */
00672 static MPage *find_page(void *p) 
00673 {
00674   unsigned long g = ((unsigned long)p >> MAPS_SHIFT);
00675   MPage *map;
00676 
00677   map = mpage_maps[g];
00678   if (map) {
00679     unsigned long addr = (((unsigned long)p & MAP_MASK) >> MAP_SHIFT);
00680     MPage *page;
00681 
00682     page = map + addr;
00683     return page;
00684   }
00685   
00686   return NULL;  
00687 }
00688 
00689 int GC_is_allocated(void *p)
00690 {
00691   return !!find_page(p);
00692 }
00693 
00694 /* Works only during GC: */
00695 static int is_marked(CompactGC *gc, void *p)
00696 {
00697   unsigned long g = ((unsigned long)p >> MAPS_SHIFT);
00698   MPage *map;
00699 
00700   map = mpage_maps[g];
00701   if (map) {
00702     MPage *page;
00703 
00704     page = map + (((unsigned long)p & MAP_MASK) >> MAP_SHIFT);
00705 #if DEFINE_MALLOC_FREE
00706     if (page->type == MTYPE_MALLOCFREE)
00707       return 1;
00708 #endif
00709     if (page->flags & MFLAG_BIGBLOCK) {
00710       if (page->flags & MFLAG_CONTINUED)
00711         return is_marked(gc, page->o.bigblock_start);
00712       else
00713         return (page->flags & (COLOR_MASK | MFLAG_OLD));
00714     } else {
00715       if (page->flags & MFLAG_OLD)
00716         return 1;
00717       else if (page->flags & COLOR_MASK) {
00718         long offset = ((long)p & MPAGE_MASK) >> LOG_WORD_SIZE;
00719 
00720         if (page->type > MTYPE_TAGGED)
00721           offset -= 1;
00722 
00723         return OFFSET_COLOR(page->u.offsets, offset);
00724       } else if ((long)p & 0x1)
00725         return 1;
00726       else
00727         return 0;
00728     }
00729   }
00730 
00731   return 1;
00732 }
00733 
00734 #if SEARCH
00735 void *search_for, *search_mark = 0x7;
00736 long search_size;
00737 
00738 void stop()
00739 {
00740   GCPRINT(GCOUTF, "stopped\n");
00741 }
00742 #endif
00743 
00744 /******************************************************************************/
00745 /*                               init phase                                   */
00746 /******************************************************************************/
00747 
00748 /* Init: set color to white and install offsets (to indicate the
00749    offset to the start of and allocation block) for marking. */
00750 
00751 #if CHECKS
00752 static void **prev_ptr, **prev_prev_ptr, **prev_prev_prev_ptr;
00753 static void **prev_prev_prev_prev_ptr, **prev_prev_prev_prev_prev_ptr;
00754 static void **prev_var_stack;
00755 #endif
00756 
00757 static void init_tagged_mpage(void **p, MPage *page)
00758 {
00759   OffsetTy offset = 0;
00760   OffsetArrTy *offsets;
00761   void **top;
00762 
00763   page->flags = (page->flags & NONCOLOR_MASK);
00764   offsets = page->u.offsets;
00765   top = p + MPAGE_WORDS;
00766 
00767   page->alloc_boundary = MPAGE_WORDS;
00768   
00769   while (p < top) {
00770     Type_Tag tag;
00771     long size;
00772 
00773     tag = *(Type_Tag *)p;
00774 
00775     if (tag == TAGGED_EOM) {
00776       /* Remember empty space for prop and compact:  */
00777       page->alloc_boundary = offset;
00778       break;
00779     }
00780 
00781 #if ALIGN_DOUBLES
00782     if (tag == SKIP) {
00783       OFFSET_SET_SIZE_UNMASKED(offsets, offset, 1);
00784       offset++;
00785       p++;
00786     } else {
00787 #endif
00788 
00789 #if CHECKS
00790       if ((tag < 0) || (tag >= NUMBER_OF_TAGS) || !size_table[tag]) {
00791        GCPRINT(GCOUTF, "bad tag: %d at %lx\n", tag, (long)p);
00792        GCFLUSHOUT();
00793        CRASH(7);
00794       }
00795       prev_prev_prev_prev_prev_ptr = prev_prev_prev_prev_ptr;
00796       prev_prev_prev_prev_ptr = prev_prev_prev_ptr;
00797       prev_prev_prev_ptr = prev_prev_ptr;
00798       prev_prev_ptr = prev_ptr;
00799       prev_ptr = p;
00800       prev_var_stack = GC_variable_stack;
00801 #endif
00802 
00803       {
00804        Size_Proc size_proc;
00805        
00806        size_proc = size_table[tag];
00807        if (((long)size_proc) < 100)
00808          size = (long)size_proc;
00809        else
00810          size = size_proc(p);
00811       }
00812 
00813 #if CHECKS
00814       if (size < 1) {
00815        CRASH(57);
00816       }
00817 #endif
00818 
00819       OFFSET_SET_SIZE_UNMASKED(offsets, offset, size);
00820       offset += size;
00821 
00822 #if CHECKS
00823       if (prev_var_stack != GC_variable_stack) {
00824        CRASH(8);
00825       }
00826 #endif
00827       
00828       p += size;
00829 #if ALIGN_DOUBLES
00830     }
00831 #endif
00832   }
00833 
00834   inited_pages++;
00835 }
00836 
00837 static void init_untagged_mpage(void **p, MPage *page)
00838 {
00839   OffsetTy offset = 0;
00840   OffsetArrTy *offsets;
00841   void **top;
00842 
00843   page->flags = (page->flags & NONCOLOR_MASK);
00844   offsets = page->u.offsets;
00845   page->alloc_boundary = MPAGE_WORDS;
00846 
00847   top = p + MPAGE_WORDS;
00848 
00849   while (p < top) {
00850     long size;
00851 
00852     size = *(long *)p + 1;
00853 
00854     if (size == UNTAGGED_EOM) {
00855       /* Remember empty space for prop:  */
00856       page->alloc_boundary = offset;
00857       
00858       break;
00859     }
00860 
00861 #if CHECKS
00862     if (0 && page->type == MTYPE_XTAGGED) {
00863       just_checking = 1;
00864       GC_mark_xtagged(p + 1);
00865       just_checking = 0;
00866     }
00867 
00868     the_size = size;
00869 #endif
00870 
00871     OFFSET_SET_SIZE_UNMASKED(offsets, offset, 0);
00872     offset += size;
00873 
00874     p += size;
00875   } 
00876 
00877   inited_pages++;
00878 }
00879 
00880 static void init_all_mpages(int young)
00881 {
00882   MPage *page;
00883 
00884   for (page = first; page; page = page->next) {
00885     int is_old = (page->age > young);
00886 #if GENERATIONS
00887     void *p = page->block_start;
00888 #endif
00889        
00890     if (!is_old && !(page->flags & MFLAG_MODIFIED)) {
00891 #if GENERATIONS
00892       if (generations_available) {
00893        if (page->flags & MFLAG_BIGBLOCK)
00894          vm_protect_pages((void *)p, page->u.size, 1);
00895        else
00896          vm_protect_pages((void *)p, MPAGE_SIZE, 1);
00897       }
00898 #endif
00899       page->flags |= MFLAG_MODIFIED;
00900     }
00901 
00902     if (is_old) {
00903       page->flags -= (page->flags & MFLAG_MARK);
00904       page->flags |= MFLAG_OLD;
00905     } else {
00906       page->flags -= (page->flags & MFLAG_OLD);
00907       page->flags |= MFLAG_MARK;
00908       young_pages++;
00909     }
00910       
00911     if (!(page->flags & MFLAG_INITED)) {
00912       void *p = page->block_start;
00913 
00914       if (page->flags & MFLAG_BIGBLOCK) {
00915        page->flags = (page->flags & NONCOLOR_MASK);
00916        page->flags |= MFLAG_INITED;
00917       } else {
00918        if (is_old) {
00919          if (page->type <= MTYPE_TAGGED)
00920            init_tagged_mpage((void **)p, page);
00921          else
00922            init_untagged_mpage((void **)p, page);
00923          page->flags |= MFLAG_INITED;
00924        } else {
00925          /* Young pages: initialize lazily as needed by `mark'.
00926             Not initialized means full page is garbage. */
00927          page->flags = (page->flags & NONCOLOR_MASK);
00928        }
00929 
00930        if (is_old) {
00931          skipped_pages++;
00932        }
00933       }
00934     } else {
00935        if (is_old) 
00936         skipped_pages++;
00937       /* Clear color flags: */
00938       page->flags = (page->flags & NONCOLOR_MASK);
00939     }
00940 
00941     if (is_old
00942        && ((page->refs_age <= young)
00943            || (page->flags & MFLAG_MODIFIED))
00944        && (page->type != MTYPE_ATOMIC)) {
00945       /* Offsets inited; need to set gray flag */
00946       page->flags |= MFLAG_GRAY;
00947       
00948       page->gray_next = gray_first;
00949       gray_first = page;
00950       
00951       page->gray_start = 0;
00952       page->gray_end = page->alloc_boundary - 2;
00953 
00954       if (!(page->flags & MFLAG_MODIFIED)) {
00955 #if GENERATIONS
00956        if (generations_available) {
00957          if (page->flags & MFLAG_BIGBLOCK)
00958            vm_protect_pages((void *)p, page->u.size, 1);
00959          else
00960            vm_protect_pages((void *)p, MPAGE_SIZE, 1);
00961        }
00962 #endif
00963        page->flags |= MFLAG_MODIFIED;
00964       }
00965 
00966       scanned_pages++;
00967     }
00968   }
00969 }
00970 
00971 /******************************************************************************/
00972 /*                               mark phase                                   */
00973 /******************************************************************************/
00974 
00975 /* Mark: mark a block as reachable. */
00976 
00977 #if MARK_STATS
00978 long mark_calls, mark_hits, mark_recalls, mark_colors, mark_many, mark_slow;
00979 #endif
00980 
00981 void GC_mark(const void *p)
00982 {
00983   unsigned long g;
00984   MPage *map;
00985 
00986 #if CHECKS
00987   if (just_checking) {
00988     return;
00989   }
00990 #endif
00991 #if MARK_STATS
00992   mark_calls++;
00993 #endif
00994 
00995   if ((long)p & 0x1) return;
00996   g = ((unsigned long)p >> MAPS_SHIFT);
00997 
00998   map = mpage_maps[g];
00999   if (map) {
01000     MPage *page;
01001     mflags_t flags;
01002 
01003     page = map + (((unsigned long)p & MAP_MASK) >> MAP_SHIFT);
01004 
01005 #if SEARCH
01006     if (p == search_mark) {
01007       stop();
01008     }
01009 #endif
01010 
01011 #if DEFINE_MALLOC_FREE
01012     if (page->type == MTYPE_MALLOCFREE) {
01013 #if CHECKS
01014       check_not_freed(page, p);
01015 #endif
01016       return;
01017     }
01018 #endif
01019 
01020     flags = page->flags;
01021     if (flags & (MFLAG_MARK | MFLAG_CONTINUED)) {
01022 #if MARK_STATS
01023       mark_hits++;
01024 #endif
01025 
01026       if (flags & MFLAG_BIGBLOCK) {
01027        if (flags & MFLAG_CONTINUED) {
01028          void *p2;
01029          unsigned long g2;
01030 #if MARK_STATS
01031          mark_recalls++;
01032 #endif
01033          p2 = page->o.bigblock_start;
01034          g2 = ((unsigned long)p2 >> MAPS_SHIFT);
01035          page = mpage_maps[g2] + (((unsigned long)p2 & MAP_MASK) >> MAP_SHIFT);
01036          flags = page->flags;
01037 
01038          if (!(flags & MFLAG_MARK))
01039            return;
01040        }
01041 
01042        if (!(flags & COLOR_MASK)) {
01043 #if MARK_STATS
01044          mark_colors++;
01045 #endif
01046          page->flags = (flags | MFLAG_GRAY);
01047          
01048          if (page->type != MTYPE_ATOMIC) {
01049            page->gray_next = gray_first;
01050            gray_first = page;
01051          }
01052 
01053 #if KEEP_BACKPOINTERS
01054          page->backpointer_page = mark_src;
01055 #endif
01056        }
01057       } else {
01058        long offset;
01059        OffsetArrTy v;
01060        mtype_t type;
01061        
01062        type = page->type;
01063 
01064        /* Check for lazy initialization: */
01065        if (!(flags & MFLAG_INITED)) {
01066          if (type <= MTYPE_TAGGED)
01067            init_tagged_mpage((void **)page->block_start, page);
01068          else
01069            init_untagged_mpage((void **)page->block_start, page);
01070          flags |= MFLAG_INITED;
01071          page->flags = flags;
01072        }
01073 
01074        if (type > MTYPE_TAGGED) {
01075 #if CHECKS
01076          if (!((long)p & MPAGE_MASK)) {
01077            /* Can't point to beginning of non-tagged block! */
01078            CRASH(9);
01079          }
01080 #endif
01081          p = BYTEPTR(p) - WORD_SIZE;
01082        }
01083 
01084        offset = ((long)p & MPAGE_MASK) >> LOG_WORD_SIZE;
01085 
01086 #if CHECKS
01087        if (offset >= page->alloc_boundary) {
01088          /* Past allocation region. */
01089          CRASH(10);
01090        }
01091 #endif
01092 
01093        v = OFFSET_COLOR_UNMASKED(page->u.offsets, offset);
01094        if (!(v & COLOR_MASK)) {
01095 #if MARK_STATS
01096          mark_colors++;
01097 #endif
01098 
01099          switch(type) {
01100          case MTYPE_ATOMIC:
01101            OFFSET_SET_COLOR_UNMASKED(page->u.offsets, offset, v | MFLAG_BLACK);
01102            if (!(flags & MFLAG_BLACK)) {
01103              page->flags = (flags | MFLAG_BLACK);
01104            }
01105 #if KEEP_BACKPOINTERS
01106            page->backpointer_page[offset] = mark_src;
01107 #endif
01108            break;
01109          case MTYPE_TAGGED:
01110 #if CHECKS
01111            {
01112              Type_Tag tag = *(Type_Tag *)p;
01113              if ((tag < 0) || (tag >= NUMBER_OF_TAGS) || !size_table[tag]) {
01114               GCPRINT(GCOUTF, "bad tag: %d at %lx\n", tag, (long)p);
01115               CRASH(11);
01116              }
01117            }
01118 #endif
01119          case MTYPE_XTAGGED:
01120          case MTYPE_ARRAY:
01121            if (mark_stack_pos < MARK_STACK_MAX) {
01122              page->flags = (flags | MFLAG_BLACK);
01123              OFFSET_SET_COLOR_UNMASKED(page->u.offsets, offset, v | MFLAG_BLACK); /* black can mean on stack */
01124 # if RECORD_MARK_SRC
01125 #  if CHECKS
01126              if ((long)mark_src & 0x1) CRASH(12);
01127 #  endif
01128              mark_src_stack[mark_stack_pos] = mark_src;
01129              mark_src_type[mark_stack_pos] = mark_type;
01130 # endif
01131              mark_stack[mark_stack_pos] = (void *)p;
01132              mark_stack_type[mark_stack_pos++] = type;
01133 #if KEEP_BACKPOINTERS
01134              page->backpointer_page[offset] = mark_src;
01135 #endif
01136              break;
01137            }
01138          default: /* ^^^ fallthrough */
01139            OFFSET_SET_COLOR_UNMASKED(page->u.offsets, offset, v | MFLAG_GRAY);
01140 #if TIME
01141            mark_stackoflw++;
01142 #endif
01143 #if KEEP_BACKPOINTERS
01144            page->backpointer_page[offset] = mark_src;
01145 #endif
01146            if (!(flags & MFLAG_GRAY)) {
01147              page->flags = (flags | MFLAG_GRAY);
01148              
01149              page->gray_next = gray_first;
01150              gray_first = page;
01151              
01152              page->gray_start = offset;
01153              page->gray_end = offset;
01154            } else {
01155              if (page->gray_start > offset)
01156               page->gray_start = offset;
01157              if (page->gray_end < offset)
01158               page->gray_end = offset;
01159            }
01160          }
01161        } else {
01162 #if CHECKS
01163          if (!(flags & COLOR_MASK)) {
01164            CRASH(13);
01165          }
01166 #endif
01167        }
01168       }
01169     }
01170   }
01171 }
01172 
01173 /******************************************************************************/
01174 /*                               prop phase                                   */
01175 /******************************************************************************/
01176 
01177 /* Propoagate: for each marked object, mark objects it
01178    reaches... until fixpoint. */
01179 
01180 static void propagate_tagged_mpage(void **bottom, MPage *page)
01181 {
01182   OffsetTy offset;
01183   OffsetArrTy *offsets;
01184   void **p, **graytop;
01185 
01186   offsets = page->u.offsets;
01187 
01188   offset = page->gray_start;
01189   p = bottom + offset;
01190   graytop = bottom + page->gray_end;
01191   
01192   while (p <= graytop) {
01193     OffsetArrTy v;
01194     Type_Tag tag;
01195     long size;
01196     
01197     tag = *(Type_Tag *)p;
01198 
01199 #if ALIGN_DOUBLES
01200     if (tag != SKIP) {
01201 #endif
01202 
01203 #if RECORD_MARK_SRC
01204       mark_src = p;
01205       mark_type = MTYPE_TAGGED;
01206 #endif
01207       
01208       v = OFFSET_COLOR_UNMASKED(offsets, offset);
01209       size = OFFSET_SIZE(offsets, offset);
01210       if (v & MFLAG_GRAY) {
01211        v -= MFLAG_GRAY;
01212        v |= MFLAG_BLACK;
01213        OFFSET_SET_COLOR_UNMASKED(offsets, offset, v);
01214        mark_table[tag](p);
01215       }
01216        
01217 #if ALIGN_DOUBLES
01218     } else
01219       size = 1;
01220 #endif
01221 
01222     p += size;
01223     offset += size;
01224   }
01225 
01226 #if MARK_STATS
01227   mark_many++;
01228 #endif
01229 
01230 #if MARK_STATS
01231   if (page->flags & MFLAG_GRAY) {
01232     mark_slow++;
01233   }
01234 #endif
01235 }
01236 
01237 static void propagate_tagged_whole_mpage(void **p, MPage *page)
01238 {
01239   void **top;
01240 
01241   top = p + MPAGE_WORDS;
01242   
01243   while (p < top) {
01244     Type_Tag tag;
01245     long size;
01246 
01247     tag = *(Type_Tag *)p;
01248 
01249     if (tag == TAGGED_EOM) {
01250       break;
01251     }
01252 
01253 #if ALIGN_DOUBLES
01254     if (tag == SKIP) {
01255       p++;
01256     } else {
01257 #endif
01258 
01259 #if RECORD_MARK_SRC
01260       mark_src = p;
01261       mark_type = MTYPE_TAGGED;
01262 #endif
01263 
01264       size = mark_table[tag](p);
01265 
01266       p += size;
01267 
01268 #if ALIGN_DOUBLES
01269     }
01270 #endif
01271   }
01272 }
01273 
01274 static void propagate_array_mpage(void **bottom, MPage *page)
01275 {
01276   OffsetTy offset;
01277   OffsetArrTy *offsets;
01278   void **p, **top;
01279 
01280   offset = page->gray_start;
01281   p = bottom + offset;
01282   top = bottom + page->gray_end;
01283   offsets = page->u.offsets;
01284 
01285   while (p <= top) {
01286     OffsetArrTy v;
01287     long size;
01288 
01289     size = *(long *)p + 1;
01290        
01291 #if CHECKS
01292     if ((size < 2) || (size > MPAGE_WORDS)) {
01293       CRASH(14);
01294     }
01295     prev_ptr = p;
01296 #endif
01297 
01298     v = OFFSET_COLOR_UNMASKED(offsets, offset);
01299     if (v & MFLAG_GRAY) {
01300       int i;
01301 
01302 #if RECORD_MARK_SRC
01303       mark_src = p + 1;
01304       mark_type = MTYPE_ARRAY;
01305 #endif
01306 
01307       v -= MFLAG_GRAY;
01308       v |= MFLAG_BLACK;
01309       OFFSET_SET_COLOR_UNMASKED(offsets, offset, v);
01310       
01311       for (i = 1; i < size; i++) {
01312        gcMARK(p[i]);
01313       }
01314     }
01315     
01316     p += size;
01317     offset += size;
01318 
01319 #if CHECKS
01320     if ((p > bottom + MPAGE_WORDS + 1) || (p < bottom)) {
01321       CRASH(15);
01322     }
01323 #endif
01324   }
01325 }
01326 
01327 static void propagate_array_whole_mpage(void **p, MPage *page)
01328 {
01329   void **top;
01330 
01331   top = p + MPAGE_WORDS;
01332 
01333   while (p < top) {
01334     long size, i;
01335 
01336     size = *(long *)p + 1;
01337 
01338     if (size == UNTAGGED_EOM) {
01339       break;
01340     }
01341 
01342 #if RECORD_MARK_SRC
01343     mark_src = p + 1;
01344     mark_type = MTYPE_ARRAY;
01345 #endif
01346 
01347     for (i = 1; i < size; i++) {
01348       gcMARK(p[i]);
01349     }
01350 
01351     p += size;
01352   } 
01353 }
01354 
01355 static void propagate_tagged_array_mpage(void **bottom, MPage *page)
01356 {
01357   OffsetTy offset;
01358   OffsetArrTy *offsets;
01359   void **p, **top;
01360 
01361   offset = page->gray_start;
01362   p = bottom + offset;
01363   top = bottom + page->gray_end;
01364   offsets = page->u.offsets;
01365 
01366   while (p <= top) {
01367     OffsetArrTy v;
01368     int size;
01369     
01370     size = *(long *)p + 1;
01371 
01372     v = OFFSET_COLOR_UNMASKED(offsets, offset);
01373     if (v & MFLAG_GRAY) {
01374       v -= MFLAG_GRAY;
01375       v |= MFLAG_BLACK;
01376       OFFSET_SET_COLOR_UNMASKED(offsets, offset, v);
01377 
01378       {
01379        int i, elem_size;
01380        void **mp = p + 1;
01381        Type_Tag tag;
01382        Mark_Proc traverse;
01383        
01384 #if RECORD_MARK_SRC
01385        mark_src = mp;
01386        mark_type = MTYPE_TAGGED_ARRAY;
01387 #endif
01388 
01389        size--;
01390        tag = *(Type_Tag *)mp;
01391 
01392        traverse = mark_table[tag];
01393        elem_size = traverse(mp);
01394        mp += elem_size;
01395        for (i = elem_size; i < size; i += elem_size, mp += elem_size)
01396          traverse(mp);
01397 
01398        size++;
01399       }
01400     }
01401     
01402     p += size;
01403     offset += size;
01404   }
01405 }
01406 
01407 static void propagate_tagged_array_whole_mpage(void **p, MPage *page)
01408 {
01409   void **top;
01410 
01411   top = p + MPAGE_WORDS;
01412 
01413   while (p < top) {
01414     int i, elem_size, size;
01415     void **mp;
01416     Type_Tag tag;
01417     Mark_Proc traverse;
01418     
01419     size = *(long *)p + 1;
01420 
01421     if (size == UNTAGGED_EOM)
01422       break;
01423       
01424     mp = p + 1;
01425     p += size;
01426     size--;
01427 
01428     tag = *(Type_Tag *)mp;
01429       
01430 #if RECORD_MARK_SRC
01431     mark_src = mp;
01432     mark_type = MTYPE_TAGGED_ARRAY;
01433 #endif
01434 
01435     traverse = mark_table[tag];
01436     elem_size = traverse(mp);
01437     mp += elem_size;
01438     for (i = elem_size; i < size; i += elem_size, mp += elem_size)
01439       traverse(mp);
01440   }
01441 }
01442 
01443 static void propagate_xtagged_mpage(void **bottom, MPage *page)
01444 {
01445   OffsetTy offset;
01446   OffsetArrTy *offsets;
01447   void **p, **top;
01448 
01449   offset = page->gray_start;
01450   p = bottom + offset;
01451   top = bottom + page->gray_end;
01452   offsets = page->u.offsets;
01453 
01454   while (p <= top) {
01455     OffsetArrTy v;
01456     long size;
01457 
01458     size = *(long *)p + 1;
01459        
01460 #if ALIGN_DOUBLES
01461     if (size > 1) {
01462 #endif
01463 
01464       v = OFFSET_COLOR_UNMASKED(offsets, offset);
01465       if (v & MFLAG_GRAY) {
01466        v -= MFLAG_GRAY;
01467        v |= MFLAG_BLACK;
01468        OFFSET_SET_COLOR_UNMASKED(offsets, offset, v);
01469        
01470 #if RECORD_MARK_SRC
01471        mark_src = p + 1;
01472        mark_type = MTYPE_XTAGGED;
01473 #endif
01474 
01475        GC_mark_xtagged(p + 1);
01476       }
01477 
01478 #if ALIGN_DOUBLES
01479     }
01480 #endif
01481     
01482     p += size;
01483     offset += size;
01484   }
01485 }
01486 
01487 static void propagate_xtagged_whole_mpage(void **p, MPage *page)
01488 {
01489   void **top;
01490 
01491   top = p + MPAGE_WORDS;
01492 
01493   while (p < top) {
01494     long size;
01495 
01496     size = *(long *)p + 1;
01497 
01498     if (size == UNTAGGED_EOM) {
01499       break;
01500     }
01501 
01502 #if RECORD_MARK_SRC
01503     mark_src = p + 1;
01504     mark_type = MTYPE_XTAGGED;
01505 #endif
01506 
01507 #if ALIGN_DOUBLES
01508     if (size > 1) {
01509 #endif
01510 
01511       GC_mark_xtagged(p + 1);
01512 
01513 #if ALIGN_DOUBLES
01514     }
01515 #endif
01516 
01517     p += size;
01518   } 
01519 }
01520 
01521 static void do_bigblock(void **p, MPage *page, int fixup)
01522 {
01523   switch (page->type) {
01524   case MTYPE_ATOMIC:
01525     return;
01526 
01527   case MTYPE_TAGGED:
01528     {
01529       Type_Tag tag;
01530 
01531       tag = *(Type_Tag *)p;
01532 
01533 #if CHECKS
01534       if ((tag < 0) || (tag >= NUMBER_OF_TAGS) || !size_table[tag]) {
01535        CRASH(16);
01536       }
01537       prev_var_stack = GC_variable_stack;
01538 #endif
01539 #if RECORD_MARK_SRC
01540       mark_src = p;
01541       mark_type = MTYPE_TAGGED;
01542 #endif
01543 
01544       if (fixup)
01545        fixup_table[tag](p);
01546       else
01547        mark_table[tag](p);
01548 
01549 #if CHECKS
01550       if (prev_var_stack != GC_variable_stack) {
01551        CRASH(17);
01552       }
01553 #endif
01554     
01555       return;
01556     }
01557 
01558   case MTYPE_TAGGED_ARRAY:
01559     {
01560       int i, elem_size, size;
01561       void **mp = p;
01562       Type_Tag tag;
01563       Mark_Proc mark;
01564 
01565       size = page->u.size >> LOG_WORD_SIZE;
01566       tag = *(Type_Tag *)mp;
01567 
01568 #if RECORD_MARK_SRC
01569       mark_src = mp;
01570       mark_type = MTYPE_TAGGED_ARRAY;
01571 #endif
01572 
01573       if (fixup)
01574        mark = fixup_table[tag];
01575       else
01576        mark = mark_table[tag];
01577       elem_size = mark(mp);      
01578       mp += elem_size;
01579       for (i = elem_size; i < size; i += elem_size, mp += elem_size)
01580        mark(mp);
01581 
01582       return;
01583     }
01584 
01585   case MTYPE_ARRAY:
01586     {
01587       int i;
01588       long size = page->u.size >> LOG_WORD_SIZE;
01589     
01590       if (fixup) {
01591        for (i = 0; i < size; i++, p++) {
01592          if (*p)
01593            gcFIXUP(*p);
01594        }
01595       } else {
01596 #if RECORD_MARK_SRC
01597        mark_src = p;
01598        mark_type = MTYPE_ARRAY;
01599 #endif
01600        for (i = 0; i < size; i++, p++) {
01601          if (*p)
01602            gcMARK(*p);
01603        }
01604       }
01605 
01606       return;
01607     }
01608 
01609   case MTYPE_XTAGGED:
01610   default:
01611 #if RECORD_MARK_SRC
01612     mark_src = p;
01613     mark_type = MTYPE_XTAGGED;
01614 #endif
01615    if (fixup)
01616      GC_fixup_xtagged(p);
01617    else
01618      GC_mark_xtagged(p);
01619    return;
01620   }
01621 }
01622 
01623 static int old_tag;
01624 static void *old_p;
01625 
01626 static void propagate_all_mpages()
01627 {
01628   MPage *page;
01629   void *p;
01630   
01631   while (gray_first || mark_stack_pos) {
01632     iterations++;
01633 
01634     while (mark_stack_pos) {
01635       mtype_t type;
01636       
01637       p = mark_stack[--mark_stack_pos];
01638       type = mark_stack_type[mark_stack_pos];
01639 # if RECORD_MARK_SRC
01640       current_mark_src = mark_src_stack[mark_stack_pos];
01641       current_mark_type = mark_src_type[mark_stack_pos];
01642 # endif
01643 
01644       switch (type) {
01645       case MTYPE_TAGGED:
01646        {
01647          Type_Tag tag;
01648          tag = *(Type_Tag *)p;
01649        
01650 #if ALIGN_DOUBLES
01651          if (tag != SKIP) {
01652 #endif
01653          
01654 #if CHECKS
01655            if ((tag < 0) || (tag >= NUMBER_OF_TAGS) || !size_table[tag]) {
01656              CRASH(18);
01657            }
01658 #endif
01659 #if RECORD_MARK_SRC
01660            mark_src = p;
01661            mark_type = MTYPE_TAGGED;
01662 #endif
01663 
01664            old_tag = tag;
01665            old_p = p;
01666            mark_table[tag](p);
01667          
01668 #if ALIGN_DOUBLES
01669          }
01670 #endif
01671        }
01672        break;
01673 
01674       case MTYPE_XTAGGED:
01675 #if RECORD_MARK_SRC
01676        mark_src = (void **)p + 1;
01677        mark_type = MTYPE_XTAGGED;
01678 #endif
01679        GC_mark_xtagged((void **)p + 1);
01680        break;
01681 
01682       default: /* MTYPE_ARRAY */
01683        {
01684          long size, i;
01685          
01686          size = ((long *)p)[0];
01687          
01688 #if RECORD_MARK_SRC
01689          mark_src = (void **)p + 1;
01690          mark_type = MTYPE_ARRAY;
01691 #endif
01692 
01693          for (i = 1; i <= size; i++) {
01694            gcMARK(((void **)p)[i]);
01695          }
01696        }
01697       }
01698     }
01699 
01700     if (gray_first) {
01701       page = gray_first;
01702       gray_first = page->gray_next;
01703       
01704       page->flags = ((page->flags & NONCOLOR_MASK) | MFLAG_BLACK);
01705       p = page->block_start;
01706       
01707       if (page->flags & MFLAG_BIGBLOCK) {
01708        if (!(page->flags & MFLAG_CONTINUED))
01709          do_bigblock((void **)p, page, 0);
01710       } else {
01711        switch (page->type) {
01712        case MTYPE_ATOMIC:
01713          break;
01714        case MTYPE_TAGGED:
01715          if (page->flags & MFLAG_OLD)
01716            propagate_tagged_whole_mpage((void **)p, page);
01717          else
01718            propagate_tagged_mpage((void **)p, page);
01719          break;
01720        case MTYPE_TAGGED_ARRAY:
01721          if (page->flags & MFLAG_OLD)
01722            propagate_tagged_array_whole_mpage((void **)p, page);
01723          else
01724            propagate_tagged_array_mpage((void **)p, page);
01725          break;
01726        case MTYPE_XTAGGED:
01727          if (page->flags & MFLAG_OLD)
01728            propagate_xtagged_whole_mpage((void **)p, page);
01729          else
01730            propagate_xtagged_mpage((void **)p, page);
01731          break;
01732        case MTYPE_ARRAY:
01733        default:
01734          if (page->flags & MFLAG_OLD)
01735            propagate_array_whole_mpage((void **)p, page);
01736          else
01737            propagate_array_mpage((void **)p, page);
01738          break;
01739        }
01740       }
01741     }      
01742   }
01743 }
01744 
01745 /******************************************************************************/
01746 /*                             compact phase                                  */
01747 /******************************************************************************/
01748 
01749 /* Compact: compact objects, setting page color to white if all
01750    objects are moved elsewhere */
01751 
01752 static void compact_tagged_mpage(void **p, MPage *page)
01753 {
01754   int to_near = 0, set_age = 0;
01755   OffsetTy offset, dest_offset, dest_start_offset;
01756   OffsetArrTy *offsets;
01757   void **dest, **startp;
01758   void **top;
01759   MSet *set;
01760 
01761   offsets = page->u.offsets;
01762 
01763   top = p + page->alloc_boundary;
01764 
01765   startp = p;
01766   switch (page->type) {
01767   case MTYPE_TAGGED:
01768   default:
01769     set = &tagged;
01770     break;
01771   }
01772   dest = set->compact_to;
01773   dest_start_offset = set->compact_to_offset;
01774   dest_offset = dest_start_offset;
01775   offset = 0;
01776 
01777   page->o.compact_to = dest;
01778   page->compact_boundary = MPAGE_WORDS;
01779   
01780   while (p < top) {
01781     long size;
01782 
01783     size = OFFSET_SIZE(offsets, offset);
01784 
01785 #if CHECKS
01786     if (!size) {
01787       CRASH(19);
01788     }
01789     prev_prev_prev_ptr = prev_prev_ptr;
01790     prev_prev_ptr = prev_ptr;
01791     prev_ptr = p;
01792 #endif
01793 
01794     if (OFFSET_COLOR(offsets, offset)) {
01795 #if ALIGN_DOUBLES
01796 #define PLUS_ALIGNMENT + alignment
01797       long alignment;
01798       if (!(size & 0x1) && (dest_offset & 0x1))
01799        alignment = 1;
01800       else
01801        alignment = 0;
01802 #else
01803 # define PLUS_ALIGNMENT       
01804 #endif
01805       
01806       if (dest_offset + size PLUS_ALIGNMENT > MPAGE_WORDS) {
01807        /* Set end of allocation area in previous page: */
01808        if (dest_offset < MPAGE_WORDS)
01809          *(Type_Tag *)(dest + dest_offset) = TAGGED_EOM;
01810        
01811 #if NOISY
01812        GCPRINT(GCOUTF, "t: %lx [0,%d] -> %lx [%d,%d]\n", 
01813               (long)startp, offset,
01814               (long)dest, dest_start_offset, dest_offset);
01815 #endif
01816 
01817        dest_offset = 0;
01818        dest = startp;
01819        to_near = 1;
01820        if (set_age) {
01821          page->compact_boundary = offset;
01822          set->compact_page->age = page->age;
01823          set->compact_page->refs_age = page->age;
01824        } else
01825          /* Haven't moved anything; set boundary to 0 to indicate this */
01826          page->compact_boundary = 0;
01827       } else {
01828        set_age = 1;
01829 #if ALIGN_DOUBLES
01830        if (alignment) {
01831          *(Type_Tag *)(dest + dest_offset) = SKIP;
01832          dest_offset++;
01833        }
01834 #endif
01835       }
01836       
01837       if (!to_near || (dest_offset != offset)) {
01838        memmove(dest + dest_offset, p, size << LOG_WORD_SIZE);
01839 #if KEEP_BACKPOINTERS
01840        if (to_near)
01841          page->backpointer_page[dest_offset] = page->backpointer_page[offset];
01842        else
01843          set->compact_page->backpointer_page[dest_offset] = page->backpointer_page[offset];
01844 #endif
01845       }
01846       
01847       OFFSET_SET_SIZE_UNMASKED(offsets, offset, dest_offset);
01848       offset += size;
01849       dest_offset += size;
01850  
01851       p += size;
01852     } else {
01853       p += size;
01854       offset += size;
01855     }
01856   }
01857 
01858   if (to_near)
01859     set->compact_page = page;
01860   set->compact_to = dest;
01861   set->compact_to_offset = dest_offset;
01862 
01863   if (!to_near) {
01864     /* Nothing left in here. Reset color to white: */
01865     page->flags = (page->flags & NONCOLOR_MASK);
01866 #if NOISY
01867     GCPRINT(GCOUTF, "t: %lx [all=%d] -> %lx [%d,%d]\n", 
01868            (long)startp, offset,
01869            (long)dest, dest_start_offset, dest_offset);
01870 #endif
01871   }
01872 }
01873 
01874 static void compact_untagged_mpage(void **p, MPage *page)
01875 {
01876   int to_near = 0, set_age = 0;
01877   OffsetTy offset = 0, dest_offset;
01878   OffsetArrTy *offsets;
01879   void **dest, **startp, **top;
01880   MSet *set;
01881 
01882   offsets = page->u.offsets;
01883 
01884   startp = p;
01885   switch (page->type) {
01886   case MTYPE_TAGGED_ARRAY:
01887     set = &tagged_array;
01888     break;
01889   case MTYPE_ATOMIC:
01890     set = &atomic;
01891     break;
01892   case MTYPE_XTAGGED:
01893     set = &xtagged;
01894     break;
01895   default:
01896     set = &array;
01897     break;
01898   }
01899 
01900   dest = set->compact_to;
01901   dest_offset = set->compact_to_offset;
01902 
01903   page->o.compact_to = dest;
01904   page->compact_boundary = MPAGE_WORDS;
01905 
01906   top = p + MPAGE_WORDS;
01907 
01908 #if CHECKS
01909   if (dest == startp) {
01910     if (dest_offset < MPAGE_WORDS) {
01911       /* Can't compact to self! */
01912       CRASH(20);
01913     }
01914   }
01915 #endif
01916 
01917   while (p < top) {
01918     long size;
01919       
01920     size = *(long *)p + 1;
01921     
01922     if (size == UNTAGGED_EOM) {
01923 #if CHECKS
01924       if (p < startp + page->alloc_boundary) {
01925        /* Premature end */
01926        CRASH(21);
01927       }
01928 #endif
01929       break;
01930     }
01931 
01932 #if CHECKS
01933     if (size >= BIGBLOCK_MIN_SIZE) {
01934       CRASH(22);
01935     }
01936 #endif
01937 
01938     if (OFFSET_COLOR(offsets, offset)) {
01939 #if ALIGN_DOUBLES
01940       long alignment;
01941       if ((size & 0x1) && !(dest_offset & 0x1))
01942        alignment = 1;
01943       else
01944        alignment = 0;
01945 #endif
01946        
01947       if ((long)dest_offset + size PLUS_ALIGNMENT > MPAGE_WORDS) {
01948        /* Set end of allocation area in previous page: */
01949        if (dest_offset < MPAGE_WORDS)
01950          *(long *)(dest + dest_offset) = UNTAGGED_EOM - 1;
01951        
01952 #if NOISY
01953        GCPRINT(GCOUTF, "u: %lx -> %lx [%d]\n", (long)startp, (long)dest, offset);
01954 #endif
01955 
01956        dest_offset = 0;
01957        dest = startp;
01958        to_near = 1;
01959 #if ALIGN_DOUBLES
01960        if (size & 0x1) {
01961          dest[0] = 0;
01962          dest_offset++;
01963        }
01964 #endif
01965 
01966        if (set_age) {
01967          page->compact_boundary = offset;
01968          set->compact_page->age = page->age;
01969          set->compact_page->refs_age = page->age;
01970        } else
01971          /* Haven't moved anything; set boundary to 0 to indicate this */
01972          page->compact_boundary = 0;
01973       } else {
01974        set_age = 1;
01975 #if ALIGN_DOUBLES
01976        if (alignment) {
01977          dest[dest_offset] = 0;
01978          dest_offset++;
01979        }
01980 #endif
01981       }
01982 
01983       if (!to_near || (dest_offset != offset)) {
01984        memmove(dest + dest_offset, p, size << LOG_WORD_SIZE);
01985 #if KEEP_BACKPOINTERS
01986        if (to_near)
01987          page->backpointer_page[dest_offset] = page->backpointer_page[offset];
01988        else
01989          set->compact_page->backpointer_page[dest_offset] = page->backpointer_page[offset];
01990 #endif
01991       }
01992       
01993       OFFSET_SET_SIZE_UNMASKED(offsets, offset, dest_offset+1);
01994 #if CHECKS
01995       if (!offsets[offset] && !offsets[offset+1])
01996        CRASH(23);
01997 #endif
01998       offset += size;
01999       dest_offset += size;
02000  
02001       p += size;
02002     } else {
02003       p += size;
02004       offset += size;
02005     }
02006   }
02007 
02008   set->compact_to = dest;
02009   set->compact_to_offset = dest_offset;
02010   if (to_near)
02011     set->compact_page = page;
02012 
02013   if (!to_near) {
02014     /* Nothing left in here. Reset color to white: */
02015     page->flags = (page->flags & NONCOLOR_MASK);
02016 #if NOISY
02017     GCPRINT(GCOUTF, "u: %lx -> %lx [all]\n", (long)startp, (long)dest);
02018 #endif
02019   }
02020 }
02021 
02022 static void compact_all_mpages()
02023 {
02024   MPage *page;
02025   int i;
02026 
02027   for (i = 0; i < NUM_SETS; i++)
02028     sets[i]->compact_to_offset = MPAGE_WORDS;
02029 
02030   for (page = first; page; page = page->next) {
02031     if (!(page->flags & (MFLAG_BIGBLOCK | MFLAG_OLD))) {
02032       if (page->flags & COLOR_MASK) {
02033        void *p;
02034        
02035        page->flags -= (page->flags & MFLAG_INITED);
02036        p = page->block_start;
02037        
02038        if (page->type <= MTYPE_TAGGED)
02039          compact_tagged_mpage((void **)p, page);
02040        else
02041          compact_untagged_mpage((void **)p, page);
02042       } else {
02043        /* Set compact_boundar to 0 to indicate no moves: */
02044        page->compact_boundary = 0;
02045 #if NOISY
02046        GCPRINT(GCOUTF, "x: %lx\n", (long)page->block_start);
02047 #endif
02048       }
02049     }
02050   }
02051 
02052   for (i = 0; i < NUM_TAGGED_SETS; i++) {
02053     if (sets[i]->compact_to_offset < MPAGE_WORDS)
02054       *(Type_Tag *)(sets[i]->compact_to + sets[i]->compact_to_offset) = TAGGED_EOM;
02055   }
02056   for (i = NUM_TAGGED_SETS; i < NUM_SETS; i++) {
02057     if (sets[i]->compact_to_offset < MPAGE_WORDS)
02058       *(long *)(sets[i]->compact_to + sets[i]->compact_to_offset) = UNTAGGED_EOM - 1;
02059   }
02060 }
02061 
02062 /******************************************************************************/
02063 /*                             freelist phase                                 */
02064 /******************************************************************************/
02065 
02066 /* Freelist: put unmarked blocks onto the free list */
02067 
02068 #if USE_FREELIST
02069 
02070 static void freelist_tagged_mpage(void **p, MPage *page)
02071 {
02072   OffsetTy offset;
02073   OffsetArrTy *offsets;
02074   void **top;
02075   void **free_lists;
02076   long on_at_start = on_free_list;
02077 
02078   offsets = page->u.offsets;
02079 
02080   top = p + page->alloc_boundary;
02081 
02082   offset = 0;
02083 
02084   switch (page->type) {
02085   case MTYPE_TAGGED:
02086   default:
02087     free_lists = tagged.free_lists;
02088     break;
02089   }
02090 
02091   while (p < top) {
02092     long size;
02093     OffsetArrTy v;
02094 
02095     size = OFFSET_SIZE(offsets, offset);
02096 
02097     v = OFFSET_COLOR_UNMASKED(offsets, offset);
02098     if (!(v & COLOR_MASK)) {
02099 #if ALIGN_DOUBLES
02100       if (size > 1) {
02101 #endif
02102        /* HACK! This relies on both Type_Tag and OffsetTy being `short' */
02103        ((Type_Tag *)p)[0] = gc_on_free_list_tag;
02104        ((Type_Tag *)p)[1] = size;
02105        p[1] = free_lists[size];
02106        free_lists[size] = (void *)p;
02107        on_free_list += size;
02108 #if ALIGN_DOUBLES
02109       }
02110 #endif
02111     } else {
02112       /* Remove color: */
02113       v -= (v & (MFLAG_GRAY | MFLAG_BLACK));
02114       OFFSET_SET_COLOR_UNMASKED(offsets, offset, v);
02115     }
02116 
02117     p += size;
02118     offset += size;
02119   }
02120 
02121   if (on_at_start != on_free_list)
02122     page->age = page->refs_age = -1;  /* will be promoted to 0 */
02123 }
02124 
02125 static void freelist_untagged_mpage(void **p, MPage *page)
02126 {
02127   OffsetTy offset = 0;
02128   OffsetArrTy *offsets;
02129   void **free_lists, **top;
02130   long on_at_start = on_free_list;
02131 
02132   switch (page->type) {
02133   case MTYPE_TAGGED_ARRAY:
02134     free_lists = tagged_array.free_lists;
02135     break;
02136   case MTYPE_ATOMIC:
02137     free_lists = atomic.free_lists;
02138     break;
02139   case MTYPE_XTAGGED:
02140     free_lists = xtagged.free_lists;
02141     break;
02142   default:
02143     free_lists = array.free_lists;
02144     break;
02145   }
02146 
02147   offsets = page->u.offsets;
02148   top = p + MPAGE_WORDS;
02149 
02150   while (p < top) {
02151     long size;
02152     OffsetArrTy v;
02153 
02154     size = *(long *)p + 1;
02155     
02156     if (size == UNTAGGED_EOM)
02157       break;
02158 
02159 #if CHECKS
02160     if (size >= BIGBLOCK_MIN_SIZE) {
02161       CRASH(24);
02162     }
02163 #endif
02164 
02165     v = OFFSET_COLOR_UNMASKED(offsets, offset);
02166     if (!(v & COLOR_MASK)) {
02167 #if ALIGN_DOUBLES
02168       if (size > 1) {
02169 #endif
02170        p[1] = free_lists[size-1];
02171        free_lists[size-1] = (void *)(p + 1);
02172        on_free_list += (size-1);
02173 #if ALIGN_DOUBLES
02174       }
02175 #endif
02176     } else {
02177       /* Remove color: */
02178       v -= (v & (MFLAG_GRAY | MFLAG_BLACK));
02179       OFFSET_SET_COLOR_UNMASKED(offsets, offset, v);
02180     }
02181      
02182     p += size;
02183     offset += size;
02184   }
02185 
02186   if (on_at_start != on_free_list)
02187     page->age = page->refs_age = -1; /* will be promoted to 0 */
02188 }
02189 
02190 static void freelist_all_mpages(int young)
02191 {
02192   MPage *page;
02193 
02194   for (page = first; page; page = page->next) {
02195     if (page->flags & COLOR_MASK) {
02196       if (page->refs_age <= young)
02197        page->refs_age = -1; /* best we can assume */
02198       if (!(page->flags & (MFLAG_BIGBLOCK | MFLAG_OLD))) {
02199        void *p;
02200        
02201        p = page->block_start;
02202        
02203        if (page->type <= MTYPE_TAGGED)
02204          freelist_tagged_mpage((void **)p, page);
02205        else
02206          freelist_untagged_mpage((void **)p, page);
02207       }
02208     }
02209   }
02210 }
02211 
02212 #endif
02213 
02214 /******************************************************************************/
02215 /*                              fixup phase                                   */
02216 /******************************************************************************/
02217 
02218 /* Fixup: translate an old address to a new one, and note age of
02219    youngest referenced page */
02220 
02221 static int min_referenced_page_age;
02222 #if CHECKS
02223 static void *bad_dest_addr;
02224 #endif
02225 
02226 void GC_fixup(void *pp)
02227 {
02228   void *p = *(void **)pp;
02229   unsigned long g;
02230   MPage *map;
02231 
02232   if ((long)p & 0x1) return;
02233   g = ((unsigned long)p >> MAPS_SHIFT);
02234 
02235   map = mpage_maps[g];
02236   if (map) {
02237     unsigned long addr = (((unsigned long)p & MAP_MASK) >> MAP_SHIFT);
02238     MPage *page;
02239 
02240     page = map + addr;
02241 
02242 #if DEFINE_MALLOC_FREE
02243     if (page->type == MTYPE_MALLOCFREE)
02244       return;
02245 #endif
02246 
02247     if (page->type) {
02248       if (page->compact_to_age < min_referenced_page_age)
02249        min_referenced_page_age = page->compact_to_age;
02250 
02251       if (!(page->flags & (MFLAG_OLD | MFLAG_BIGBLOCK))) {
02252        long offset = ((long)p & MPAGE_MASK) >> LOG_WORD_SIZE;
02253        OffsetTy v;
02254        void *r;
02255 
02256        if (page->type > MTYPE_TAGGED) {
02257 #if CHECKS
02258          if (!offset) {
02259            /* Can't point to beginning of non-tagged block! */
02260            CRASH(25);
02261          }
02262 #endif
02263          offset--;
02264        }
02265 
02266        v = OFFSET_SIZE(page->u.offsets, offset);
02267 #if CHECKS
02268        if (page->type > MTYPE_TAGGED) {
02269          if (!v) {
02270            /* Can't point to beginning of non-tagged block! */
02271            CRASH(26);
02272          }
02273        }
02274 #endif
02275        
02276        if (offset < page->compact_boundary)
02277          r = (void *)(page->o.compact_to + v);
02278        else
02279          r = (void *)(((long)p & MPAGE_START) + ((long)v << LOG_WORD_SIZE));
02280 
02281 #if SEARCH
02282        if (r == search_for)
02283          stop();
02284 #endif
02285 
02286 #if CHECKS
02287        if (!(find_page(r)->flags & COLOR_MASK)) {
02288          bad_dest_addr = r;
02289          CRASH(27);
02290        }
02291 #endif
02292 
02293        if (r != p)
02294          *(void **)pp = r;
02295       }
02296     }
02297   }
02298 }
02299 
02300 /**********************************************************************/
02301 
02302 /* set compact_to_age field of a page: */
02303 
02304 void reverse_propagate_new_age(void)
02305 {
02306   MPage *page;
02307 
02308   for (page = first; page; page = page->next) {
02309     if (!(page->flags & (MFLAG_BIGBLOCK | MFLAG_OLD))) {
02310       if (page->compact_boundary > 0) {
02311        MPage *page_to;
02312        page_to = find_page(page->o.compact_to);
02313        if (page_to->age < page->age)
02314          page->compact_to_age = page_to->age;
02315        else
02316          page->compact_to_age = page->age;
02317       } else
02318        page->compact_to_age = page->age;
02319     } else
02320       page->compact_to_age = page->age;
02321   }
02322 }
02323 
02324 /**********************************************************************/
02325 
02326 /* Fixup: fixup addresses in all readable objects */
02327 
02328 static void fixup_tagged_mpage(void **p, MPage *page)
02329 {
02330   void **top;
02331 #if KEEP_BACKPOINTERS
02332   long bp_delta = page->backpointer_page - p;
02333 #endif
02334 
02335   top = p + MPAGE_WORDS;
02336 
02337   while (p < top) {
02338     Type_Tag tag;
02339     long size;
02340 
02341     tag = *(Type_Tag *)p;
02342 
02343     if (tag == TAGGED_EOM)
02344       break;
02345 
02346 #if ALIGN_DOUBLES
02347     if (tag == SKIP) {
02348       p++;
02349     } else {
02350 #endif
02351 
02352 #if CHECKS
02353       if ((tag < 0) || (tag >= NUMBER_OF_TAGS) || !size_table[tag]) {
02354        GCFLUSHOUT();
02355        CRASH(28);
02356       }
02357       prev_var_stack = prev_ptr;
02358       prev_ptr = p;
02359 #endif
02360 
02361       size = fixup_table[tag](p);
02362 
02363 #if KEEP_BACKPOINTERS
02364       GC_fixup((void *)(p + bp_delta));
02365 #endif
02366 
02367       p += size;
02368 
02369 #if ALIGN_DOUBLES
02370     }
02371 #endif
02372   }
02373 }
02374 
02375 static void fixup_array_mpage(void **p, MPage *page)
02376 {
02377   void **top;
02378 #if KEEP_BACKPOINTERS
02379   long bp_delta = page->backpointer_page - p;
02380 #endif
02381 
02382   top = p + MPAGE_WORDS;
02383 
02384   while (p < top) {
02385     long size;
02386 
02387     size = *(long *)p + 1;
02388 
02389     if (size == UNTAGGED_EOM)
02390       break;
02391 
02392 #if CHECKS
02393     if (size >= BIGBLOCK_MIN_SIZE) {
02394       CRASH(29);
02395     }
02396 #endif
02397 
02398 #if KEEP_BACKPOINTERS
02399     GC_fixup((void *)(p + bp_delta));
02400 #endif
02401 
02402     for (p++; --size; p++) {
02403       gcFIXUP(*p);
02404     }
02405   }
02406 }
02407 
02408 static void fixup_tagged_array_mpage(void **p, MPage *page)
02409 {
02410   void **top;
02411 #if KEEP_BACKPOINTERS
02412   long bp_delta = page->backpointer_page - p;
02413 #endif
02414 
02415   top = p + MPAGE_WORDS;
02416 
02417   while (p < top) {
02418     long size;
02419     int i, elem_size;
02420     void **mp;
02421     Type_Tag tag;
02422     Fixup_Proc traverse;
02423 
02424     size = *(long *)p + 1;
02425 
02426     if (size == UNTAGGED_EOM)
02427       break;
02428 
02429     mp = p + 1;
02430     p += size;
02431     size--;
02432 
02433 #if ALIGN_DOUBLES
02434     if (size) {
02435 #endif
02436 #if KEEP_BACKPOINTERS
02437       GC_fixup((void *)(mp - 1 + bp_delta));
02438 #endif
02439       tag = *(Type_Tag *)mp;
02440 
02441       traverse = fixup_table[tag];
02442       elem_size = traverse(mp);
02443       mp += elem_size;
02444       for (i = elem_size; i < size; i += elem_size, mp += elem_size)
02445        traverse(mp);
02446 
02447 #if ALIGN_DOUBLES
02448     }
02449 #endif
02450   }
02451 }
02452 
02453 static void fixup_xtagged_mpage(void **p, MPage *page)
02454 {
02455   void **top;
02456 #if KEEP_BACKPOINTERS
02457   long bp_delta = page->backpointer_page - p;
02458 #endif
02459 
02460   top = p + MPAGE_WORDS;
02461 
02462   while (p < top) {
02463     long size;
02464 
02465     size = *(long *)p + 1;
02466 
02467     if (size == UNTAGGED_EOM)
02468       break;
02469 
02470 #if CHECKS
02471     if (size >= BIGBLOCK_MIN_SIZE) {
02472       CRASH(30);
02473     }
02474 #endif
02475 
02476 #if ALIGN_DOUBLES
02477     if (size > 1) {
02478 #endif
02479       GC_fixup_xtagged(p + 1);
02480 #if KEEP_BACKPOINTERS
02481       GC_fixup((void *)(p + bp_delta));
02482 #endif
02483 #if ALIGN_DOUBLES
02484     }
02485 #endif
02486 
02487     p += size;
02488   }
02489 }
02490 
02491 static void fixup_all_mpages()
02492 {
02493   MPage *page;
02494 
02495   for (page = first; page; page = page->next) {
02496     if (page->flags & COLOR_MASK) {
02497       if (page->type != MTYPE_ATOMIC) {
02498        void *p;
02499 
02500        scanned_pages++;
02501        min_referenced_page_age = page->age;
02502        p = page->block_start;
02503 
02504 #if NOISY
02505        GCPRINT(GCOUTF, "Fixup %lx\n", (long)p);
02506 #endif
02507 
02508        if (page->flags & MFLAG_BIGBLOCK) {
02509          do_bigblock((void **)p, page, 1);
02510 #if KEEP_BACKPOINTERS
02511          GC_fixup((void *)&(page->backpointer_page));
02512 #endif
02513        } else {
02514          switch (page->type) {
02515          case MTYPE_TAGGED:
02516            fixup_tagged_mpage((void **)p, page);
02517            break;
02518          case MTYPE_TAGGED_ARRAY:
02519            fixup_tagged_array_mpage((void **)p, page);
02520            break;
02521          case MTYPE_XTAGGED:
02522            fixup_xtagged_mpage((void **)p, page);
02523            break;
02524          default:
02525            fixup_array_mpage((void **)p, page);
02526          }
02527        }
02528 
02529        page->refs_age = min_referenced_page_age;
02530       }
02531     }
02532   }
02533 }
02534 
02535 /******************************************************************************/
02536 /*                               free phase                                   */
02537 /******************************************************************************/
02538 
02539 /* Free: release unused pages. */
02540 
02541 static void free_unused_mpages()
02542 {
02543   MPage *page, *next;
02544   memory_in_use = 0;
02545 
02546   for (page = first; page; page = next) {
02547     next = page->next;
02548     if (!(page->flags & (COLOR_MASK | MFLAG_OLD))) {
02549       void *p;
02550       p = page->block_start;
02551 
02552       if (page->prev)
02553        page->prev->next = page->next;
02554       else
02555        first = page->next;
02556       if (page->next)
02557        page->next->prev = page->prev;
02558       else
02559        last = page->prev;
02560 
02561       if (page->flags & MFLAG_BIGBLOCK) {
02562 #if NOISY
02563        GCPRINT(GCOUTF, "Free %lx - %lx\n", (long)p,
02564               (long)p + page->u.size);
02565 #endif
02566 
02567        free_pages((void *)p, page->u.size);
02568        
02569        {
02570         long s = page->u.size;
02571         unsigned long i = ((unsigned long)p >> MAPS_SHIFT);
02572         unsigned long j = (((unsigned long)p & MAP_MASK) >> MAP_SHIFT);
02573         while (s > MPAGE_SIZE) {
02574           s -= MPAGE_SIZE;
02575           j++;
02576           if (j == MAP_SIZE) {
02577             j = 0;
02578             i++;
02579           }
02580           mpage_maps[i][j].type = 0;
02581           mpage_maps[i][j].flags = 0;
02582         }
02583        }
02584       } else {
02585 #if NOISY
02586        GCPRINT(GCOUTF, "Free %lx\n", (long)p);
02587 #endif
02588        free_pages((void *)p, MPAGE_SIZE);
02589        free_pages(page->u.offsets, OPAGE_SIZE);
02590 #if KEEP_BACKPOINTERS
02591        free_pages(page->backpointer_page, MPAGE_SIZE);
02592 #endif
02593       }
02594       
02595       if (page->flags & MFLAG_INITED)
02596        scanned_pages++;
02597       
02598       page->type = 0;
02599       page->flags = 0;
02600       skipped_pages++;
02601     } else {
02602       if (page->flags & MFLAG_BIGBLOCK) {
02603        if (!(page->flags & MFLAG_CONTINUED))
02604          memory_in_use += page->u.size;
02605       } else
02606        memory_in_use += MPAGE_SIZE;
02607     }
02608   }
02609 
02610   vm_flush_freed_pages(GC->vm);
02611 }
02612 
02613 void promote_all_ages()
02614 {
02615   MPage *page;
02616 
02617   for (page = first; page; page = page->next) {
02618     if (page->age < 15)
02619       page->age++;
02620     if (page->refs_age < 15)
02621       page->refs_age++;
02622   }
02623 }
02624 
02625 
02626 void protect_old_mpages()
02627 {
02628 #if GENERATIONS
02629   MPage *page;
02630 
02631   if (generations_available) {
02632     for (page = first; page; page = page->next) {
02633       if (page->age && (page->type != MTYPE_ATOMIC)) {
02634        void *p;
02635       
02636        if (page->flags & MFLAG_MODIFIED) {
02637          page->flags -= MFLAG_MODIFIED;
02638       
02639          p = page->block_start;
02640          if (page->flags & MFLAG_BIGBLOCK)
02641            vm_protect_pages((void *)p, page->u.size, 0);
02642          else 
02643            vm_protect_pages((void *)p, MPAGE_SIZE, 0);
02644        }
02645       }
02646     }
02647   }
02648 #endif
02649 }
02650 
02651 /******************************************************************************/
02652 /*                         modification tracking                              */
02653 /******************************************************************************/
02654 
02655 #if GENERATIONS
02656 
02657 static int designate_modified(void *p);
02658 
02659 static int designate_modified_maybe(void *p, int no_barrier_ok)
02660 {
02661   unsigned long g = ((unsigned long)p >> MAPS_SHIFT);
02662   MPage *map;
02663 
02664 #if CHECKS
02665   if (during_gc)
02666     CRASH(31);
02667 #endif
02668 
02669   map = mpage_maps[g];
02670   if (map) {
02671     unsigned long addr = (((unsigned long)p & MAP_MASK) >> MAP_SHIFT);
02672     MPage *page;
02673 
02674     page = map + addr;
02675     if (page->type) {
02676       if (page->flags & MFLAG_CONTINUED) {
02677        designate_modified(page->o.bigblock_start);
02678        num_seg_faults++;
02679        return 1;
02680       } else if (page->age) {
02681         if (page->flags & MFLAG_MODIFIED) {
02682           if (no_barrier_ok)
02683             return 0;
02684         } else {
02685           page->flags |= MFLAG_MODIFIED;
02686           p = (void *)((long)p & MPAGE_START);
02687           if (page->flags & MFLAG_BIGBLOCK)
02688             vm_protect_pages(p, page->u.size, 1);
02689           else
02690             vm_protect_pages(p, MPAGE_SIZE, 1);
02691           num_seg_faults++;
02692           return 1;
02693         }
02694       } else if (no_barrier_ok) {
02695         return 0;
02696       }
02697 
02698       GCPRINT(GCOUTF, "Seg fault (internal error) at %lx [%ld]\n", 
02699              (long)p, num_seg_faults);
02700       return 0;
02701     }
02702   }
02703 
02704   
02705   GCPRINT(GCOUTF, "Access on unmapped page at %lx [%ld]\n", 
02706          (long)p, num_seg_faults);
02707 
02708 #if defined(_WIN32) && defined(CHECKS)
02709   DebugBreak();
02710 #endif
02711   return 0;
02712 }
02713 
02714 static int designate_modified(void *p)
02715 {
02716   return designate_modified_maybe(p, 0);
02717 }
02718 
02719 void GC_write_barrier(void *p)
02720 {
02721   designate_modified_maybe(p, 1);
02722 }
02723 
02724 /* The platform-specific signal handlers, and initialization function: */
02725 # include "sighand.c"
02726 
02727 #endif /* GENERATIONS */
02728 
02729 /******************************************************************************/
02730 /*                              stack walking                                 */
02731 /******************************************************************************/
02732 
02733 #if CHECKS
02734 static void **o_var_stack, **oo_var_stack;
02735 #endif
02736 #if TIME
02737 static int stack_depth;
02738 #endif
02739 #if RECORD_MARK_SRC
02740 static int record_stack_source = 0;
02741 #endif
02742 
02743 #include "stack_comp.c"
02744 
02745 #define GC_X_variable_stack GC_mark_variable_stack
02746 #if RECORD_MARK_SRC
02747 # define X_source(stk, p) if (record_stack_source) { mark_src = (stk ? stk : p); mark_type = MTYPE_STACK; }
02748 #else
02749 # define X_source(stk, p) /* */
02750 #endif
02751 #define gcX(a) gcMARK(*a)
02752 #include "var_stack.c"
02753 #undef GC_X_variable_stack
02754 #undef gcX
02755 #undef X_source
02756 
02757 #define GC_X_variable_stack GC_fixup_variable_stack
02758 #define gcX(a) gcFIXUP(*a)
02759 #define X_source(stk, p) /* */
02760 #include "var_stack.c"
02761 #undef GC_X_variable_stack
02762 #undef gcX
02763 #undef X_source
02764 
02765 #if CHECKS
02766 # if CHECK_STACK_PTRS
02767 static void check_ptr(void **a)
02768 {
02769   void *p = *a;
02770   MPage *page;
02771 
02772   if (!mpage_maps) return;
02773 
02774   if ((long)p & 0x1) return;
02775 
02776   page = find_page(p);
02777   if (page) {
02778     if ((page->type == MTYPE_TAGGED)
02779         && !(page->flags & MFLAG_BIGBLOCK)) {
02780       Type_Tag tag;
02781 
02782       tag = *(Type_Tag *)p;
02783       if ((tag < 0) || (tag >= NUMBER_OF_TAGS) 
02784          || (!size_table[tag] 
02785              && (tag != weak_box_tag)
02786              && (tag != ephemeron_tag)
02787              && (tag != weak_array_tag)
02788              && (tag != gc_on_free_list_tag))) {
02789        GCPRINT(GCOUTF, "bad tag: %d at %lx, references from %lx\n", tag, (long)p, (long)a);
02790        GCFLUSHOUT();
02791        CRASH(70);
02792       }
02793 
02794     }
02795 #if DEFINE_MALLOC_FREE
02796     else if (page->type == MTYPE_MALLOCFREE) {
02797       check_not_freed(page, p);
02798     }
02799 #endif
02800   }
02801 }
02802 
02803 #define GC_X_variable_stack GC_do_check_variable_stack
02804 #define gcX(a) check_ptr(a)
02805 #define X_source(stk, p) /* */
02806 #include "var_stack.c"
02807 #undef GC_X_variable_stack
02808 #undef gcX
02809 #undef X_source
02810 
02811 # endif
02812 
02813 void GC_check_variable_stack()
02814 {
02815 # if CHECK_STACK_PTRS
02816   GC_do_check_variable_stack(GC_variable_stack,
02817                              0,
02818                              (void **)(GC_get_thread_stack_base
02819                                        ? GC_get_thread_stack_base()
02820                                        : stack_base),
02821                              NULL);
02822 # endif
02823 }
02824 #endif
02825 
02826 /******************************************************************************/
02827 /*                             main GC driver                                 */
02828 /******************************************************************************/
02829 
02830 static void set_ending_tags(void)
02831 {
02832   int i;
02833 
02834   for (i = 0; i < NUM_TAGGED_SETS; i++) {
02835     if (sets[i]->low < sets[i]->high)
02836       *(Type_Tag *)sets[i]->low = TAGGED_EOM;
02837   }
02838   for (i = NUM_TAGGED_SETS; i < NUM_SETS; i++) {
02839     if (sets[i]->low < sets[i]->high)
02840       *(long *)sets[i]->low = UNTAGGED_EOM - 1;
02841   }
02842 }
02843 
02844 static int initialized;
02845 
02846 static void init(void)
02847 {
02848   if (!initialized) {
02849     GC_register_traversers(weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 1, 0);
02850     GC_register_traversers(ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 1, 0);
02851     GC_register_traversers(weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
02852 #if USE_FREELIST
02853     GC_register_traversers(gc_on_free_list_tag, size_on_free_list, size_on_free_list, size_on_free_list, 0, 0);
02854 #endif
02855     GC_add_roots(&GC->finalizers, (char *)&GC->finalizers + sizeof(GC->finalizers) + 1);
02856     GC_add_roots(&fnl_weaks, (char *)&fnl_weaks + sizeof(fnl_weaks) + 1);
02857     GC_add_roots(&run_queue, (char *)&run_queue + sizeof(run_queue) + 1);
02858     GC_add_roots(&last_in_queue, (char *)&last_in_queue + sizeof(last_in_queue) + 1);
02859     GC_add_roots(&park, (char *)&park + sizeof(park) + 1);
02860     GC_add_roots(&park_save, (char *)&park_save + sizeof(park_save) + 1);
02861 
02862     sets[0] = &tagged;
02863     sets[1] = &array;
02864     sets[2] = &tagged_array;
02865     sets[3] = &xtagged;
02866     sets[4] = &atomic;
02867 
02868     initialized = 1;
02869 
02870 #if GENERATIONS
02871     initialize_signal_handler(GC);
02872 #endif
02873   }
02874 }
02875 
02876 #if 0
02877 # define GETTIME() ((long)scheme_get_milliseconds())
02878 #else
02879 extern long scheme_get_process_milliseconds();
02880 # define GETTIME() ((long)scheme_get_process_milliseconds())
02881 #endif
02882 
02883 #if TIME
02884 # define PRINTTIME(x) GCPRINT x
02885 # define STDERR GCOUTF
02886 static long started, rightnow, old;
02887 # define INITTIME() (started = GETTIME())
02888 # define GETTIMEREL() (rightnow = GETTIME(), old = started, started = rightnow, rightnow - old)
02889 #else
02890 # define INITTIME() /* empty */
02891 # define PRINTTIME(x) /* empty */
02892 #endif
02893 
02894 static void mark_roots()
02895 {
02896   Roots *roots = &GC->roots;
02897   ImmobileBox *ib;
02898   int i;
02899 
02900   for (i = 0; i < roots->count; i += 2) {
02901     void **s = (void **)roots->roots[i];
02902     void **e = (void **)roots->roots[i + 1];
02903 
02904     while (s < e) {
02905 #if RECORD_MARK_SRC
02906       mark_src = s;
02907       mark_type = MTYPE_ROOT;
02908 #endif
02909       gcMARK(*s);
02910       s++;
02911     }
02912   }
02913 
02914 #if RECORD_MARK_SRC
02915   record_stack_source = 1;
02916 #endif
02917   GC_mark_variable_stack(GC_variable_stack,
02918       0,
02919       (void *)(GC_get_thread_stack_base
02920         ? GC_get_thread_stack_base()
02921         : stack_base),
02922       NULL);
02923 #if RECORD_MARK_SRC
02924   record_stack_source = 0;
02925 #endif
02926 
02927   /* Do immobiles: */
02928   for (ib = immobile; ib; ib = ib->next) {
02929 #if RECORD_MARK_SRC
02930     mark_src = ib;
02931     mark_type = MTYPE_IMMOBILE;
02932 #endif
02933     gcMARK(ib->p);
02934   }
02935 }
02936 
02937 static void fixup_roots()
02938 {
02939   Roots *roots = &GC->roots;
02940   ImmobileBox *ib;
02941   int i;
02942 
02943   for (i = 0; i < roots->count; i += 2) {
02944     void **s = (void **)roots->roots[i];
02945     void **e = (void **)roots->roots[i + 1];
02946 
02947     while (s < e) {
02948       gcFIXUP(*s);
02949       s++;
02950     }
02951   }
02952 
02953   GC_fixup_variable_stack(GC_variable_stack,
02954       0,
02955       (void *)(GC_get_thread_stack_base
02956         ? GC_get_thread_stack_base()
02957         : stack_base),
02958       NULL);
02959 
02960   /* Do immobiles: */
02961   for (ib = immobile; ib; ib = ib->next) {
02962     gcFIXUP(ib->p);
02963   }
02964 }
02965 
02966 static void gcollect(int full)
02967 {
02968   CompactGC *gc = GC;
02969   int did_fnls;
02970 #if TIME
02971   struct rusage pre, post;
02972 #endif
02973   int young;
02974   int compact;
02975   int i;
02976 
02977   INITTIME();
02978   PRINTTIME((STDERR, "gc: << start with %ld [%d]: %ld\n", 
02979             memory_in_use, cycle_count, GETTIMEREL()));
02980 
02981   if (memory_in_use > max_memory_use)
02982     max_memory_use = memory_in_use;
02983 
02984   init();
02985 
02986   set_ending_tags();
02987 
02988   init_weak_boxes(gc);
02989   init_ephemerons(gc);
02990   init_weak_arrays(gc);
02991 
02992   did_fnls = 0;
02993 
02994   gray_first = NULL;
02995 
02996   if (GC_collect_start_callback)
02997     GC_collect_start_callback();
02998 
02999 #if TIME
03000   getrusage(RUSAGE_SELF, &pre);
03001 #endif
03002 
03003   sort_and_merge_roots(&GC->roots);
03004 
03005   during_gc = 1;
03006 
03007   /******************** Init ****************************/
03008 
03009   skipped_pages = 0;
03010   scanned_pages = 0;
03011   young_pages = 0;
03012   inited_pages = 0;
03013 
03014   if (full)
03015     young = 15;
03016   else if ((cycle_count & 0xF) == 0xF)
03017     young = 15;
03018   else if ((cycle_count & 0x7) == 0x7)
03019     young = 7;
03020   else if ((cycle_count & 0x3) == 0x3)
03021     young = 3;
03022   else if ((cycle_count & 0x1) == 0x1)
03023     young = 1;
03024   else
03025     young = 0;
03026 
03027 #if !GENERATIONS
03028   young = 15;
03029 #else
03030   if (!generations_available)
03031     young = 15;
03032 #endif
03033 
03034 #if USE_FREELIST && (COMPACTING == SELECTIVELY_COMPACT)
03035   if (full)
03036     compact = 1;
03037   else {
03038     /* Remaining free list items few enough? */
03039     if (((float)(on_free_list << LOG_WORD_SIZE) / memory_in_use) < COMPACT_THRESHOLD)
03040       compact = 0;
03041     else
03042       compact = 1;
03043   }
03044 #else
03045 # if (COMPACTING == ALWAYS_COMPACT) || !USE_FREELIST
03046   compact = 1;
03047 # endif
03048 # if (COMPACTING == NEVER_COMPACT)
03049   compact = 0;
03050 # endif
03051 #endif
03052 
03053   if (compact)
03054     compact_count++;
03055 
03056   init_all_mpages(young);
03057 
03058   PRINTTIME((STDERR, "gc: init %s [freelist=%f] (young:%d skip:%d scan:%d init:%d): %ld\n", 
03059             compact ? "cmpct" : "frlst", (double)(FREE_LIST_DELTA << LOG_WORD_SIZE) / memory_in_use,
03060             young_pages, skipped_pages, scanned_pages, inited_pages,
03061             GETTIMEREL()));
03062 
03063   /************* Mark and Propagate *********************/
03064 
03065   inited_pages = 0;
03066 #if TIME
03067   mark_stackoflw = 0;
03068 #endif
03069 
03070 #if MARK_STATS
03071   mark_calls = mark_hits = mark_recalls = mark_colors = mark_many = mark_slow = 0;
03072 #endif
03073 
03074   mark_roots();
03075 
03076   {
03077     Fnl *f;
03078     for (f = GC->finalizers; f; f = f->next) {
03079 #if RECORD_MARK_SRC
03080       mark_src = f;
03081       mark_type = MTYPE_FINALIZER;
03082 #endif
03083       mark_finalizer(f);
03084     }
03085     for (f = run_queue; f; f = f->next) {
03086 #if RECORD_MARK_SRC
03087       mark_src = f;
03088       mark_type = MTYPE_FINALIZER;
03089 #endif
03090       mark_finalizer(f);
03091     }
03092   }
03093 
03094   {
03095     Fnl_Weak_Link *wl;
03096     for (wl = fnl_weaks; wl; wl = wl->next) {
03097 #if RECORD_MARK_SRC
03098       mark_src = wl;
03099       mark_type = MTYPE_WEAKLINK;
03100 #endif
03101       mark_finalizer_weak_link(wl);
03102     }
03103   }
03104 
03105 #if TIME
03106   getrusage(RUSAGE_SELF, &post);
03107 #endif
03108 
03109 #if MARK_STATS
03110 # define STATS_FORMAT " {c=%ld h=%ld c=%ld r=%ld m=%ld s=%ld}"
03111 # define STATS_ARGS mark_calls, mark_hits, mark_colors, mark_recalls, mark_many, mark_slow,
03112 #else
03113 # define STATS_FORMAT
03114 # define STATS_ARGS
03115 #endif
03116 
03117   PRINTTIME((STDERR, "gc: roots (init:%d deep:%d)"
03118             STATS_FORMAT
03119             " [%ld/%ld faults]: %ld\n", 
03120             inited_pages, stack_depth, 
03121             STATS_ARGS
03122             post.ru_minflt - pre.ru_minflt, post.ru_majflt - pre.ru_majflt,
03123             GETTIMEREL()));
03124 
03125   iterations = 0;
03126 
03127   /* Propagate, mark ready ephemerons */
03128   propagate_all_mpages();
03129   mark_ready_ephemerons(gc);
03130 
03131   /* Propagate, loop to do finalization */
03132   while (1) { 
03133 
03134     /* Propagate all marks. */
03135     propagate_all_mpages();
03136     
03137     if ((did_fnls >= 3) || !GC->finalizers) {
03138       if (did_fnls == 3) {
03139        /* Finish up ordered finalization */
03140        Fnl *f, *next, *prev;
03141        Fnl_Weak_Link *wl;
03142 
03143        /* Enqueue and mark level 3 finalizers that still haven't been marked. */
03144        /* (Recursive marking is already done, though.) */
03145        prev = NULL;
03146        for (f = GC->finalizers; f; f = next) {
03147          next = f->next;
03148          if (f->eager_level == 3) {
03149            if (!is_marked(gc, f->p)) {
03150              /* Not yet marked. Mark it and enqueue it. */
03151 #if RECORD_MARK_SRC
03152              mark_src = f;
03153              mark_type = MTYPE_FINALIZER;
03154 #endif
03155              gcMARK(f->p);
03156 
03157              if (prev)
03158               prev->next = next;
03159              else
03160               GC->finalizers = next;
03161              
03162              f->eager_level = 0; /* indicates queued */
03163              
03164              f->next = NULL;
03165              if (last_in_queue) {
03166               last_in_queue->next = f;
03167               last_in_queue = f;
03168              } else {
03169               run_queue = last_in_queue = f;
03170              }
03171            } else {
03172              prev = f;
03173            }
03174          } else {
03175            prev = f;
03176          }
03177        }
03178 
03179        if (young == 15) {
03180          /* Restore zeroed out weak links, marking as we go: */       
03181          for (wl = fnl_weaks; wl; wl = wl->next) {
03182            void *wp = (void *)wl->p;
03183            int markit;
03184            markit = is_marked(gc, wp);
03185            if (markit) {
03186 #if RECORD_MARK_SRC
03187              mark_src = wp;
03188              mark_type = MTYPE_WEAKLINKX;
03189 #endif
03190              gcMARK(wl->saved);
03191            }
03192            *(void **)(BYTEPTR(wp) + wl->offset) = wl->saved;
03193          }
03194        }
03195        
03196        /* We have to mark one more time, because restoring a weak
03197            link may have made something reachable. */
03198 
03199        did_fnls++;
03200       } else
03201        break;
03202     } else {
03203       int eager_level = did_fnls + 1;
03204       
03205       if (eager_level == 3) {
03206        /* Ordered finalization */
03207        Fnl *f;
03208        Fnl_Weak_Link *wl;
03209 
03210        /* If full collect, zero out weak links for ordered finalization. */
03211        /* (Only done on full collect to avoid modifying old pages.) */
03212        if (young == 15) {
03213          for (wl = fnl_weaks; wl; wl = wl->next) {
03214            void *wp = (void *)wl->p;
03215            wl->saved = *(void **)(BYTEPTR(wp) + wl->offset);
03216            *(void **)(BYTEPTR(wp) + wl->offset) = NULL;
03217          }
03218        }
03219 
03220        /* Mark content of not-yet-marked finalized objects,
03221           but don't mark the finalized objects themselves. */  
03222        for (f = GC->finalizers; f; f = f->next) {
03223          if (f->eager_level == 3) {
03224 #if RECORD_MARK_SRC
03225            mark_src = f;
03226            mark_type = MTYPE_TAGGED;
03227 #endif
03228            if (!is_marked(gc, f->p)) {
03229              /* Not yet marked. Mark content. */
03230              if (f->tagged) {
03231               Type_Tag tag = *(Type_Tag *)f->p;
03232 #if CHECKS
03233               if ((tag < 0) || (tag >= NUMBER_OF_TAGS) || !size_table[tag]) {
03234                 CRASH(34);
03235               }
03236 #endif
03237               mark_table[tag](f->p);
03238              } else {
03239               GC_mark_xtagged(f->p);
03240              }
03241            }
03242          }
03243        }
03244       } else {
03245        /* Unordered finalization */
03246        Fnl *f, *prev, *queue;
03247 
03248        f = GC->finalizers;
03249        prev = NULL;
03250        queue = NULL;
03251        
03252        while (f) {
03253          if (f->eager_level == eager_level) {
03254            if (!is_marked(gc, f->p)) {
03255              /* Not yet marked. Move finalization to run queue. */
03256              Fnl *next = f->next;
03257 
03258              if (prev)
03259               prev->next = next;
03260              else
03261               GC->finalizers = next;
03262              
03263              f->eager_level = 0; /* indicates queued */
03264              
03265              f->next = NULL;
03266              if (last_in_queue) {
03267               last_in_queue->next = f;
03268               last_in_queue = f;
03269              } else {
03270               run_queue = last_in_queue = f;
03271              }
03272              if (!queue)
03273               queue = f;
03274 
03275              f = next;
03276            } else {
03277              prev = f;
03278              f = f->next;
03279            }
03280          } else {
03281            prev = f;
03282            f = f->next;
03283          }
03284        }
03285        
03286        /* Mark items added to run queue: */
03287        f = queue;
03288        while (f) {
03289 #if RECORD_MARK_SRC
03290          mark_src = f;
03291          mark_type = MTYPE_FINALIZER;
03292 #endif
03293          gcMARK(f->p);
03294          f = f->next;
03295        }
03296 
03297        mark_ready_ephemerons(gc);
03298       }
03299        
03300       did_fnls++;
03301     }
03302   }
03303 
03304 #if CHECKS
03305   {
03306     Fnl *f;
03307     /* All finalized objects must be marked at this point. */
03308     for (f = finalizers; f; f = f->next) {
03309       if (!is_marked(f->p))
03310        CRASH(35);
03311     }
03312     for (f = run_queue; f; f = f->next) {
03313       if (!is_marked(f->p))
03314        CRASH(36);
03315     }
03316   }
03317 #endif
03318 
03319 #if TIME
03320   getrusage(RUSAGE_SELF, &post);
03321 #endif
03322 
03323   PRINTTIME((STDERR, "gc: mark (init:%d cycle:%ld stkoflw:%ld)"
03324             STATS_FORMAT
03325             " [%ld/%ld faults]: %ld\n", 
03326             inited_pages, iterations, 
03327             mark_stackoflw,
03328             STATS_ARGS
03329             post.ru_minflt - pre.ru_minflt, post.ru_majflt - pre.ru_majflt,
03330             GETTIMEREL()));
03331 
03332   /******************************************************/
03333 
03334   zero_remaining_ephemerons(gc);
03335   zero_weak_boxes(gc);
03336   zero_weak_arrays(gc);
03337 
03338   /* Cleanup weak finalization links: */
03339   {
03340     Fnl_Weak_Link *wl, *prev, *next;
03341 
03342     prev = NULL;
03343     for (wl = fnl_weaks; wl; wl = next) {
03344       next = wl->next;
03345       if (!is_marked(gc, wl->p)) {
03346        /* Will be collected. Removed this link. */
03347        wl->p = NULL;
03348        if (prev)
03349          prev->next = next;
03350        else
03351          fnl_weaks = next;
03352        --fnl_weak_link_count;
03353       } else {
03354        prev = wl;
03355       }
03356     }
03357   }
03358 
03359   PRINTTIME((STDERR, "gc: weak: %ld\n", GETTIMEREL()));
03360 
03361   /******************************************************/
03362 
03363 #if USE_FREELIST
03364   {
03365     int j;
03366 
03367     for (j = 0; j < NUM_SETS; j++) {
03368       void **free_lists = sets[j]->free_lists;
03369       for (i = 0; i < FREE_LIST_ARRAY_SIZE; i++)
03370        free_lists[i] = NULL;
03371     }
03372 
03373     on_free_list = 0;
03374   }
03375 #endif
03376 
03377   if (compact)
03378     compact_all_mpages();
03379 #if USE_FREELIST
03380   else
03381     freelist_all_mpages(young);
03382 #endif
03383 
03384 #if TIME
03385   getrusage(RUSAGE_SELF, &post);
03386 #endif
03387 
03388   PRINTTIME((STDERR, "gc: %s [%ld/%ld faults]: %ld\n", 
03389             compact ? "compact" : "freelist",
03390             post.ru_minflt - pre.ru_minflt, post.ru_majflt - pre.ru_majflt,
03391             GETTIMEREL()));
03392 
03393   /******************************************************/
03394 
03395   promote_all_ages();
03396 
03397   if (compact) {
03398     for (i = 0; i < NUM_SETS; i++) {
03399       sets[i]->malloc_page = sets[i]->compact_page;
03400       sets[i]->low = sets[i]->compact_to + sets[i]->compact_to_offset;
03401       sets[i]->high = sets[i]->compact_to + MPAGE_WORDS;
03402       if (sets[i]->compact_to_offset < MPAGE_WORDS) {
03403        sets[i]->compact_page->age = 0;
03404        sets[i]->compact_page->refs_age = 0;
03405        sets[i]->compact_page->flags |= MFLAG_MODIFIED;
03406       }
03407     }
03408 
03409     reverse_propagate_new_age();
03410   } else {
03411     for (i = 0; i < NUM_SETS; i++) {
03412       if (sets[i]->malloc_page) {
03413        if (!(sets[i]->malloc_page->flags & COLOR_MASK)) {
03414          sets[i]->malloc_page= NULL;
03415          sets[i]->low = sets[i]->high = (void **)0;
03416        } else
03417          sets[i]->malloc_page->flags -= (sets[i]->malloc_page->flags & MFLAG_INITED);
03418       }
03419     }
03420   }
03421 
03422   /******************************************************/
03423 
03424   resolve_for_fixup = 1;
03425 
03426   if (compact) {
03427 #if CHECKS
03428     int fnl_count = 0;
03429 #endif
03430 
03431     scanned_pages = 0;
03432     
03433     fixup_roots();
03434 
03435     {
03436       Fnl *f;
03437       for (f = GC->finalizers; f; f = f->next) {
03438 #if CHECKS
03439        fnl_count++;
03440 #endif
03441        fixup_finalizer(f);
03442       }
03443       for (f = run_queue; f; f = f->next) {
03444 #if CHECKS
03445        fnl_count++;
03446 #endif
03447        fixup_finalizer(f);
03448       }
03449 #if CHECKS
03450       if (fnl_count != num_fnls)
03451        CRASH(38);
03452 #endif
03453     }
03454     
03455     {
03456       Fnl_Weak_Link *wl;
03457       for (wl = fnl_weaks; wl; wl = wl->next)
03458        fixup_finalizer_weak_link(wl);
03459     }
03460 
03461     fixup_all_mpages();
03462     
03463 #if TIME
03464     getrusage(RUSAGE_SELF, &post);
03465 #endif
03466     
03467     PRINTTIME((STDERR, "gc: fixup (%d) [%ld/%ld faults]: %ld\n", 
03468               scanned_pages,
03469               post.ru_minflt - pre.ru_minflt, post.ru_majflt - pre.ru_majflt,
03470               GETTIMEREL()));
03471   }
03472 
03473   resolve_for_fixup = 0;
03474 
03475   /******************************************************/
03476   
03477   skipped_pages = scanned_pages = 0;
03478 
03479   free_unused_mpages();
03480 
03481   protect_old_mpages();
03482 
03483   reset_finalizer_tree(GC);
03484 
03485 #if (COMPACTING == NEVER_COMPACT)
03486 # define THRESH_FREE_LIST_DELTA (FREE_LIST_DELTA >> LOG_WORD_SIZE)
03487 #else
03488 # define THRESH_FREE_LIST_DELTA FREE_LIST_DELTA
03489 #endif
03490 
03491   gc_threshold = (long)((GROW_FACTOR * (memory_in_use - THRESH_FREE_LIST_DELTA))
03492                      + GROW_ADDITION);
03493 
03494   if (compact) {
03495     for (i = 0; i < NUM_NONATOMIC_SETS; i++) {
03496       if (sets[i]->compact_to_offset < MPAGE_WORDS)
03497        memset(sets[i]->low, 0, (sets[i]->high - sets[i]->low) << LOG_WORD_SIZE);
03498     }
03499   }
03500 
03501 #if TIME
03502   getrusage(RUSAGE_SELF, &post);
03503 #endif
03504 
03505   memory_use_growth += (memory_in_use - prev_memory_in_use);
03506   prev_memory_in_use = memory_in_use;
03507 
03508   PRINTTIME((STDERR, "gc: done with %ld delta=%ld (free:%d cheap:%d) [%ld/%ld faults]: %ld >>\n",
03509             memory_in_use, memory_use_growth, skipped_pages, scanned_pages,
03510             post.ru_minflt - pre.ru_minflt, post.ru_majflt - pre.ru_majflt,
03511             GETTIMEREL()));
03512 
03513   during_gc = 0;
03514 
03515   if (young == 15) {
03516     cycle_count = 0;
03517     memory_use_growth = 0;
03518   } else {
03519     if ((cycle_count & 0x1) 
03520        || (memory_use_growth > INCREMENT_CYCLE_COUNT_GROWTH))
03521       cycle_count++;
03522   }
03523   gc_count++;
03524 
03525   if (GC_collect_start_callback)
03526     GC_collect_end_callback();
03527 
03528   /**********************************************************************/
03529 
03530   /* Run Finalizations. Collections may happen */
03531 
03532   ran_final = 0;
03533 
03534   if (!running_finals) {
03535     running_finals = 1;
03536 
03537     /* Finalization might allocate, which might need park: */
03538     park_save[0] = park[0];
03539     park_save[1] = park[1];
03540     park[0] = NULL;
03541     park[1] = NULL;
03542 
03543     while (run_queue) {
03544       Fnl *f;
03545       void **gcs;
03546       
03547       ran_final++;
03548       
03549       f = run_queue;
03550       run_queue = run_queue->next;
03551       if (!run_queue)
03552        last_in_queue = NULL;
03553       --GC->num_fnls;
03554 
03555       gcs = GC_variable_stack;
03556       f->f(f->p, f->data);
03557       GC_variable_stack = gcs;
03558     }
03559 
03560     running_finals = 0;
03561 
03562     park[0] = park_save[0];
03563     park[1] = park_save[1];
03564     park_save[0] = NULL;
03565     park_save[1] = NULL;
03566   }
03567 }
03568 
03569 void *GC_resolve(void *p)
03570 {
03571   if (resolve_for_fixup) {
03572     GC_fixup(&p);
03573     return p;
03574   } else
03575     return p;
03576 }
03577 
03578 void *GC_fixup_self(void *p)
03579 {
03580   return p;
03581 }
03582 
03583 /******************************************************************************/
03584 /*                               allocators                                   */
03585 /******************************************************************************/
03586 
03587 void *malloc_pages_try_hard(size_t len, size_t alignment)
03588 {
03589   void *m;
03590   int i = 5;
03591 
03592   ran_final = 1;
03593 
03594   while (i--) {
03595     m = malloc_pages(len, alignment);
03596     if (m)
03597       return m;
03598     if (!ran_final)
03599       break;
03600     else
03601       gcollect(1);
03602   }
03603 
03604   if (GC_out_of_memory)
03605     GC_out_of_memory();
03606 
03607   GCPRINT(GCOUTF, "Out of memory\n");
03608   abort();
03609 }
03610 
03611 /**********************************************************************/
03612 
03613 static MPage *get_page_rec(void *p, mtype_t mtype, mflags_t flags)
03614 {
03615   unsigned long g, addr;
03616   MPage *map;
03617 
03618   g = ((unsigned long)p >> MAPS_SHIFT);
03619   
03620   if (!mpage_maps) {
03621     int i;
03622     mpage_maps = (MPage **)malloc_pages(sizeof(MPage *) * MAPS_SIZE, 0);
03623     if (!mpage_maps) {
03624       GCPRINT(GCOUTF, "Can't allocate map list\n");
03625       abort();
03626     }
03627     for (i = 0; i < MAPS_SIZE; i++)
03628       mpage_maps[i] = NULL;
03629   }
03630 
03631   map = mpage_maps[g];
03632   if (!map) {
03633     int i;
03634 
03635     map = (MPage *)malloc_pages_try_hard(sizeof(MPage) * MAP_SIZE, 0);
03636     for (i = 0; i < MAP_SIZE; i++) {
03637       map[i].type = 0;
03638       map[i].flags = 0;
03639     }
03640 
03641     mpage_maps[g] = map;
03642   }
03643 
03644   addr = (((unsigned long)p & MAP_MASK) >> MAP_SHIFT);
03645 
03646 #if NOISY
03647   {
03648     int c;
03649     if (!mtype)
03650       c = '.';
03651     else {
03652       if (mtype <= MTYPE_TAGGED)
03653        c = 't';
03654       else if (mtype == MTYPE_ATOMIC)
03655        c = 'a';
03656       else if (mtype == MTYPE_TAGGED_ARRAY)
03657        c = 'g';
03658       else
03659        c = 'v';
03660 
03661       if (flags & MFLAG_BIGBLOCK)
03662        c = c - ('a' - 'A');
03663     }
03664     GCPRINT(GCOUTF, "%c p = %lx, g = %lx, addr = %lx\n", c, (long)p, g, addr);
03665   }
03666 #endif
03667 
03668   return map + addr;
03669 }
03670 
03671 static void new_page(mtype_t mtype, mflags_t mflags, MSet *set, int link)
03672 {
03673   void *p;
03674   MPage *map;
03675   OffsetArrTy *offsets;
03676 
03677   if ((memory_in_use > gc_threshold) && link && !avoid_collection) {
03678     gcollect(0);
03679     return;
03680   }
03681   
03682   p = (void *)malloc_pages_try_hard(MPAGE_SIZE, MPAGE_SIZE);
03683   offsets = (OffsetArrTy *)malloc_pages_try_hard(OPAGE_SIZE, 0);
03684 
03685   memory_in_use += MPAGE_SIZE;
03686 
03687   map = get_page_rec(p, mtype, mflags);
03688 
03689   map->type = mtype;
03690   map->flags = (mflags | MFLAG_MODIFIED);
03691   map->u.offsets = offsets;
03692   map->block_start = p;
03693   map->age = 0;
03694   map->refs_age = 0;
03695 
03696   if (link) {
03697     map->next = NULL;
03698     map->prev = last;
03699     if (last)
03700       last->next = map;
03701     else
03702       first = map;
03703     last = map;
03704   } else {
03705     map->next = map->prev = NULL;
03706   }
03707 
03708   set->malloc_page = map;
03709 
03710   set->low = (void **)p;
03711   set->high = (void **)(BYTEPTR(p) + MPAGE_SIZE);
03712 
03713 #if KEEP_BACKPOINTERS
03714   map->backpointer_page = (void **)malloc_pages_try_hard(MPAGE_SIZE, 0);
03715 #endif
03716 }
03717 
03718 static void *malloc_bigblock(long size_in_bytes, mtype_t mtype, int link)
03719 {
03720   void *p, *mp;
03721   MPage *map;
03722   long s;
03723 
03724 #if SEARCH
03725   if (size_in_bytes == search_size)
03726     stop();
03727 #endif
03728 
03729   if ((memory_in_use > gc_threshold) && link && !avoid_collection) {
03730     gcollect(0);
03731     return malloc_bigblock(size_in_bytes, mtype, 1);
03732   }
03733   
03734   p = (void *)malloc_pages_try_hard(size_in_bytes, MPAGE_SIZE);
03735 
03736   memory_in_use += size_in_bytes;
03737 
03738   map = get_page_rec(p, mtype, MFLAG_BIGBLOCK);
03739   
03740   map->type = mtype;
03741   map->flags = (MFLAG_BIGBLOCK | MFLAG_MODIFIED);
03742   map->u.size = size_in_bytes;
03743   map->block_start = p;
03744   map->age = 0;
03745   map->refs_age = 0;
03746 
03747   if (link) {
03748     map->next = NULL;
03749     map->prev = last;
03750     if (last)
03751       last->next = map;
03752     else
03753       first = map;
03754     last = map;
03755   } else {
03756     map->next = NULL;
03757     map->prev = NULL;
03758   }
03759 
03760   s = size_in_bytes;
03761   mp = p;
03762   while (s > MPAGE_SIZE) {
03763     mp = BYTEPTR(mp) + MPAGE_SIZE;
03764     s -= MPAGE_SIZE;
03765     map = get_page_rec(mp, 0, MFLAG_CONTINUED | MFLAG_BIGBLOCK);
03766     map->type = mtype;
03767     map->flags = MFLAG_CONTINUED | MFLAG_BIGBLOCK;
03768     map->o.bigblock_start = p;
03769   }
03770 
03771 #if SEARCH
03772   if (p == search_for) {
03773     stop();
03774   }
03775 #endif
03776 
03777   return p;
03778 }
03779 
03780 void *GC_malloc_one_tagged(size_t size_in_bytes)
03781 {
03782   size_t size_in_words;
03783   void **m, **naya;
03784 
03785 #if CHECKS
03786   GC_check_variable_stack();
03787 #endif
03788 
03789   size_in_words = ((size_in_bytes + 3) >> LOG_WORD_SIZE);
03790 
03791 #if CHECKS
03792   if (size_in_words < 2)
03793     CRASH(37);
03794 #endif
03795 
03796   if (size_in_words >= (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE)) {
03797     return malloc_bigblock(size_in_words << LOG_WORD_SIZE, MTYPE_TAGGED, 1);
03798   }
03799 
03800 #if USE_FREELIST
03801   m = (void *)tagged.free_lists[size_in_words];
03802   if (m) {
03803     int i;
03804 
03805     tagged.free_lists[size_in_words] = m[1];
03806 
03807     for (i = 0; i < size_in_words; i++)
03808       m[i] = NULL;
03809 
03810     on_free_list -= size_in_words;
03811     
03812     return m;
03813   }
03814 #endif
03815 
03816 #if ALIGN_DOUBLES
03817   if (!(size_in_words & 0x1)) {
03818     /* Make sure memory is 8-aligned */
03819     if (((long)tagged.low & 0x4)) {
03820       if (tagged.low == tagged.high) {
03821        new_page(MTYPE_TAGGED, 0, &tagged, 1);
03822        return GC_malloc_one_tagged(size_in_words << LOG_WORD_SIZE);
03823       }
03824       ((Type_Tag *)tagged.low)[0] = SKIP;
03825       tagged.low += 1;
03826     }
03827   }
03828 #endif
03829 
03830 #if SEARCH
03831   if (size_in_bytes == search_size)
03832     stop();
03833 #endif
03834 
03835   m = tagged.low;
03836   naya = tagged.low + size_in_words;
03837   if (naya >= tagged.high) {
03838     if (tagged.low < tagged.high)
03839       *(Type_Tag *)tagged.low = TAGGED_EOM;
03840     new_page(MTYPE_TAGGED, 0, &tagged, 1);
03841     return GC_malloc_one_tagged(size_in_words << LOG_WORD_SIZE);
03842   }
03843   tagged.low = naya;
03844 
03845 #if SEARCH
03846   if (m == search_for) {
03847     stop();
03848   }
03849 #endif
03850 
03851   return m;
03852 }
03853 
03854 void *GC_malloc_one_small_tagged(size_t size_in_bytes)
03855 {
03856   return GC_malloc_one_tagged(size_in_bytes);
03857 }
03858 
03859 void *GC_malloc_one_small_dirty_tagged(size_t size_in_bytes)
03860 {
03861   return GC_malloc_one_tagged(size_in_bytes);
03862 }
03863 
03864 void *GC_malloc_pair(void *a, void *b)
03865 {
03866   void *p;
03867 
03868   park[0] = a;
03869   park[1] = b;
03870   p = GC_malloc_one_tagged(3 << LOG_WORD_SIZE);
03871   a = park[0];
03872   b = park[1];
03873 
03874   ((Type_Tag *)p)[0] = pair_tag;
03875   ((void **)p)[1] = a;
03876   ((void **)p)[2] = b;
03877 
03878   return p;
03879 }
03880 
03881 #ifndef gcINLINE
03882 # define gcINLINE inline
03883 #endif
03884 
03885 static gcINLINE void *malloc_untagged(size_t size_in_bytes, mtype_t mtype, MSet *set)
03886 {
03887   size_t size_in_words;
03888   void **m, **naya;
03889 
03890 #if CHECKS
03891   GC_check_variable_stack();
03892 #endif
03893 
03894   if (!size_in_bytes)
03895     return zero_sized;
03896 
03897   size_in_words = ((size_in_bytes + 3) >> LOG_WORD_SIZE);
03898 
03899   if (size_in_words >= (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE)) {
03900     return malloc_bigblock(size_in_words << LOG_WORD_SIZE, mtype, 1);
03901   }
03902 
03903 #if USE_FREELIST
03904   m = (void *)set->free_lists[size_in_words];
03905   if (m) {
03906     int i;
03907 
03908     set->free_lists[size_in_words] = m[0];
03909 
03910     if (mtype != MTYPE_ATOMIC)
03911       memset(m, 0, size_in_words << LOG_WORD_SIZE);
03912 
03913     on_free_list -= size_in_words;
03914     
03915     return m;
03916   }
03917 #endif
03918 
03919 #if ALIGN_DOUBLES
03920   if (!(size_in_words & 0x1)) {
03921     /* Make sure memory is 8-aligned */
03922     if (!((long)set->low & 0x4)) {
03923       if (set->low == set->high) {
03924        new_page(mtype, 0, set, 1);
03925        return malloc_untagged(size_in_words << LOG_WORD_SIZE, mtype, set);
03926       }
03927       (set->low)[0] = 0;
03928       set->low += 1;
03929     }
03930   }
03931 #endif
03932 
03933 #if SEARCH
03934   if (size_in_bytes == search_size)
03935     stop();
03936 #endif
03937 
03938   m = set->low;
03939   naya = set->low + size_in_words + 1;
03940   if (naya >= set->high) {
03941     if (set->low < set->high)
03942       *(long *)set->low = UNTAGGED_EOM - 1;
03943     new_page(mtype, 0, set, 1);
03944     return malloc_untagged(size_in_words << LOG_WORD_SIZE, mtype, set);
03945   }
03946   set->low = naya;
03947 
03948 #if SEARCH
03949   if ((m + 1) == search_for) {
03950     stop();
03951   }
03952 #endif
03953 
03954   *(long *)m = size_in_words;
03955 
03956   return m + 1;
03957 }
03958 
03959 /* Array of pointers: */
03960 void *GC_malloc(size_t size_in_bytes)
03961 {
03962   return malloc_untagged(size_in_bytes, MTYPE_ARRAY, &array);
03963 }
03964 
03965 void *GC_malloc_allow_interior(size_t size_in_bytes)
03966 {
03967   return malloc_bigblock(size_in_bytes, MTYPE_ARRAY, 1);
03968 }
03969 
03970 void *GC_malloc_atomic_allow_interior(size_t size_in_bytes)
03971 {
03972   return malloc_bigblock(size_in_bytes, MTYPE_ATOMIC, 1);
03973 }
03974 
03975 void *GC_malloc_tagged_allow_interior(size_t size_in_bytes)
03976 {
03977   return malloc_bigblock(size_in_bytes, MTYPE_TAGGED, 1);
03978 }
03979 
03980 void *GC_malloc_array_tagged(size_t size_in_bytes)
03981 {
03982   return malloc_untagged(size_in_bytes, MTYPE_TAGGED_ARRAY, &tagged_array);
03983 }
03984 
03985 void *GC_malloc_one_xtagged(size_t size_in_bytes)
03986 {
03987   return malloc_untagged(size_in_bytes, MTYPE_XTAGGED, &xtagged);
03988 }
03989 
03990 /* Pointerless */
03991 void *GC_malloc_atomic(size_t size_in_bytes)
03992 {
03993   return malloc_untagged(size_in_bytes, MTYPE_ATOMIC, &atomic);
03994 }
03995 
03996 /* Plain malloc: */
03997 void *GC_malloc_atomic_uncollectable(size_t size_in_bytes)
03998 {
03999   void *p;
04000   p = malloc(size_in_bytes);
04001   memset(p, 0, size_in_bytes);
04002   return p;
04003 }
04004 
04005 /******************************************************************************/
04006 /*                                  misc                                      */
04007 /******************************************************************************/
04008 
04009 static void free_bigpage(MPage *page)
04010 {
04011   long s;
04012   unsigned long i, j;
04013 
04014   page->type = 0;
04015   page->flags = 0;
04016 
04017   free_pages(page->block_start, page->u.size);
04018        
04019   s = page->u.size;
04020   i = ((unsigned long)page->block_start >> MAPS_SHIFT);
04021   j = (((unsigned long)page->block_start & MAP_MASK) >> MAP_SHIFT);
04022   while (s > MPAGE_SIZE) {
04023     s -= MPAGE_SIZE;
04024     j++;
04025     if (j == MAP_SIZE) {
04026       j = 0;
04027       i++;
04028     }
04029     mpage_maps[i][j].type = 0;
04030     mpage_maps[i][j].flags = 0;
04031   }
04032 }
04033 
04034 void GC_free(void *p)
04035 {
04036   MPage *page;
04037 
04038   page = find_page(p);
04039 
04040   if ((page->flags & MFLAG_BIGBLOCK)
04041       && !(page->flags & MFLAG_CONTINUED)
04042       && (p == page->block_start)) {
04043     memory_in_use -= page->u.size;
04044 
04045     if (page->prev)
04046       page->prev->next = page->next;
04047     else
04048       first = page->next;
04049     if (page->next)
04050       page->next->prev = page->prev;
04051     else
04052       last = page->prev;
04053 
04054     free_bigpage(page);
04055   }
04056 }
04057 
04058 long GC_malloc_stays_put_threshold() 
04059 { 
04060   return BIGBLOCK_MIN_SIZE;
04061 }
04062 
04063 void GC_gcollect()
04064 {
04065   gcollect(1);
04066 }
04067 
04068 long GC_get_memory_use(void *c)
04069 {
04070   return memory_in_use;
04071 }
04072 
04073 int GC_set_account_hook(int type, void *cust, unsigned long b, void *f) 
04074 {
04075   return 0;
04076 }
04077 
04078 int GC_mtrace_new_id(void *f)
04079 {
04080   return 0;
04081 }
04082 
04083 int GC_mtrace_union_current_with(int newval)
04084 {
04085   return 0;
04086 }
04087 
04088 unsigned long GC_get_stack_base(void)
04089 {
04090   return stack_base;
04091 }
04092 
04093 /******************************************************************************/
04094 /*                        malloc and free replacements                        */
04095 /******************************************************************************/
04096 
04097 #if DEFINE_MALLOC_FREE
04098 
04099 # define MALLOC_MIDDLE_SIZE (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE)
04100 
04101 static MSet mallocfree_set;
04102 
04103 void *mallocfree_freelists[FREE_LIST_ARRAY_SIZE];
04104 
04105 void *malloc(size_t size)
04106 {
04107   void **m, **naya;
04108   long size_in_words = (size +  (WORD_SIZE - 1)) >> LOG_WORD_SIZE;
04109   int pos;
04110 
04111   if (size_in_words < 2)
04112     size_in_words = 2; /* need at least 2 for freelist */
04113 
04114   if (size_in_words >= (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE)) {
04115     return malloc_bigblock(size_in_words << LOG_WORD_SIZE, MTYPE_MALLOCFREE, 0);
04116   }
04117 
04118 #if ALIGN_DOUBLES
04119   if (size_in_words & 0x1)
04120     size_in_words++;
04121 #endif
04122 
04123   if (mallocfree_freelists[size_in_words]) {
04124     MPage *page;
04125 
04126     m = mallocfree_freelists[size_in_words];
04127     mallocfree_freelists[size_in_words] = ((void **)m)[1];
04128 
04129     page = find_page(m);
04130     pos = m - (void **)((long)m & MPAGE_START);
04131 
04132     OFFSET_SET_SIZE_UNMASKED(page->u.offsets, pos, size_in_words);
04133     while (--size_in_words) {
04134       pos++;
04135       OFFSET_SET_SIZE_UNMASKED(page->u.offsets, pos, MALLOC_MIDDLE_SIZE);
04136     }
04137 
04138     return m;
04139   }
04140 
04141   m = mallocfree_set.low;
04142   naya = m + size_in_words;
04143   if (naya >= mallocfree_set.high) {
04144     new_page(MTYPE_MALLOCFREE, 0, &mallocfree_set, 0);
04145     return malloc(size);
04146   }
04147   mallocfree_set.low = naya;
04148 
04149   pos = m - (void **)mallocfree_set.malloc_page->block_start;
04150 
04151   OFFSET_SET_SIZE_UNMASKED(mallocfree_set.malloc_page->u.offsets, pos, size_in_words);
04152   while (--size_in_words) {
04153     pos++;
04154     OFFSET_SET_SIZE_UNMASKED(mallocfree_set.malloc_page->u.offsets, pos, MALLOC_MIDDLE_SIZE);
04155   }
04156 
04157   return m;
04158 }
04159 
04160 void free(void *p)
04161 {
04162   MPage *page;
04163   int pos;
04164   long sz;
04165 
04166   if (!p)
04167     return;
04168 
04169   page = find_page(p);
04170   if (!page || (page->type != MTYPE_MALLOCFREE)) {
04171     GCPRINT(GCOUTF, "Free of non-malloced pointer! %p\n", p);
04172     return;
04173   }
04174   
04175   if (page->flags & MFLAG_BIGBLOCK) {
04176     if ((page->flags & MFLAG_CONTINUED) || (p != page->block_start)) {
04177       GCPRINT(GCOUTF, "Free of in the middle of large malloced pointer! %p\n", p);
04178       return;
04179     }
04180 
04181     free_bigpage(page);
04182 
04183     return;
04184   }
04185 
04186   pos = (void **)p - (void **)page->block_start;
04187 
04188   sz = OFFSET_SIZE(page->u.offsets, pos);
04189 
04190   if (!sz) {
04191     GCPRINT(GCOUTF, "Free of non-malloced to already-freed pointer! %p\n", p);
04192     return;
04193   }
04194 
04195   if (sz == MALLOC_MIDDLE_SIZE) {
04196     GCPRINT(GCOUTF, "Free in middle of malloced pointer! %p\n", p);
04197     return;
04198   }
04199 
04200   OFFSET_SET_SIZE_UNMASKED(page->u.offsets, pos, 0);
04201 
04202   ((int *)p)[0] = sz;
04203   ((void **)p)[1] = mallocfree_freelists[sz];
04204   mallocfree_freelists[sz] = p;
04205 
04206   while (--sz) {
04207     pos++;
04208     OFFSET_SET_SIZE_UNMASKED(page->u.offsets, pos, 0);
04209   }
04210 }
04211 
04212 void *realloc(void *p, size_t size)
04213 {
04214   void *naya;
04215   size_t oldsize;
04216 
04217   if (p) {
04218     MPage *page;
04219     page = find_page(p);
04220     if (!page || (page->type != MTYPE_MALLOCFREE)) {
04221       GCPRINT(GCOUTF, "Realloc of non-malloced pointer! %p\n", p);
04222       oldsize = 0;
04223     } else {
04224       if (page->flags & MFLAG_BIGBLOCK) {
04225        if ((page->flags & MFLAG_CONTINUED) || (p != page->block_start)) {
04226          GCPRINT(GCOUTF, "Realloc of in the middle of large malloced pointer! %p\n", p);
04227          oldsize = 0;
04228        } else
04229          oldsize = page->u.size;
04230       } else {
04231        int pos;
04232        pos = (void **)p - (void **)page->block_start;
04233        oldsize = OFFSET_SIZE(page->u.offsets, pos);
04234        if (oldsize == MALLOC_MIDDLE_SIZE) {
04235          GCPRINT(GCOUTF, "Realloc in middle of malloced pointer! %p\n", p);
04236          oldsize = 0;
04237        }
04238       }
04239     }
04240   } else
04241     oldsize = 0;
04242 
04243   oldsize <<= LOG_WORD_SIZE;
04244 
04245   naya = malloc(size);
04246   if (oldsize > size)
04247     oldsize = size;
04248   memcpy(naya, p, oldsize);
04249   if (p)
04250     free(p);
04251 
04252   return naya;
04253 }
04254 
04255 void *calloc(size_t n, size_t size)
04256 {
04257   void *p;
04258   long c;
04259 
04260   c = n * size;
04261   p = malloc(c);
04262   memset(p, 0, c);
04263 
04264   return p;
04265 }
04266 
04267 # if CHECKS
04268 static void check_not_freed(MPage *page, const void *p)
04269 {
04270   if (page->flags & MFLAG_BIGBLOCK) {
04271     /* Ok */
04272   } else {
04273     int pos;
04274     pos = (void **)p - (void **)page->block_start;
04275     if (!OFFSET_SIZE(page->u.offsets, pos)) {
04276       GCPRINT(GCOUTF, "Mark of previously malloced? (now freed) pointer: %p\n", p);
04277       CRASH(77);
04278     }
04279   }
04280 }
04281 # endif
04282 
04283 #endif
04284 
04285 /******************************************************************************/
04286 /*                             GC stat dump                                   */
04287 /******************************************************************************/
04288 
04289 static long dump_info_array[BIGBLOCK_MIN_SIZE];
04290 
04291 #if KEEP_BACKPOINTERS
04292 
04293 static void *trace_backpointer(MPage *page, void *p)
04294 {
04295 
04296   if (page->flags & MFLAG_BIGBLOCK)
04297     return (void *)page->backpointer_page;
04298   else {
04299     int offset;
04300     offset = ((char *)p - (char *)page->block_start) >> LOG_WORD_SIZE;
04301     if (page->type != MTYPE_TAGGED)
04302       offset -= 1;
04303     if (offset > 0)
04304       return page->backpointer_page[offset];
04305     else
04306       return NULL; /* This shouldn't happen */
04307   }
04308 }
04309 
04310 # define trace_page_t MPage
04311 # define trace_page_type(page) (page)->type
04312 static void *trace_pointer_start(struct mpage *page, void *p) { 
04313   if (page->flags & MFLAG_BIGBLOCK) 
04314     return page->block_start;
04315   else 
04316     return p;
04317 }
04318 # define TRACE_PAGE_TAGGED MTYPE_TAGGED
04319 # define TRACE_PAGE_ARRAY MTYPE_ARRAY
04320 # define TRACE_PAGE_TAGGED_ARRAY MTYPE_TAGGED_ARRAY
04321 # define TRACE_PAGE_ATOMIC MTYPE_ATOMIC
04322 # define TRACE_PAGE_XTAGGED MTYPE_XTAGGED
04323 # define TRACE_PAGE_MALLOCFREE MTYPE_MALLOCFREE
04324 # define TRACE_PAGE_BAD 0
04325 # define trace_page_is_big(page) ((page)->flags & MFLAG_BIGBLOCK)
04326 
04327 # include "backtrace.c"
04328 
04329 #endif
04330 
04331 static long scan_tagged_mpage(void **p, MPage *page, short trace_for_tag,
04332                            GC_for_each_found_proc for_each_found)
04333 {
04334   void **top, **bottom = p;
04335 
04336   top = p + MPAGE_WORDS;
04337   
04338   while (p < top) {
04339     Type_Tag tag;
04340     long size;
04341 
04342     tag = *(Type_Tag *)p;
04343 
04344     if (tag == TAGGED_EOM) {
04345       return (p - bottom);
04346     }
04347 
04348 #if ALIGN_DOUBLES
04349     if (tag == SKIP) {
04350       p++;
04351     } else {
04352 #endif      
04353       {
04354        Size_Proc size_proc;
04355        
04356        size_proc = size_table[tag];
04357        if (((long)size_proc) < 100)
04358          size = (long)size_proc;
04359        else
04360          size = size_proc(p);
04361       }
04362 
04363       dump_info_array[tag]++;
04364       dump_info_array[tag + NUMBER_OF_TAGS] += size;
04365 
04366       if (tag == trace_for_tag) {
04367 #if KEEP_BACKPOINTERS
04368        register_traced_object(p);
04369 #endif
04370        if (for_each_found)
04371          for_each_found(p);
04372       }
04373 
04374       p += size;
04375 #if ALIGN_DOUBLES
04376     }
04377 #endif
04378   }
04379 
04380   return MPAGE_WORDS;
04381 }
04382 
04383 static long scan_untagged_mpage(void **p, MPage *page)
04384 {
04385   void **top, **bottom = p;
04386 
04387   top = p + MPAGE_WORDS;
04388 
04389   while (p < top) {
04390     long size;
04391 
04392     size = *(long *)p + 1;
04393 
04394     if (size == UNTAGGED_EOM) {
04395       return (p - bottom);
04396     }
04397 
04398     dump_info_array[size - 1] += 1;
04399 
04400     p += size;
04401   } 
04402 
04403   return MPAGE_WORDS;
04404 }
04405 
04406 #if KEEP_BACKPOINTERS
04407 
04408 int GC_is_tagged(void *p)
04409 {
04410   MPage *page;
04411   page = find_page(p);
04412   return page && (page->type == MTYPE_TAGGED);
04413 }
04414 
04415 static void *next_tagged_start(void *p, int stop_at_p)
04416 {
04417   MPage *page;
04418   void **p2, **top;
04419   int prev_was_p = 0;
04420 
04421   page = find_page(p);
04422   if (page && (page->type == MTYPE_TAGGED)) {
04423     p2 = (void **)page->block_start;
04424 
04425     if (page->flags & MFLAG_CONTINUED)
04426       return NULL;
04427     if (page->flags & MFLAG_BIGBLOCK) {
04428       if (p == (void *)p2) {
04429        if (stop_at_p)
04430          return p;
04431       }
04432       return NULL;
04433     }
04434 
04435     top = p2 + MPAGE_WORDS;
04436     
04437     while (p2 < top) {
04438       Type_Tag tag;
04439       long size;
04440 
04441       if (stop_at_p) {
04442        if ((void *)p2 == p)
04443          return p;
04444        if ((unsigned long)p2 > (unsigned long)p)
04445          break;
04446       }
04447       
04448       tag = *(Type_Tag *)p2;
04449 
04450       if (tag == TAGGED_EOM)
04451        break;
04452 
04453 #if ALIGN_DOUBLES
04454       if (tag == SKIP) {
04455        p2++;
04456       } else {
04457 #endif
04458        if (prev_was_p)
04459          return (void *)p2;
04460 
04461        {
04462          Size_Proc size_proc;
04463        
04464          size_proc = size_table[tag];
04465          if (((long)size_proc) < 100)
04466            size = (long)size_proc;
04467          else
04468            size = size_proc(p2);
04469        }
04470 
04471        prev_was_p = (p == p2);
04472       
04473        p2 += size;
04474 #if ALIGN_DOUBLES
04475       }
04476 #endif
04477     }
04478   }
04479   
04480   return NULL;
04481 }
04482 
04483 int GC_is_tagged_start(void *p)
04484 {
04485   if (next_tagged_start(p, 1))
04486     return 1;
04487   else
04488     return 0;
04489 }
04490 
04491 void *GC_next_tagged_start(void *p)
04492 {
04493   void *p2;
04494 
04495   while (1) {
04496     p2 = next_tagged_start(p, 0);
04497     if (p2)
04498       return p2;
04499 
04500     p = (void *)(((long)p & MPAGE_START) + MPAGE_SIZE);
04501     if (!p)
04502       return NULL;
04503   }
04504 }
04505 
04506 #endif
04507 
04508 void GC_dump_with_traces(int flags,
04509                       GC_get_type_name_proc get_type_name,
04510                       GC_get_xtagged_name_proc get_xtagged_name,
04511                       GC_for_each_found_proc for_each_found,
04512                       short trace_for_tag,
04513                       GC_print_tagged_value_proc print_tagged_value,
04514                       int path_length_limit)
04515 {
04516   int i;
04517   long waste = 0;
04518 
04519   if (!(flags & GC_DUMP_SHOW_TRACE))
04520     trace_for_tag = -1;
04521 #if KEEP_BACKPOINTERS
04522   reset_object_traces();
04523 #endif
04524   if (for_each_found)
04525     avoid_collection++;
04526 
04527   if (flags & GC_DUMP_SHOW_DETAILS) {
04528     GCPRINT(GCOUTF, "t=tagged a=atomic v=array x=xtagged g=tagarray\n");
04529     GCPRINT(GCOUTF, "mpagesize=%ld  opagesize=%ld\n", (long)MPAGE_SIZE, (long)OPAGE_SIZE);
04530     GCPRINT(GCOUTF, "[");
04531     for (i = 0; i < MAPS_SIZE; i++) {
04532       if (i && !(i & 63))
04533        GCPRINT(GCOUTF, "\n ");
04534 
04535       if (mpage_maps[i])
04536        GCPRINT(GCOUTF, "*");
04537       else
04538        GCPRINT(GCOUTF, "-");
04539     }
04540     GCPRINT(GCOUTF, "]\n");
04541     for (i = 0; i < MAPS_SIZE; i++) {
04542       MPage *maps = mpage_maps[i];
04543       if (maps) {
04544        int j;
04545        GCPRINT(GCOUTF, "%.2x:\n ", i);
04546        for (j = 0; j < MAP_SIZE; j++) {
04547          if (j && !(j & 63))
04548            GCPRINT(GCOUTF, "\n ");
04549 
04550          if (maps[j].type
04551 #if DEFINE_MALLOC_FREE
04552              && (maps[j].type != MTYPE_MALLOCFREE)
04553 #endif
04554              ) {
04555            int c;
04556 
04557            if (maps[j].flags & MFLAG_CONTINUED) 
04558              c = '.';
04559            else {
04560              if (maps[j].type <= MTYPE_TAGGED)
04561               c = 't';
04562              else if (maps[j].type == MTYPE_TAGGED_ARRAY)
04563               c = 'g';
04564              else if (maps[j].type == MTYPE_ATOMIC)
04565               c = 'a';
04566              else if (maps[j].type == MTYPE_XTAGGED)
04567               c = 'x';
04568              else
04569               c = 'v';
04570            
04571              if (maps[j].flags & MFLAG_BIGBLOCK)
04572               c = c - ('a' - 'A');
04573            }
04574 
04575            GCPRINT(GCOUTF, "%c", c);
04576          } else {
04577            GCPRINT(GCOUTF, "-");
04578          }
04579        }
04580        GCPRINT(GCOUTF, "\n");
04581       }
04582     }
04583 
04584     {
04585       MPage *page;
04586 
04587       GCPRINT(GCOUTF, "Block info: [type][modified?][age][refs-age]\n");
04588       for (page = first, i = 0; page; page = page->next, i++) {
04589        int c;
04590 
04591        if (page->flags & MFLAG_CONTINUED) 
04592          c = '.';
04593        else {
04594          if (page->type <= MTYPE_TAGGED)
04595            c = 't';
04596          else if (page->type == MTYPE_TAGGED_ARRAY)
04597            c = 'g';
04598          else if (page->type == MTYPE_ATOMIC)
04599            c = 'a';
04600          else if (page->type == MTYPE_XTAGGED)
04601            c = 'x';
04602          else
04603            c = 'v';
04604         
04605          if (page->flags & MFLAG_BIGBLOCK)
04606            c = c - ('a' - 'A');
04607        }
04608        
04609        GCPRINT(GCOUTF, " %c%c%c%c",
04610               c,
04611               ((page->flags & MFLAG_MODIFIED)
04612                ? 'M'
04613                : '_'),
04614               ((page->age < 10)
04615                ? (page->age + '0')
04616                : (page->age + 'a' - 10)),
04617               ((page->type == MTYPE_ATOMIC)
04618                ? '-'
04619                : ((page->refs_age < 10)
04620                   ? (page->refs_age + '0')
04621                   : (page->refs_age + 'a' - 10))));
04622        if ((i % 10) == 9)
04623          GCPRINT(GCOUTF, "\n");
04624       }
04625       GCPRINT(GCOUTF, "\n");
04626     }
04627   }
04628 
04629   {
04630     int j;
04631 
04632     init();
04633     set_ending_tags();
04634 
04635     for (j = 0; j < NUM_SETS; j++) {
04636       int kind, i;
04637       char *name;
04638       MPage *page;
04639       long used, total;
04640 
04641       switch (j) {
04642       case 1: kind = MTYPE_ARRAY; name = "array"; break;
04643       case 2: kind = MTYPE_ATOMIC; name = "atomic"; break;
04644       case 3: kind = MTYPE_XTAGGED; name = "xtagged"; break;
04645       case 4: kind = MTYPE_TAGGED_ARRAY; name = "tagarray"; break;
04646       default: kind = MTYPE_TAGGED; name = "tagged"; break;
04647       }
04648 
04649       for (i = 0; i < (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE); i++)
04650        dump_info_array[i] = 0;
04651 
04652       total = 0;
04653 
04654       for (page = first; page; page = page->next) {
04655        if ((page->type == kind) && !(page->flags & MFLAG_BIGBLOCK)) {
04656          if (j >= NUM_TAGGED_SETS)
04657            used = scan_untagged_mpage(page->block_start, page); /* gets size counts */
04658          else
04659            used = scan_tagged_mpage(page->block_start, page, 
04660                                  trace_for_tag, for_each_found); /* gets tag counts */
04661 
04662          total += used;
04663          waste += (MPAGE_WORDS - used);
04664        }
04665        if ((page->flags & MFLAG_BIGBLOCK)
04666            && (page->type == kind)
04667            && (((trace_for_tag >= (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE))
04668                && (page->u.size > trace_for_tag))
04669               || (page->u.size == -trace_for_tag))) {
04670 #if KEEP_BACKPOINTERS
04671          register_traced_object(page->block_start);
04672 #endif
04673          if (for_each_found)
04674            for_each_found(page->block_start);
04675        }
04676       }
04677 
04678       if (j >= NUM_TAGGED_SETS) {
04679        int k = 0;
04680        if (flags & GC_DUMP_SHOW_DETAILS) {
04681          GCPRINT(GCOUTF, "%s counts: ", name);
04682          for (i = 0; i < (BIGBLOCK_MIN_SIZE >> LOG_WORD_SIZE); i++) {
04683            if (dump_info_array[i]) {
04684              k++;
04685              if (k == 10) {
04686               GCPRINT(GCOUTF, "\n    ");
04687               k = 0;
04688              }
04689              GCPRINT(GCOUTF, " [%d:%ld]", i << LOG_WORD_SIZE, dump_info_array[i]);
04690            }
04691          }
04692          GCPRINT(GCOUTF, "\n");
04693        }
04694       } else {
04695        GCPRINT(GCOUTF, "Tag counts and sizes:\n");
04696        GCPRINT(GCOUTF, "Begin MzScheme3m\n");
04697        for (i = 0; i < NUMBER_OF_TAGS; i++) {
04698          if (dump_info_array[i]) {
04699            char *tn, buf[256];
04700            switch(i) {
04701            case gc_on_free_list_tag: tn = "freelist-elem"; break;
04702            default:
04703              if (i == weak_array_tag)
04704               tn = "weak-array";
04705              else if (get_type_name)
04706               tn = get_type_name((Type_Tag)i);
04707              else
04708               tn = NULL;
04709              if (!tn) {
04710               sprintf(buf, "unknown,%d", i);
04711               tn = buf;
04712              }
04713              break;
04714            }
04715            GCPRINT(GCOUTF, "  %20.20s: %10ld %10ld\n", tn, dump_info_array[i], (dump_info_array[i + NUMBER_OF_TAGS]) << LOG_WORD_SIZE);
04716          }
04717        }
04718        GCPRINT(GCOUTF, "End MzScheme3m\n");
04719       }
04720 
04721       if (flags & GC_DUMP_SHOW_DETAILS) {
04722        int did_big = 0;
04723        for (page = first; page; page = page->next) {
04724          if ((page->type == kind) && (page->flags & MFLAG_BIGBLOCK) && !(page->flags & MFLAG_CONTINUED)) {
04725            if (!did_big) {
04726              GCPRINT(GCOUTF, "    ");
04727              did_big = 1;
04728            }
04729            if (j >= NUM_TAGGED_SETS)
04730              GCPRINT(GCOUTF, " [+%ld]", page->u.size);
04731            else
04732              GCPRINT(GCOUTF, " %d:[+%ld]", (int)*(Type_Tag *)(page->block_start), page->u.size);
04733            
04734            total += (page->u.size >> LOG_WORD_SIZE);
04735            waste += ((page->u.size >> LOG_WORD_SIZE)  & (MPAGE_WORDS - 1));
04736          }
04737        }
04738        if (did_big)
04739          GCPRINT(GCOUTF, "\n");
04740       }
04741 
04742       GCPRINT(GCOUTF, " Total %s: %ld\n", name, total << LOG_WORD_SIZE);
04743     }
04744   }
04745 
04746   GCPRINT(GCOUTF, "Active fnls: %d\n", GC->num_fnls);
04747   GCPRINT(GCOUTF, "Active fnl weak links: %d\n", fnl_weak_link_count);
04748 
04749   if (memory_in_use > max_memory_use)
04750     max_memory_use = memory_in_use;
04751   
04752   GCPRINT(GCOUTF, "Number of collections: %d  (%d compacting)\n", gc_count, compact_count);
04753   GCPRINT(GCOUTF, "Memory high point: %ld\n", max_memory_use);
04754 
04755   GCPRINT(GCOUTF, "Memory use: %ld\n", memory_in_use - FREE_LIST_DELTA);
04756   GCPRINT(GCOUTF, "Memory wasted: %ld (%.2f%%)\n", waste << LOG_WORD_SIZE, 
04757          (100.0 * (waste << LOG_WORD_SIZE)) / memory_in_use);
04758   GCPRINT(GCOUTF, "Memory overhead: %ld (%.2f%%)   %ld (%.2f%%) on free list\n", 
04759          page_allocations - memory_in_use + FREE_LIST_DELTA,
04760          (100.0 * ((double)page_allocations - memory_in_use)) / memory_in_use,
04761          (long)FREE_LIST_DELTA,
04762          (100.0 * FREE_LIST_DELTA) / memory_in_use);
04763   GCPRINT(GCOUTF, "Mmap overhead: %ld (%.2f%%)\n", 
04764          vm_memory_allocated(GC->vm) - memory_in_use + FREE_LIST_DELTA,
04765          (100.0 * ((double) vm_memory_allocated(GC->vm) - memory_in_use)) / memory_in_use);
04766 
04767 #if KEEP_BACKPOINTERS
04768   if (flags & GC_DUMP_SHOW_TRACE) {
04769     print_traced_objects(path_length_limit, get_type_name, get_xtagged_name, print_tagged_value);
04770   }
04771   if (flags & GC_DUMP_SHOW_FINALS) {
04772     Fnl *f;
04773     avoid_collection++;
04774     GCPRINT(GCOUTF, "Begin Finalizations\n");
04775     for (f = finalizers; f; f = f->next) {
04776       print_out_pointer("==@ ", f->p, get_type_name, get_xtagged_name, print_tagged_value);
04777     }
04778     GCPRINT(GCOUTF, "End Finalizations\n");
04779     --avoid_collection;
04780   }
04781 #endif
04782   if (for_each_found)
04783     --avoid_collection;
04784 }
04785 
04786 void GC_dump(void)
04787 {
04788   GC_dump_with_traces(0, NULL, NULL, NULL, 0, NULL, 0);
04789 }
04790 
04791 /******************************************************************************/
04792 /*                              GC free all                                   */
04793 /******************************************************************************/
04794 
04795 void GC_free_all(void)
04796 {
04797   vm_flush_freed_pages(GC->vm);
04798   vm_free(GC->vm);
04799   free(GC); 
04800 }
04801