Back to index

plt-scheme  4.2.1
alloc.c
Go to the documentation of this file.
00001 /*
00002  * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers
00003  * Copyright (c) 1991-1996 by Xerox Corporation.  All rights reserved.
00004  * Copyright (c) 1998 by Silicon Graphics.  All rights reserved.
00005  * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved.
00006  *
00007  * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
00008  * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
00009  *
00010  * Permission is hereby granted to use or copy this program
00011  * for any purpose,  provided the above notices are retained on all copies.
00012  * Permission to modify the code and to distribute modified code is granted,
00013  * provided the above notices are retained, and a notice that the code was
00014  * modified is included with the above copyright notice.
00015  *
00016  */
00017 
00018 
00019 # include "private/gc_priv.h"
00020 
00021 # include <stdio.h>
00022 # if !defined(MACOS) && !defined(MSWINCE)
00023 #   include <signal.h>
00024 #   include <sys/types.h>
00025 # endif
00026 
00027 /*
00028  * Separate free lists are maintained for different sized objects
00029  * up to MAXOBJSZ.
00030  * The call GC_allocobj(i,k) ensures that the freelist for
00031  * kind k objects of size i points to a non-empty
00032  * free list. It returns a pointer to the first entry on the free list.
00033  * In a single-threaded world, GC_allocobj may be called to allocate
00034  * an object of (small) size i as follows:
00035  *
00036  *            opp = &(GC_objfreelist[i]);
00037  *            if (*opp == 0) GC_allocobj(i, NORMAL);
00038  *            ptr = *opp;
00039  *            *opp = obj_link(ptr);
00040  *
00041  * Note that this is very fast if the free list is non-empty; it should
00042  * only involve the execution of 4 or 5 simple instructions.
00043  * All composite objects on freelists are cleared, except for
00044  * their first word.
00045  */
00046 
00047 /*
00048  *  The allocator uses GC_allochblk to allocate large chunks of objects.
00049  * These chunks all start on addresses which are multiples of
00050  * HBLKSZ.   Each allocated chunk has an associated header,
00051  * which can be located quickly based on the address of the chunk.
00052  * (See headers.c for details.) 
00053  * This makes it possible to check quickly whether an
00054  * arbitrary address corresponds to an object administered by the
00055  * allocator.
00056  */
00057 
00058 word GC_non_gc_bytes = 0;  /* Number of bytes not intended to be collected */
00059 
00060 word GC_gc_no = 0;
00061 
00062 #ifndef SMALL_CONFIG
00063   int GC_incremental = 0;  /* By default, stop the world.      */
00064 #endif
00065 
00066 int GC_parallel = FALSE;   /* By default, parallel GC is off.  */
00067 
00068 int GC_full_freq = 19;         /* Every 20th collection is a full     */
00069                         /* collection, whether we need it      */
00070                         /* or not.                       */
00071 
00072 GC_bool GC_need_full_gc = FALSE;
00073                         /* Need full GC do to heap growth.     */
00074 
00075 #ifdef THREADS
00076   GC_bool GC_world_stopped = FALSE;
00077 # define IF_THREADS(x) x
00078 #else
00079 # define IF_THREADS(x)
00080 #endif
00081 
00082 word GC_used_heap_size_after_full = 0;
00083 
00084 char * GC_copyright[] =
00085 {"Copyright 1988,1989 Hans-J. Boehm and Alan J. Demers ",
00086 "Copyright (c) 1991-1995 by Xerox Corporation.  All rights reserved. ",
00087 "Copyright (c) 1996-1998 by Silicon Graphics.  All rights reserved. ",
00088 "Copyright (c) 1999-2001 by Hewlett-Packard Company.  All rights reserved. ",
00089 "THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY",
00090 " EXPRESSED OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.",
00091 "See source code for details." };
00092 
00093 # include "version.h"
00094 
00095 #if defined(SAVE_CALL_CHAIN) && \
00096        !(defined(REDIRECT_MALLOC) && defined(GC_HAVE_BUILTIN_BACKTRACE))
00097 #   define SAVE_CALL_CHAIN_IN_GC
00098     /* This is only safe if the call chain save mechanism won't end up       */
00099     /* calling GC_malloc.  The GNU C library documentation suggests   */
00100     /* that backtrace doesn't use malloc, but at least the initial    */
00101     /* call in some versions does seem to invoke the dynamic linker,  */
00102     /* which uses malloc.                                      */
00103 #endif
00104 
00105 /* some more variables */
00106 
00107 extern signed_word GC_mem_found;  /* Number of reclaimed longwords    */
00108                               /* after garbage collection             */
00109 
00110 GC_bool GC_dont_expand = 0;
00111 
00112 word GC_free_space_divisor = 4; /* PLTSCHEME: 3 -> 4 */
00113 
00114 extern GC_bool GC_collection_in_progress();
00115               /* Collection is in progress, or was abandoned.  */
00116 
00117 int GC_never_stop_func GC_PROTO((void)) { return(0); }
00118 
00119 unsigned long GC_time_limit = TIME_LIMIT;
00120 
00121 CLOCK_TYPE GC_start_time;   /* Time at which we stopped world. */
00122                             /* used only in GC_timeout_stop_func.     */
00123 
00124 int GC_n_attempts = 0;             /* Number of attempts at finishing */
00125                             /* collection within GC_time_limit.       */
00126 
00127 #if defined(SMALL_CONFIG) || defined(NO_CLOCK)
00128 #   define GC_timeout_stop_func GC_never_stop_func
00129 #else
00130   int GC_timeout_stop_func GC_PROTO((void))
00131   {
00132     CLOCK_TYPE current_time;
00133     static unsigned count = 0;
00134     unsigned long time_diff;
00135     
00136     if ((count++ & 3) != 0) return(0);
00137     GET_TIME(current_time);
00138     time_diff = MS_TIME_DIFF(current_time,GC_start_time);
00139     if (time_diff >= GC_time_limit) {
00140 #      ifdef CONDPRINT
00141          if (GC_print_stats) {
00142            GC_printf0("Abandoning stopped marking after ");
00143            GC_printf1("%lu msecs", (unsigned long)time_diff);
00144            GC_printf1("(attempt %ld)\n", (unsigned long) GC_n_attempts);
00145          }
00146 #      endif
00147        return(1);
00148     }
00149     return(0);
00150   }
00151 #endif /* !SMALL_CONFIG */
00152 
00153 /* Return the minimum number of words that must be allocated between  */
00154 /* collections to amortize the collection cost.                       */
00155 static word min_words_allocd()
00156 {
00157 #   ifdef THREADS
00158        /* We punt, for now. */
00159        register signed_word stack_size = 10000;
00160 #   else
00161         int dummy;
00162         register signed_word stack_size = (ptr_t)(&dummy) - GC_stackbottom;
00163 #   endif
00164     word total_root_size;       /* includes double stack size, */
00165                                 /* since the stack is expensive       */
00166                                 /* to scan.                           */
00167     word scan_size;         /* Estimate of memory to be scanned       */
00168                             /* during normal GC.               */
00169     
00170     if (stack_size < 0) stack_size = -stack_size;
00171     total_root_size = 2 * stack_size + GC_root_size;
00172     scan_size = BYTES_TO_WORDS(GC_heapsize - GC_large_free_bytes
00173                             + (GC_large_free_bytes >> 2)
00174                                /* use a bit more of large empty heap */
00175                             + total_root_size);
00176     if (TRUE_INCREMENTAL) {
00177         return scan_size / (2 * GC_free_space_divisor);
00178     } else {
00179         return scan_size / GC_free_space_divisor;
00180     }
00181 }
00182 
00183 /* Return the number of words allocated, adjusted for explicit storage       */
00184 /* management, etc..  This number is used in deciding when to trigger */
00185 /* collections.                                                       */
00186 word GC_adj_words_allocd()
00187 {
00188     register signed_word result;
00189     register signed_word expl_managed =
00190               BYTES_TO_WORDS((long)GC_non_gc_bytes
00191                             - (long)GC_non_gc_bytes_at_gc);
00192     
00193     /* Don't count what was explicitly freed, or newly allocated for  */
00194     /* explicit management.  Note that deallocating an explicitly     */
00195     /* managed object should not alter result, assuming the client    */
00196     /* is playing by the rules.                                       */
00197     result = (signed_word)GC_words_allocd
00198             - (signed_word)GC_mem_freed 
00199             + (signed_word)GC_finalizer_mem_freed - expl_managed;
00200     if (result > (signed_word)GC_words_allocd) {
00201         result = GC_words_allocd;
00202        /* probably client bug or unfortunate scheduling */
00203     }
00204     result += GC_words_finalized;
00205        /* We count objects enqueued for finalization as though they   */
00206        /* had been reallocated this round. Finalization is user       */
00207        /* visible progress.  And if we don't count this, we have      */
00208        /* stability problems for programs that finalize all objects.  */
00209     if ((signed_word)(GC_words_wasted >> 3) < result)
00210         result += GC_words_wasted;
00211        /* This doesn't reflect useful work.  But if there is lots of  */
00212        /* new fragmentation, the same is probably true of the heap,   */
00213        /* and the collection will be correspondingly cheaper.         */
00214     if (result < (signed_word)(GC_words_allocd >> 3)) {
00215        /* Always count at least 1/8 of the allocations.  We don't want       */
00216        /* to collect too infrequently, since that would inhibit       */
00217        /* coalescing of free storage blocks.                          */
00218        /* This also makes us partially robust against client bugs.    */
00219         return(GC_words_allocd >> 3);
00220     } else {
00221         return(result);
00222     }
00223 }
00224 
00225 
00226 /* Clear up a few frames worth of garbage left at the top of the stack.      */
00227 /* This is used to prevent us from accidentally treating garbade left */
00228 /* on the stack by other parts of the collector as roots.  This       */
00229 /* differs from the code in misc.c, which actually tries to keep the  */
00230 /* stack clear of long-lived, client-generated garbage.               */
00231 void GC_clear_a_few_frames()
00232 {
00233 #   define NWORDS 64
00234     word frames[NWORDS];
00235     /* Some compilers will warn that frames was set but never used.   */
00236     /* That's the whole idea ...                               */
00237     register int i;
00238     
00239     for (i = 0; i < NWORDS; i++) frames[i] = 0;
00240 }
00241 
00242 /* Heap size at which we need a collection to avoid expanding past    */
00243 /* limits used by blacklisting.                                       */
00244 static word GC_collect_at_heapsize = (word)(-1);
00245 
00246 /* Have we allocated enough to amortize a collection? */
00247 GC_bool GC_should_collect()
00248 {
00249     return(GC_adj_words_allocd() >= min_words_allocd()
00250           || GC_heapsize >= GC_collect_at_heapsize);
00251 }
00252 
00253 
00254 void GC_notify_full_gc()
00255 {
00256     if (GC_start_call_back != (void (*) GC_PROTO((void)))0) {
00257        (*GC_start_call_back)();
00258     }
00259 }
00260 
00261 GC_bool GC_is_full_gc = FALSE;
00262 
00263 /* 
00264  * Initiate a garbage collection if appropriate.
00265  * Choose judiciously
00266  * between partial, full, and stop-world collections.
00267  * Assumes lock held, signals disabled.
00268  */
00269 void GC_maybe_gc()
00270 {
00271     static int n_partial_gcs = 0;
00272 
00273     if (GC_should_collect()) {
00274         if (!GC_incremental) {
00275             GC_gcollect_inner();
00276             n_partial_gcs = 0;
00277             return;
00278         } else {
00279 #        ifdef PARALLEL_MARK
00280            GC_wait_for_reclaim();
00281 #        endif
00282          if (GC_need_full_gc || n_partial_gcs >= GC_full_freq) {
00283 #          ifdef CONDPRINT
00284              if (GC_print_stats) {
00285                GC_printf2(
00286                  "***>Full mark for collection %lu after %ld allocd bytes\n",
00287                 (unsigned long) GC_gc_no+1,
00288                 (long)WORDS_TO_BYTES(GC_words_allocd));
00289              }
00290 #           endif
00291            GC_promote_black_lists();
00292            (void)GC_reclaim_all((GC_stop_func)0, TRUE);
00293            GC_clear_marks();
00294             n_partial_gcs = 0;
00295            GC_notify_full_gc();
00296            GC_is_full_gc = TRUE;
00297           } else {
00298             n_partial_gcs++;
00299           }
00300        }
00301         /* We try to mark with the world stopped.       */
00302         /* If we run out of time, this turns into       */
00303         /* incremental marking.                  */
00304 #      ifndef NO_CLOCK
00305           if (GC_time_limit != GC_TIME_UNLIMITED) { GET_TIME(GC_start_time); }
00306 #      endif
00307         if (GC_stopped_mark(GC_time_limit == GC_TIME_UNLIMITED? 
00308                          GC_never_stop_func : GC_timeout_stop_func)) {
00309 #           ifdef SAVE_CALL_CHAIN_IN_GC
00310                 GC_save_callers(GC_last_stack);
00311 #           endif
00312             GC_finish_collection();
00313         } else {
00314            if (!GC_is_full_gc) {
00315               /* Count this as the first attempt */
00316                GC_n_attempts++;
00317            }
00318        }
00319     }
00320 }
00321 
00322 /* PLTSCHEME: notification callback for starting/ending a GC */
00323 GC_collect_start_callback_Proc GC_collect_start_callback = NULL;
00324 GC_collect_end_callback_Proc GC_collect_end_callback = NULL;
00325 GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) {
00326   GC_collect_start_callback_Proc old;
00327   old = GC_collect_start_callback;
00328   GC_collect_start_callback = func;
00329   return old;
00330 }
00331 GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc func) {
00332   GC_collect_end_callback_Proc old;
00333   old = GC_collect_end_callback;
00334   GC_collect_end_callback = func;
00335   return old;
00336 }
00337 
00338 /*
00339  * Stop the world garbage collection.  Assumes lock held, signals disabled.
00340  * If stop_func is not GC_never_stop_func, then abort if stop_func returns TRUE.
00341  * Return TRUE if we successfully completed the collection.
00342  */
00343 GC_bool GC_try_to_collect_inner(stop_func)
00344 GC_stop_func stop_func;
00345 {
00346 #   ifdef CONDPRINT
00347         CLOCK_TYPE start_time, current_time;
00348 #   endif
00349     if (GC_dont_gc) return FALSE;
00350     /* PLTSCHEME */
00351     if (GC_collect_start_callback)
00352       GC_collect_start_callback();
00353     if (GC_incremental && GC_collection_in_progress()) {
00354 #   ifdef CONDPRINT
00355       if (GC_print_stats) {
00356        GC_printf0(
00357            "GC_try_to_collect_inner: finishing collection in progress\n");
00358       }
00359 #   endif /* CONDPRINT */
00360       /* Just finish collection already in progress.    */
00361        while(GC_collection_in_progress()) {
00362            if (stop_func()) return(FALSE);
00363            GC_collect_a_little_inner(1);
00364        }
00365     }
00366     if (stop_func == GC_never_stop_func) GC_notify_full_gc();
00367 #   ifdef CONDPRINT
00368       if (GC_print_stats) {
00369         if (GC_print_stats) GET_TIME(start_time);
00370        GC_printf2(
00371           "Initiating full world-stop collection %lu after %ld allocd bytes\n",
00372           (unsigned long) GC_gc_no+1,
00373           (long)WORDS_TO_BYTES(GC_words_allocd));
00374       }
00375 #   endif
00376     GC_promote_black_lists();
00377     /* Make sure all blocks have been reclaimed, so sweep routines    */
00378     /* don't see cleared mark bits.                                   */
00379     /* If we're guaranteed to finish, then this is unnecessary.              */
00380     /* In the find_leak case, we have to finish to guarantee that     */
00381     /* previously unmarked objects are not reported as leaks.         */
00382 #       ifdef PARALLEL_MARK
00383            GC_wait_for_reclaim();
00384 #       endif
00385        if ((GC_find_leak || stop_func != GC_never_stop_func)
00386            && !GC_reclaim_all(stop_func, FALSE)) {
00387            /* Aborted.  So far everything is still consistent. */
00388            return(FALSE);
00389        }
00390     GC_invalidate_mark_state();  /* Flush mark stack.   */
00391     GC_clear_marks();
00392 #   ifdef SAVE_CALL_CHAIN_IN_GC
00393         GC_save_callers(GC_last_stack);
00394 #   endif
00395     GC_is_full_gc = TRUE;
00396     if (!GC_stopped_mark(stop_func)) {
00397       if (!GC_incremental) {
00398        /* We're partially done and have no way to complete or use     */
00399        /* current work.  Reestablish invariants as cheaply as         */
00400        /* possible.                                            */
00401        GC_invalidate_mark_state();
00402        GC_unpromote_black_lists();
00403       } /* else we claim the world is already still consistent.  We'll       */
00404         /* finish incrementally.                               */
00405       return(FALSE);
00406     }
00407     GC_finish_collection();
00408 #   if defined(CONDPRINT)
00409       if (GC_print_stats) {
00410         GET_TIME(current_time);
00411         GC_printf1("Complete collection took %lu msecs\n",
00412                    MS_TIME_DIFF(current_time,start_time));
00413       }
00414 #   endif
00415     /* PLTSCHEME */
00416     if (GC_collect_end_callback)
00417       GC_collect_end_callback();
00418     return(TRUE);
00419 }
00420 
00421 
00422 
00423 /*
00424  * Perform n units of garbage collection work.  A unit is intended to touch
00425  * roughly GC_RATE pages.  Every once in a while, we do more than that.
00426  * This needs to be a fairly large number with our current incremental
00427  * GC strategy, since otherwise we allocate too much during GC, and the
00428  * cleanup gets expensive.
00429  */
00430 # define GC_RATE 10 
00431 # define MAX_PRIOR_ATTEMPTS 1
00432        /* Maximum number of prior attempts at world stop marking      */
00433        /* A value of 1 means that we finish the second time, no matter */
00434        /* how long it takes.  Doesn't count the initial root scan     */
00435        /* for a full GC.                                       */
00436 
00437 int GC_deficit = 0;  /* The number of extra calls to GC_mark_some     */
00438                      /* that we have made.                            */
00439 
00440 void GC_collect_a_little_inner(n)
00441 int n;
00442 {
00443     register int i;
00444     
00445     if (GC_dont_gc) return;
00446     if (GC_incremental && GC_collection_in_progress()) {
00447        for (i = GC_deficit; i < GC_RATE*n; i++) {
00448            if (GC_mark_some((ptr_t)0)) {
00449                /* Need to finish a collection */
00450 #             ifdef SAVE_CALL_CHAIN_IN_GC
00451                   GC_save_callers(GC_last_stack);
00452 #             endif
00453 #             ifdef PARALLEL_MARK
00454                   GC_wait_for_reclaim();
00455 #             endif
00456               if (GC_n_attempts < MAX_PRIOR_ATTEMPTS
00457                   && GC_time_limit != GC_TIME_UNLIMITED) {
00458                 GET_TIME(GC_start_time);
00459                 if (!GC_stopped_mark(GC_timeout_stop_func)) {
00460                   GC_n_attempts++;
00461                   break;
00462                 }
00463               } else {
00464                 (void)GC_stopped_mark(GC_never_stop_func);
00465               }
00466                GC_finish_collection();
00467                break;
00468            }
00469        }
00470        if (GC_deficit > 0) GC_deficit -= GC_RATE*n;
00471        if (GC_deficit < 0) GC_deficit = 0;
00472     } else {
00473         GC_maybe_gc();
00474     }
00475 }
00476 
00477 int GC_collect_a_little GC_PROTO(())
00478 {
00479     int result;
00480     DCL_LOCK_STATE;
00481 
00482     DISABLE_SIGNALS();
00483     LOCK();
00484     GC_collect_a_little_inner(1);
00485     result = (int)GC_collection_in_progress();
00486     UNLOCK();
00487     ENABLE_SIGNALS();
00488     if (!result && GC_debugging_started) GC_print_all_smashed();
00489     return(result);
00490 }
00491 
00492 /*
00493  * Assumes lock is held, signals are disabled.
00494  * We stop the world.
00495  * If stop_func() ever returns TRUE, we may fail and return FALSE.
00496  * Increment GC_gc_no if we succeed.
00497  */
00498 GC_bool GC_stopped_mark(stop_func)
00499 GC_stop_func stop_func;
00500 {
00501     register int i;
00502     int dummy;
00503 #   if defined(PRINTTIMES) || defined(CONDPRINT)
00504        CLOCK_TYPE start_time, current_time;
00505 #   endif
00506        
00507 #   ifdef PRINTTIMES
00508        GET_TIME(start_time);
00509 #   endif
00510 #   if defined(CONDPRINT) && !defined(PRINTTIMES)
00511        if (GC_print_stats) GET_TIME(start_time);
00512 #   endif
00513 #   if defined(REGISTER_LIBRARIES_EARLY)
00514         GC_cond_register_dynamic_libraries();
00515 #   endif
00516     STOP_WORLD();
00517     IF_THREADS(GC_world_stopped = TRUE);
00518 #   ifdef CONDPRINT
00519       if (GC_print_stats) {
00520        GC_printf1("--> Marking for collection %lu ",
00521                   (unsigned long) GC_gc_no + 1);
00522        GC_printf2("after %lu allocd bytes + %lu wasted bytes\n",
00523                  (unsigned long) WORDS_TO_BYTES(GC_words_allocd),
00524                  (unsigned long) WORDS_TO_BYTES(GC_words_wasted));
00525       }
00526 #   endif
00527 #   ifdef MAKE_BACK_GRAPH
00528       if (GC_print_back_height) {
00529         GC_build_back_graph();
00530       }
00531 #   endif
00532 
00533     /* Mark from all roots.  */
00534         /* Minimize junk left in my registers and on the stack */
00535             GC_clear_a_few_frames();
00536             GC_noop(0,0,0,0,0,0);
00537        GC_initiate_gc();
00538        for(i = 0;;i++) {
00539            if ((*stop_func)()) {
00540 #                 ifdef CONDPRINT
00541                     if (GC_print_stats) {
00542                      GC_printf0("Abandoned stopped marking after ");
00543                      GC_printf1("%lu iterations\n",
00544                                (unsigned long)i);
00545                     }
00546 #                 endif
00547                   GC_deficit = i; /* Give the mutator a chance. */
00548                     IF_THREADS(GC_world_stopped = FALSE);
00549                    START_WORLD();
00550                    return(FALSE);
00551            }
00552            if (GC_mark_some((ptr_t)(&dummy))) break;
00553        }
00554        
00555     GC_gc_no++;
00556 #   ifdef PRINTSTATS
00557       GC_printf2("Collection %lu reclaimed %ld bytes",
00558                 (unsigned long) GC_gc_no - 1,
00559                 (long)WORDS_TO_BYTES(GC_mem_found));
00560 #   else
00561 #     ifdef CONDPRINT
00562         if (GC_print_stats) {
00563          GC_printf1("Collection %lu finished", (unsigned long) GC_gc_no - 1);
00564        }
00565 #     endif
00566 #   endif /* !PRINTSTATS */
00567 #   ifdef CONDPRINT
00568       if (GC_print_stats) {
00569         GC_printf1(" ---> heapsize = %lu bytes\n",
00570                   (unsigned long) GC_heapsize);
00571         /* Printf arguments may be pushed in funny places.  Clear the */
00572         /* space.                                              */
00573         GC_printf0("");
00574       }
00575 #   endif  /* CONDPRINT  */
00576 
00577     /* Check all debugged objects for consistency */
00578         if (GC_debugging_started) {
00579             (*GC_check_heap)();
00580         }
00581     
00582     IF_THREADS(GC_world_stopped = FALSE);
00583     START_WORLD();
00584 #   ifdef PRINTTIMES
00585        GET_TIME(current_time);
00586        GC_printf1("World-stopped marking took %lu msecs\n",
00587                   MS_TIME_DIFF(current_time,start_time));
00588 #   else
00589 #     ifdef CONDPRINT
00590        if (GC_print_stats) {
00591          GET_TIME(current_time);
00592          GC_printf1("World-stopped marking took %lu msecs\n",
00593                     MS_TIME_DIFF(current_time,start_time));
00594        }
00595 #     endif
00596 #   endif
00597     return(TRUE);
00598 }
00599 
00600 /* Set all mark bits for the free list whose first entry is q  */
00601 #ifdef __STDC__
00602   void GC_set_fl_marks(ptr_t q)
00603 #else
00604   void GC_set_fl_marks(q)
00605   ptr_t q;
00606 #endif
00607 {
00608    ptr_t p;
00609    struct hblk * h, * last_h = 0;
00610    hdr *hhdr;
00611    int word_no;
00612 
00613    for (p = q; p != 0; p = obj_link(p)){
00614        h = HBLKPTR(p);
00615        if (h != last_h) {
00616          last_h = h; 
00617          hhdr = HDR(h);
00618        }
00619        word_no = (((word *)p) - ((word *)h));
00620        set_mark_bit_from_hdr(hhdr, word_no);
00621    }
00622 }
00623 
00624 /* Clear all mark bits for the free list whose first entry is q       */
00625 /* Decrement GC_mem_found by number of words on free list.     */
00626 #ifdef __STDC__
00627   void GC_clear_fl_marks(ptr_t q)
00628 #else
00629   void GC_clear_fl_marks(q)
00630   ptr_t q;
00631 #endif
00632 {
00633    ptr_t p;
00634    struct hblk * h, * last_h = 0;
00635    hdr *hhdr;
00636    int word_no;
00637 
00638    for (p = q; p != 0; p = obj_link(p)){
00639        h = HBLKPTR(p);
00640        if (h != last_h) {
00641          last_h = h; 
00642          hhdr = HDR(h);
00643        }
00644        word_no = (((word *)p) - ((word *)h));
00645        clear_mark_bit_from_hdr(hhdr, word_no);
00646 #      ifdef GATHERSTATS
00647            GC_mem_found -= hhdr -> hb_sz;
00648 #      endif
00649    }
00650 }
00651 
00652 /* Finish up a collection.  Assumes lock is held, signals are disabled,      */
00653 /* but the world is otherwise running.                                */
00654 void GC_finish_collection()
00655 {
00656 #   ifdef PRINTTIMES
00657        CLOCK_TYPE start_time;
00658        CLOCK_TYPE finalize_time;
00659        CLOCK_TYPE done_time;
00660        
00661        GET_TIME(start_time);
00662        finalize_time = start_time;
00663 #   endif
00664 
00665 #   ifdef GATHERSTATS
00666         GC_mem_found = 0;
00667 #   endif
00668 #   if defined(LINUX) && defined(__ELF__) && !defined(SMALL_CONFIG)
00669        if (getenv("GC_PRINT_ADDRESS_MAP") != 0) {
00670          GC_print_address_map();
00671        }
00672 #   endif
00673     COND_DUMP;
00674     if (GC_find_leak) {
00675       /* Mark all objects on the free list.  All objects should be */
00676       /* marked when we're done.                           */
00677        {
00678          register word size;              /* current object size             */
00679          int kind;
00680          ptr_t q;
00681 
00682          for (kind = 0; kind < GC_n_kinds; kind++) {
00683            for (size = 1; size <= MAXOBJSZ; size++) {
00684              q = GC_obj_kinds[kind].ok_freelist[size];
00685              if (q != 0) GC_set_fl_marks(q);
00686            }
00687          }
00688        }
00689        GC_start_reclaim(TRUE);
00690          /* The above just checks; it doesn't really reclaim anything. */
00691     }
00692 
00693     GC_finalize();
00694 #   ifdef STUBBORN_ALLOC
00695       GC_clean_changing_list();
00696 #   endif
00697 
00698 #   ifdef PRINTTIMES
00699       GET_TIME(finalize_time);
00700 #   endif
00701 
00702     if (GC_print_back_height) {
00703 #     ifdef MAKE_BACK_GRAPH
00704        GC_traverse_back_graph();
00705 #     else
00706 #      ifndef SMALL_CONFIG
00707          GC_err_printf0("Back height not available: "
00708                        "Rebuild collector with -DMAKE_BACK_GRAPH\n");
00709 #      endif
00710 #     endif
00711     }
00712 
00713     /* Clear free list mark bits, in case they got accidentally marked   */
00714     /* (or GC_find_leak is set and they were intentionally marked).    */
00715     /* Also subtract memory remaining from GC_mem_found count.           */
00716     /* Note that composite objects on free list are cleared.             */
00717     /* Thus accidentally marking a free list is not a problem;  only     */
00718     /* objects on the list itself will be marked, and that's fixed here. */
00719       {
00720        register word size;         /* current object size             */
00721        register ptr_t q;    /* pointer to current object       */
00722        int kind;
00723 
00724        for (kind = 0; kind < GC_n_kinds; kind++) {
00725          for (size = 1; size <= MAXOBJSZ; size++) {
00726            q = GC_obj_kinds[kind].ok_freelist[size];
00727            if (q != 0) GC_clear_fl_marks(q);
00728          }
00729        }
00730       }
00731 
00732 
00733 #   ifdef PRINTSTATS
00734        GC_printf1("Bytes recovered before sweep - f.l. count = %ld\n",
00735                  (long)WORDS_TO_BYTES(GC_mem_found));
00736 #   endif
00737     /* Reconstruct free lists to contain everything not marked */
00738         GC_start_reclaim(FALSE);
00739         if (GC_is_full_gc)  {
00740            GC_used_heap_size_after_full = USED_HEAP_SIZE;
00741            GC_need_full_gc = FALSE;
00742        } else {
00743            GC_need_full_gc =
00744                BYTES_TO_WORDS(USED_HEAP_SIZE - GC_used_heap_size_after_full)
00745                > min_words_allocd();
00746        }
00747 
00748 #   ifdef PRINTSTATS
00749        GC_printf2(
00750                 "Immediately reclaimed %ld bytes in heap of size %lu bytes",
00751                  (long)WORDS_TO_BYTES(GC_mem_found),
00752                  (unsigned long)GC_heapsize);
00753 #      ifdef USE_MUNMAP
00754          GC_printf1("(%lu unmapped)", GC_unmapped_bytes);
00755 #      endif
00756        GC_printf2(
00757               "\n%lu (atomic) + %lu (composite) collectable bytes in use\n",
00758                (unsigned long)WORDS_TO_BYTES(GC_atomic_in_use),
00759                (unsigned long)WORDS_TO_BYTES(GC_composite_in_use));
00760 #   endif
00761 
00762       GC_n_attempts = 0;
00763       GC_is_full_gc = FALSE;
00764     /* Reset or increment counters for next cycle */
00765       GC_words_allocd_before_gc += GC_words_allocd;
00766       GC_non_gc_bytes_at_gc = GC_non_gc_bytes;
00767       GC_words_allocd = 0;
00768       GC_words_wasted = 0;
00769       GC_mem_freed = 0;
00770       GC_finalizer_mem_freed = 0;
00771       
00772 #   ifdef USE_MUNMAP
00773       GC_unmap_old();
00774 #   endif
00775 #   ifdef PRINTTIMES
00776        GET_TIME(done_time);
00777        GC_printf2("Finalize + initiate sweep took %lu + %lu msecs\n",
00778                   MS_TIME_DIFF(finalize_time,start_time),
00779                   MS_TIME_DIFF(done_time,finalize_time));
00780 #   endif
00781 }
00782 
00783 /* Externally callable routine to invoke full, stop-world collection */
00784 # if defined(__STDC__) || defined(__cplusplus)
00785     int GC_try_to_collect(GC_stop_func stop_func)
00786 # else
00787     int GC_try_to_collect(stop_func)
00788     GC_stop_func stop_func;
00789 # endif
00790 {
00791     int result;
00792     DCL_LOCK_STATE;
00793     
00794     if (GC_debugging_started) GC_print_all_smashed();
00795     GC_INVOKE_FINALIZERS();
00796     DISABLE_SIGNALS();
00797     LOCK();
00798     ENTER_GC();
00799     if (!GC_is_initialized) GC_init_inner();
00800     /* Minimize junk left in my registers */
00801       GC_noop(0,0,0,0,0,0);
00802     result = (int)GC_try_to_collect_inner(stop_func);
00803     EXIT_GC();
00804     UNLOCK();
00805     ENABLE_SIGNALS();
00806     if(result) {
00807         if (GC_debugging_started) GC_print_all_smashed();
00808         GC_INVOKE_FINALIZERS();
00809     }
00810     return(result);
00811 }
00812 
00813 void GC_gcollect GC_PROTO(())
00814 {
00815     (void)GC_try_to_collect(GC_never_stop_func);
00816     if (GC_have_errors) GC_print_all_errors();
00817 }
00818 
00819 word GC_n_heap_sects = 0;   /* Number of sections currently in heap. */
00820 
00821 /*
00822  * Use the chunk of memory starting at p of size bytes as part of the heap.
00823  * Assumes p is HBLKSIZE aligned, and bytes is a multiple of HBLKSIZE.
00824  */
00825 void GC_add_to_heap(p, bytes)
00826 struct hblk *p;
00827 word bytes;
00828 {
00829     word words;
00830     hdr * phdr;
00831     
00832     if (GC_n_heap_sects >= MAX_HEAP_SECTS) {
00833        ABORT("Too many heap sections: Increase MAXHINCR or MAX_HEAP_SECTS");
00834     }
00835     phdr = GC_install_header(p);
00836     if (0 == phdr) {
00837        /* This is extremely unlikely. Can't add it.  This will        */
00838        /* almost certainly result in a    0 return from the allocator,       */
00839        /* which is entirely appropriate.                       */
00840        return;
00841     }
00842     GC_heap_sects[GC_n_heap_sects].hs_start = (ptr_t)p;
00843     GC_heap_sects[GC_n_heap_sects].hs_bytes = bytes;
00844     GC_n_heap_sects++;
00845     words = BYTES_TO_WORDS(bytes);
00846     phdr -> hb_sz = words;
00847     phdr -> hb_map = (unsigned char *)1;   /* A value != GC_invalid_map      */
00848     phdr -> hb_flags = 0;
00849     GC_freehblk(p);
00850     GC_heapsize += bytes;
00851     if ((ptr_t)p <= (ptr_t)GC_least_plausible_heap_addr
00852         || GC_least_plausible_heap_addr == 0) {
00853         GC_least_plausible_heap_addr = (GC_PTR)((ptr_t)p - sizeof(word));
00854               /* Making it a little smaller than necessary prevents   */
00855               /* us from getting a false hit from the variable */
00856               /* itself.  There's some unintentional reflection       */
00857               /* here.                                         */
00858     }
00859     if ((ptr_t)p + bytes >= (ptr_t)GC_greatest_plausible_heap_addr) {
00860         GC_greatest_plausible_heap_addr = (GC_PTR)((ptr_t)p + bytes);
00861     }
00862 }
00863 
00864 # if !defined(NO_DEBUGGING)
00865 void GC_print_heap_sects()
00866 {
00867     register unsigned i;
00868     
00869     GC_printf1("Total heap size: %lu\n", (unsigned long) GC_heapsize);
00870     for (i = 0; i < GC_n_heap_sects; i++) {
00871         unsigned long start = (unsigned long) GC_heap_sects[i].hs_start;
00872         unsigned long len = (unsigned long) GC_heap_sects[i].hs_bytes;
00873         struct hblk *h;
00874         unsigned nbl = 0;
00875         
00876        GC_printf3("Section %ld from 0x%lx to 0x%lx ", (unsigned long)i,
00877                  start, (unsigned long)(start + len));
00878        for (h = (struct hblk *)start; h < (struct hblk *)(start + len); h++) {
00879            if (GC_is_black_listed(h, HBLKSIZE)) nbl++;
00880        }
00881        GC_printf2("%lu/%lu blacklisted\n", (unsigned long)nbl,
00882                  (unsigned long)(len/HBLKSIZE));
00883     }
00884 }
00885 # endif
00886 
00887 GC_PTR GC_least_plausible_heap_addr = (GC_PTR)ONES;
00888 GC_PTR GC_greatest_plausible_heap_addr = 0;
00889 
00890 ptr_t GC_max(x,y)
00891 ptr_t x, y;
00892 {
00893     return(x > y? x : y);
00894 }
00895 
00896 ptr_t GC_min(x,y)
00897 ptr_t x, y;
00898 {
00899     return(x < y? x : y);
00900 }
00901 
00902 # if defined(__STDC__) || defined(__cplusplus)
00903     void GC_set_max_heap_size(GC_word n)
00904 # else
00905     void GC_set_max_heap_size(n)
00906     GC_word n;
00907 # endif
00908 {
00909     GC_max_heapsize = n;
00910 }
00911 
00912 GC_word GC_max_retries = 0;
00913 
00914 /*
00915  * this explicitly increases the size of the heap.  It is used
00916  * internally, but may also be invoked from GC_expand_hp by the user.
00917  * The argument is in units of HBLKSIZE.
00918  * Tiny values of n are rounded up.
00919  * Returns FALSE on failure.
00920  */
00921 GC_bool GC_expand_hp_inner(n)
00922 word n;
00923 {
00924     word bytes;
00925     struct hblk * space;
00926     word expansion_slop;    /* Number of bytes by which we expect the */
00927                             /* heap to expand soon.                     */
00928 
00929     if (n < MINHINCR) n = MINHINCR;
00930     bytes = n * HBLKSIZE;
00931     /* Make sure bytes is a multiple of GC_page_size */
00932       {
00933        word mask = GC_page_size - 1;
00934        bytes += mask;
00935        bytes &= ~mask;
00936       }
00937     
00938     if (GC_max_heapsize != 0 && GC_heapsize + bytes > GC_max_heapsize) {
00939         /* Exceeded self-imposed limit */
00940         return(FALSE);
00941     }
00942     space = GET_MEM(bytes);
00943     if( space == 0 ) {
00944 #      ifdef CONDPRINT
00945          if (GC_print_stats) {
00946            GC_printf1("Failed to expand heap by %ld bytes\n",
00947                      (unsigned long)bytes);
00948          }
00949 #       endif
00950        return(FALSE);
00951     }
00952 #   ifdef CONDPRINT
00953       if (GC_print_stats) {
00954        GC_printf2("Increasing heap size by %lu after %lu allocated bytes\n",
00955                   (unsigned long)bytes,
00956                   (unsigned long)WORDS_TO_BYTES(GC_words_allocd));
00957 #      ifdef UNDEFINED
00958          GC_printf1("Root size = %lu\n", GC_root_size);
00959          GC_print_block_list(); GC_print_hblkfreelist();
00960          GC_printf0("\n");
00961 #      endif
00962       }
00963 #   endif
00964     expansion_slop = WORDS_TO_BYTES(min_words_allocd()) + 4*MAXHINCR*HBLKSIZE;
00965     if (GC_last_heap_addr == 0 && !((word)space & SIGNB)
00966         || (GC_last_heap_addr != 0 && GC_last_heap_addr < (ptr_t)space)) {
00967         /* Assume the heap is growing up */
00968         GC_greatest_plausible_heap_addr =
00969             (GC_PTR)GC_max((ptr_t)GC_greatest_plausible_heap_addr,
00970                            (ptr_t)space + bytes + expansion_slop);
00971     } else {
00972         /* Heap is growing down */
00973         GC_least_plausible_heap_addr =
00974             (GC_PTR)GC_min((ptr_t)GC_least_plausible_heap_addr,
00975                            (ptr_t)space - expansion_slop);
00976     }
00977 #   if defined(LARGE_CONFIG)
00978       if (((ptr_t)GC_greatest_plausible_heap_addr <= (ptr_t)space + bytes
00979            || (ptr_t)GC_least_plausible_heap_addr >= (ptr_t)space)
00980          && GC_heapsize > 0) {
00981        /* GC_add_to_heap will fix this, but ... */
00982        WARN("Too close to address space limit: blacklisting ineffective\n", 0);
00983       }
00984 #   endif
00985     GC_prev_heap_addr = GC_last_heap_addr;
00986     GC_last_heap_addr = (ptr_t)space;
00987     GC_add_to_heap(space, bytes);
00988     /* Force GC before we are likely to allocate past expansion_slop */
00989       GC_collect_at_heapsize =
00990          GC_heapsize + expansion_slop - 2*MAXHINCR*HBLKSIZE;
00991 #     if defined(LARGE_CONFIG)
00992         if (GC_collect_at_heapsize < GC_heapsize /* wrapped */)
00993          GC_collect_at_heapsize = (word)(-1);
00994 #     endif
00995     return(TRUE);
00996 }
00997 
00998 /* PLTSCHEME: To report out-of-memory in an app- or platform-specific way. */
00999 void (*GC_out_of_memory)(void) = NULL;
01000 
01001 /* Really returns a bool, but it's externally visible, so that's clumsy. */
01002 /* Arguments is in bytes.                                      */
01003 # if defined(__STDC__) || defined(__cplusplus)
01004   int GC_expand_hp(size_t bytes)
01005 # else
01006   int GC_expand_hp(bytes)
01007   size_t bytes;
01008 # endif
01009 {
01010     int result;
01011     DCL_LOCK_STATE;
01012     
01013     DISABLE_SIGNALS();
01014     LOCK();
01015     if (!GC_is_initialized) GC_init_inner();
01016     result = (int)GC_expand_hp_inner(divHBLKSZ((word)bytes));
01017     if (result) GC_requested_heapsize += bytes;
01018     UNLOCK();
01019     ENABLE_SIGNALS();
01020     return(result);
01021 }
01022 
01023 unsigned GC_fail_count = 0;  
01024                      /* How many consecutive GC/expansion failures?   */
01025                      /* Reset by GC_allochblk.                 */
01026 
01027 GC_bool GC_collect_or_expand(needed_blocks, ignore_off_page)
01028 word needed_blocks;
01029 GC_bool ignore_off_page;
01030 {
01031     if (!GC_incremental && !GC_dont_gc &&
01032        ((GC_dont_expand && GC_words_allocd > 0) || GC_should_collect())) {
01033       GC_gcollect_inner();
01034     } else {
01035       word blocks_to_get = GC_heapsize/(HBLKSIZE*GC_free_space_divisor)
01036                         + needed_blocks;
01037       
01038       if (blocks_to_get > MAXHINCR) {
01039           word slop;
01040           
01041          /* Get the minimum required to make it likely that we        */
01042          /* can satisfy the current request in the presence of black- */
01043          /* listing.  This will probably be more than MAXHINCR.       */
01044           if (ignore_off_page) {
01045               slop = 4;
01046           } else {
01047              slop = 2*divHBLKSZ(BL_LIMIT);
01048              if (slop > needed_blocks) slop = needed_blocks;
01049          }
01050           if (needed_blocks + slop > MAXHINCR) {
01051               blocks_to_get = needed_blocks + slop;
01052           } else {
01053               blocks_to_get = MAXHINCR;
01054           }
01055       }
01056       if (!GC_expand_hp_inner(blocks_to_get)
01057         && !GC_expand_hp_inner(needed_blocks)) {
01058        if (GC_fail_count++ < GC_max_retries) {
01059          /* PLTSCHEME: rather not see this message */
01060 #if 0
01061            WARN("Out of Memory!  Trying to continue ...\n", 0);
01062 #endif
01063            GC_gcollect_inner();
01064        } else {
01065            /* PLTSCHEME */
01066            if (GC_out_of_memory)
01067              GC_out_of_memory();
01068 
01069 #          if !defined(AMIGA) || !defined(GC_AMIGA_FASTALLOC)
01070              WARN("Out of Memory!  Returning NIL!\n", 0);
01071 #          endif
01072            return(FALSE);
01073        }
01074       } else {
01075 #        ifdef CONDPRINT
01076             if (GC_fail_count && GC_print_stats) {
01077              GC_printf0("Memory available again ...\n");
01078            }
01079 #        endif
01080       }
01081     }
01082     return(TRUE);
01083 }
01084 
01085 /*
01086  * Make sure the object free list for sz is not empty.
01087  * Return a pointer to the first object on the free list.
01088  * The object MUST BE REMOVED FROM THE FREE LIST BY THE CALLER.
01089  * Assumes we hold the allocator lock and signals are disabled.
01090  *
01091  */
01092 ptr_t GC_allocobj(sz, kind)
01093 word sz;
01094 int kind;
01095 {
01096     ptr_t * flh = &(GC_obj_kinds[kind].ok_freelist[sz]);
01097     GC_bool tried_minor = FALSE;
01098     
01099     if (sz == 0) return(0);
01100 
01101     while (*flh == 0) {
01102       ENTER_GC();
01103       /* Do our share of marking work */
01104         if(TRUE_INCREMENTAL) GC_collect_a_little_inner(1);
01105       /* Sweep blocks for objects of this size */
01106         GC_continue_reclaim(sz, kind);
01107       EXIT_GC();
01108       if (*flh == 0) {
01109         GC_new_hblk(sz, kind);
01110       }
01111       if (*flh == 0) {
01112         ENTER_GC();
01113        if (GC_incremental && GC_time_limit == GC_TIME_UNLIMITED
01114            && ! tried_minor ) {
01115            GC_collect_a_little_inner(1);
01116            tried_minor = TRUE;
01117        } else {
01118           if (!GC_collect_or_expand((word)1,FALSE)) {
01119            EXIT_GC();
01120            return(0);
01121          }
01122        }
01123        EXIT_GC();
01124       }
01125     }
01126     /* Successful allocation; reset failure count.      */
01127     GC_fail_count = 0;
01128     
01129     return(*flh);
01130 }