b8c672693127e47a19f07cb9f12ae1dc011e7941
[sbcl.git] / src / runtime / gencgc.c
1 /*
2  * GENerational Conservative Garbage Collector for SBCL x86
3  */
4
5 /*
6  * This software is part of the SBCL system. See the README file for
7  * more information.
8  *
9  * This software is derived from the CMU CL system, which was
10  * written at Carnegie Mellon University and released into the
11  * public domain. The software is in the public domain and is
12  * provided with absolutely no warranty. See the COPYING and CREDITS
13  * files for more information.
14  */
15
16 /*
17  * For a review of garbage collection techniques (e.g. generational
18  * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
19  * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
20  * had been accepted for _ACM Computing Surveys_ and was available
21  * as a PostScript preprint through
22  *   <http://www.cs.utexas.edu/users/oops/papers.html>
23  * as
24  *   <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
25  */
26
27 #include <stdio.h>
28 #include <signal.h>
29 #include <errno.h>
30 #include <string.h>
31 #include "sbcl.h"
32 #include "runtime.h"
33 #include "os.h"
34 #include "interr.h"
35 #include "globals.h"
36 #include "interrupt.h"
37 #include "validate.h"
38 #include "lispregs.h"
39 #include "arch.h"
40 #include "fixnump.h"
41 #include "gc.h"
42 #include "gc-internal.h"
43 #include "thread.h"
44 #include "genesis/vector.h"
45 #include "genesis/weak-pointer.h"
46 #include "genesis/simple-fun.h"
47 #include "save.h"
48 #include "genesis/hash-table.h"
49
50 /* forward declarations */
51 page_index_t  gc_find_freeish_pages(long *restart_page_ptr, long nbytes,
52                                     int unboxed);
53
54 \f
55 /*
56  * GC parameters
57  */
58
59 /* Generations 0-5 are normal collected generations, 6 is only used as
60  * scratch space by the collector, and should never get collected.
61  */
62 enum {
63     HIGHEST_NORMAL_GENERATION = 5,
64     PSEUDO_STATIC_GENERATION,
65     SCRATCH_GENERATION,
66     NUM_GENERATIONS
67 };
68
69 /* Should we use page protection to help avoid the scavenging of pages
70  * that don't have pointers to younger generations? */
71 boolean enable_page_protection = 1;
72
73 /* Should we unmap a page and re-mmap it to have it zero filled? */
74 #if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__sun)
75 /* comment from cmucl-2.4.8: This can waste a lot of swap on FreeBSD
76  * so don't unmap there.
77  *
78  * The CMU CL comment didn't specify a version, but was probably an
79  * old version of FreeBSD (pre-4.0), so this might no longer be true.
80  * OTOH, if it is true, this behavior might exist on OpenBSD too, so
81  * for now we don't unmap there either. -- WHN 2001-04-07 */
82 /* Apparently this flag is required to be 0 for SunOS/x86, as there
83  * are reports of heap corruption otherwise. */
84 boolean gencgc_unmap_zero = 0;
85 #else
86 boolean gencgc_unmap_zero = 1;
87 #endif
88
89 /* the minimum size (in bytes) for a large object*/
90 unsigned long large_object_size = 4 * PAGE_BYTES;
91
92 \f
93 /*
94  * debugging
95  */
96
97 /* the verbosity level. All non-error messages are disabled at level 0;
98  * and only a few rare messages are printed at level 1. */
99 #ifdef QSHOW
100 boolean gencgc_verbose = 1;
101 #else
102 boolean gencgc_verbose = 0;
103 #endif
104
105 /* FIXME: At some point enable the various error-checking things below
106  * and see what they say. */
107
108 /* We hunt for pointers to old-space, when GCing generations >= verify_gen.
109  * Set verify_gens to HIGHEST_NORMAL_GENERATION + 1 to disable this kind of
110  * check. */
111 generation_index_t verify_gens = HIGHEST_NORMAL_GENERATION + 1;
112
113 /* Should we do a pre-scan verify of generation 0 before it's GCed? */
114 boolean pre_verify_gen_0 = 0;
115
116 /* Should we check for bad pointers after gc_free_heap is called
117  * from Lisp PURIFY? */
118 boolean verify_after_free_heap = 0;
119
120 /* Should we print a note when code objects are found in the dynamic space
121  * during a heap verify? */
122 boolean verify_dynamic_code_check = 0;
123
124 /* Should we check code objects for fixup errors after they are transported? */
125 boolean check_code_fixups = 0;
126
127 /* Should we check that newly allocated regions are zero filled? */
128 boolean gencgc_zero_check = 0;
129
130 /* Should we check that the free space is zero filled? */
131 boolean gencgc_enable_verify_zero_fill = 0;
132
133 /* Should we check that free pages are zero filled during gc_free_heap
134  * called after Lisp PURIFY? */
135 boolean gencgc_zero_check_during_free_heap = 0;
136
137 /* When loading a core, don't do a full scan of the memory for the
138  * memory region boundaries. (Set to true by coreparse.c if the core
139  * contained a pagetable entry).
140  */
141 boolean gencgc_partial_pickup = 0;
142 \f
143 /*
144  * GC structures and variables
145  */
146
147 /* the total bytes allocated. These are seen by Lisp DYNAMIC-USAGE. */
148 unsigned long bytes_allocated = 0;
149 extern unsigned long bytes_consed_between_gcs; /* gc-common.c */
150 unsigned long auto_gc_trigger = 0;
151
152 /* the source and destination generations. These are set before a GC starts
153  * scavenging. */
154 generation_index_t from_space;
155 generation_index_t new_space;
156
157 /* should the GC be conservative on stack. If false (only right before
158  * saving a core), don't scan the stack / mark pages dont_move. */
159 static boolean conservative_stack = 1;
160
161 /* An array of page structures is statically allocated.
162  * This helps quickly map between an address its page structure.
163  * NUM_PAGES is set from the size of the dynamic space. */
164 struct page page_table[NUM_PAGES];
165
166 /* To map addresses to page structures the address of the first page
167  * is needed. */
168 static void *heap_base = NULL;
169
170 #if N_WORD_BITS == 32
171  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
172 #elif N_WORD_BITS == 64
173  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
174 #endif
175
176 /* Calculate the start address for the given page number. */
177 inline void *
178 page_address(page_index_t page_num)
179 {
180     return (heap_base + (page_num * PAGE_BYTES));
181 }
182
183 /* Find the page index within the page_table for the given
184  * address. Return -1 on failure. */
185 inline page_index_t
186 find_page_index(void *addr)
187 {
188     page_index_t index = addr-heap_base;
189
190     if (index >= 0) {
191         index = ((unsigned long)index)/PAGE_BYTES;
192         if (index < NUM_PAGES)
193             return (index);
194     }
195
196     return (-1);
197 }
198
199 /* a structure to hold the state of a generation */
200 struct generation {
201
202     /* the first page that gc_alloc() checks on its next call */
203     page_index_t alloc_start_page;
204
205     /* the first page that gc_alloc_unboxed() checks on its next call */
206     page_index_t alloc_unboxed_start_page;
207
208     /* the first page that gc_alloc_large (boxed) considers on its next
209      * call. (Although it always allocates after the boxed_region.) */
210     page_index_t alloc_large_start_page;
211
212     /* the first page that gc_alloc_large (unboxed) considers on its
213      * next call. (Although it always allocates after the
214      * current_unboxed_region.) */
215     page_index_t alloc_large_unboxed_start_page;
216
217     /* the bytes allocated to this generation */
218     long bytes_allocated;
219
220     /* the number of bytes at which to trigger a GC */
221     long gc_trigger;
222
223     /* to calculate a new level for gc_trigger */
224     long bytes_consed_between_gc;
225
226     /* the number of GCs since the last raise */
227     int num_gc;
228
229     /* the average age after which a GC will raise objects to the
230      * next generation */
231     int trigger_age;
232
233     /* the cumulative sum of the bytes allocated to this generation. It is
234      * cleared after a GC on this generations, and update before new
235      * objects are added from a GC of a younger generation. Dividing by
236      * the bytes_allocated will give the average age of the memory in
237      * this generation since its last GC. */
238     long cum_sum_bytes_allocated;
239
240     /* a minimum average memory age before a GC will occur helps
241      * prevent a GC when a large number of new live objects have been
242      * added, in which case a GC could be a waste of time */
243     double min_av_mem_age;
244 };
245
246 /* an array of generation structures. There needs to be one more
247  * generation structure than actual generations as the oldest
248  * generation is temporarily raised then lowered. */
249 struct generation generations[NUM_GENERATIONS];
250
251 /* the oldest generation that is will currently be GCed by default.
252  * Valid values are: 0, 1, ... HIGHEST_NORMAL_GENERATION
253  *
254  * The default of HIGHEST_NORMAL_GENERATION enables GC on all generations.
255  *
256  * Setting this to 0 effectively disables the generational nature of
257  * the GC. In some applications generational GC may not be useful
258  * because there are no long-lived objects.
259  *
260  * An intermediate value could be handy after moving long-lived data
261  * into an older generation so an unnecessary GC of this long-lived
262  * data can be avoided. */
263 generation_index_t gencgc_oldest_gen_to_gc = HIGHEST_NORMAL_GENERATION;
264
265 /* The maximum free page in the heap is maintained and used to update
266  * ALLOCATION_POINTER which is used by the room function to limit its
267  * search of the heap. XX Gencgc obviously needs to be better
268  * integrated with the Lisp code. */
269 page_index_t last_free_page;
270 \f
271 /* This lock is to prevent multiple threads from simultaneously
272  * allocating new regions which overlap each other.  Note that the
273  * majority of GC is single-threaded, but alloc() may be called from
274  * >1 thread at a time and must be thread-safe.  This lock must be
275  * seized before all accesses to generations[] or to parts of
276  * page_table[] that other threads may want to see */
277
278 #ifdef LISP_FEATURE_SB_THREAD
279 static pthread_mutex_t free_pages_lock = PTHREAD_MUTEX_INITIALIZER;
280 #endif
281
282 \f
283 /*
284  * miscellaneous heap functions
285  */
286
287 /* Count the number of pages which are write-protected within the
288  * given generation. */
289 static long
290 count_write_protect_generation_pages(generation_index_t generation)
291 {
292     page_index_t i;
293     long count = 0;
294
295     for (i = 0; i < last_free_page; i++)
296         if ((page_table[i].allocated != FREE_PAGE_FLAG)
297             && (page_table[i].gen == generation)
298             && (page_table[i].write_protected == 1))
299             count++;
300     return count;
301 }
302
303 /* Count the number of pages within the given generation. */
304 static long
305 count_generation_pages(generation_index_t generation)
306 {
307     page_index_t i;
308     long count = 0;
309
310     for (i = 0; i < last_free_page; i++)
311         if ((page_table[i].allocated != 0)
312             && (page_table[i].gen == generation))
313             count++;
314     return count;
315 }
316
317 #ifdef QSHOW
318 static long
319 count_dont_move_pages(void)
320 {
321     page_index_t i;
322     long count = 0;
323     for (i = 0; i < last_free_page; i++) {
324         if ((page_table[i].allocated != 0) && (page_table[i].dont_move != 0)) {
325             ++count;
326         }
327     }
328     return count;
329 }
330 #endif /* QSHOW */
331
332 /* Work through the pages and add up the number of bytes used for the
333  * given generation. */
334 static long
335 count_generation_bytes_allocated (generation_index_t gen)
336 {
337     page_index_t i;
338     long result = 0;
339     for (i = 0; i < last_free_page; i++) {
340         if ((page_table[i].allocated != 0) && (page_table[i].gen == gen))
341             result += page_table[i].bytes_used;
342     }
343     return result;
344 }
345
346 /* Return the average age of the memory in a generation. */
347 static double
348 gen_av_mem_age(generation_index_t gen)
349 {
350     if (generations[gen].bytes_allocated == 0)
351         return 0.0;
352
353     return
354         ((double)generations[gen].cum_sum_bytes_allocated)
355         / ((double)generations[gen].bytes_allocated);
356 }
357
358 void fpu_save(int *);           /* defined in x86-assem.S */
359 void fpu_restore(int *);        /* defined in x86-assem.S */
360 /* The verbose argument controls how much to print: 0 for normal
361  * level of detail; 1 for debugging. */
362 static void
363 print_generation_stats(int verbose) /* FIXME: should take FILE argument */
364 {
365     generation_index_t i, gens;
366     int fpu_state[27];
367
368     /* This code uses the FP instructions which may be set up for Lisp
369      * so they need to be saved and reset for C. */
370     fpu_save(fpu_state);
371
372     /* highest generation to print */
373     if (verbose)
374         gens = SCRATCH_GENERATION;
375     else
376         gens = PSEUDO_STATIC_GENERATION;
377
378     /* Print the heap stats. */
379     fprintf(stderr,
380             "   Gen Boxed Unboxed LB   LUB  !move  Alloc  Waste   Trig    WP  GCs Mem-age\n");
381
382     for (i = 0; i < gens; i++) {
383         page_index_t j;
384         long boxed_cnt = 0;
385         long unboxed_cnt = 0;
386         long large_boxed_cnt = 0;
387         long large_unboxed_cnt = 0;
388         long pinned_cnt=0;
389
390         for (j = 0; j < last_free_page; j++)
391             if (page_table[j].gen == i) {
392
393                 /* Count the number of boxed pages within the given
394                  * generation. */
395                 if (page_table[j].allocated & BOXED_PAGE_FLAG) {
396                     if (page_table[j].large_object)
397                         large_boxed_cnt++;
398                     else
399                         boxed_cnt++;
400                 }
401                 if(page_table[j].dont_move) pinned_cnt++;
402                 /* Count the number of unboxed pages within the given
403                  * generation. */
404                 if (page_table[j].allocated & UNBOXED_PAGE_FLAG) {
405                     if (page_table[j].large_object)
406                         large_unboxed_cnt++;
407                     else
408                         unboxed_cnt++;
409                 }
410             }
411
412         gc_assert(generations[i].bytes_allocated
413                   == count_generation_bytes_allocated(i));
414         fprintf(stderr,
415                 "   %1d: %5ld %5ld %5ld %5ld %5ld %8ld %5ld %8ld %4ld %3d %7.4f\n",
416                 i,
417                 boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt,
418                 pinned_cnt,
419                 generations[i].bytes_allocated,
420                 (count_generation_pages(i)*PAGE_BYTES
421                  - generations[i].bytes_allocated),
422                 generations[i].gc_trigger,
423                 count_write_protect_generation_pages(i),
424                 generations[i].num_gc,
425                 gen_av_mem_age(i));
426     }
427     fprintf(stderr,"   Total bytes allocated=%ld\n", bytes_allocated);
428
429     fpu_restore(fpu_state);
430 }
431 \f
432 /*
433  * allocation routines
434  */
435
436 /*
437  * To support quick and inline allocation, regions of memory can be
438  * allocated and then allocated from with just a free pointer and a
439  * check against an end address.
440  *
441  * Since objects can be allocated to spaces with different properties
442  * e.g. boxed/unboxed, generation, ages; there may need to be many
443  * allocation regions.
444  *
445  * Each allocation region may start within a partly used page. Many
446  * features of memory use are noted on a page wise basis, e.g. the
447  * generation; so if a region starts within an existing allocated page
448  * it must be consistent with this page.
449  *
450  * During the scavenging of the newspace, objects will be transported
451  * into an allocation region, and pointers updated to point to this
452  * allocation region. It is possible that these pointers will be
453  * scavenged again before the allocation region is closed, e.g. due to
454  * trans_list which jumps all over the place to cleanup the list. It
455  * is important to be able to determine properties of all objects
456  * pointed to when scavenging, e.g to detect pointers to the oldspace.
457  * Thus it's important that the allocation regions have the correct
458  * properties set when allocated, and not just set when closed. The
459  * region allocation routines return regions with the specified
460  * properties, and grab all the pages, setting their properties
461  * appropriately, except that the amount used is not known.
462  *
463  * These regions are used to support quicker allocation using just a
464  * free pointer. The actual space used by the region is not reflected
465  * in the pages tables until it is closed. It can't be scavenged until
466  * closed.
467  *
468  * When finished with the region it should be closed, which will
469  * update the page tables for the actual space used returning unused
470  * space. Further it may be noted in the new regions which is
471  * necessary when scavenging the newspace.
472  *
473  * Large objects may be allocated directly without an allocation
474  * region, the page tables are updated immediately.
475  *
476  * Unboxed objects don't contain pointers to other objects and so
477  * don't need scavenging. Further they can't contain pointers to
478  * younger generations so WP is not needed. By allocating pages to
479  * unboxed objects the whole page never needs scavenging or
480  * write-protecting. */
481
482 /* We are only using two regions at present. Both are for the current
483  * newspace generation. */
484 struct alloc_region boxed_region;
485 struct alloc_region unboxed_region;
486
487 /* The generation currently being allocated to. */
488 static generation_index_t gc_alloc_generation;
489
490 /* Find a new region with room for at least the given number of bytes.
491  *
492  * It starts looking at the current generation's alloc_start_page. So
493  * may pick up from the previous region if there is enough space. This
494  * keeps the allocation contiguous when scavenging the newspace.
495  *
496  * The alloc_region should have been closed by a call to
497  * gc_alloc_update_page_tables(), and will thus be in an empty state.
498  *
499  * To assist the scavenging functions write-protected pages are not
500  * used. Free pages should not be write-protected.
501  *
502  * It is critical to the conservative GC that the start of regions be
503  * known. To help achieve this only small regions are allocated at a
504  * time.
505  *
506  * During scavenging, pointers may be found to within the current
507  * region and the page generation must be set so that pointers to the
508  * from space can be recognized. Therefore the generation of pages in
509  * the region are set to gc_alloc_generation. To prevent another
510  * allocation call using the same pages, all the pages in the region
511  * are allocated, although they will initially be empty.
512  */
513 static void
514 gc_alloc_new_region(long nbytes, int unboxed, struct alloc_region *alloc_region)
515 {
516     page_index_t first_page;
517     page_index_t last_page;
518     long bytes_found;
519     page_index_t i;
520
521     /*
522     FSHOW((stderr,
523            "/alloc_new_region for %d bytes from gen %d\n",
524            nbytes, gc_alloc_generation));
525     */
526
527     /* Check that the region is in a reset state. */
528     gc_assert((alloc_region->first_page == 0)
529               && (alloc_region->last_page == -1)
530               && (alloc_region->free_pointer == alloc_region->end_addr));
531     thread_mutex_lock(&free_pages_lock);
532     if (unboxed) {
533         first_page =
534             generations[gc_alloc_generation].alloc_unboxed_start_page;
535     } else {
536         first_page =
537             generations[gc_alloc_generation].alloc_start_page;
538     }
539     last_page=gc_find_freeish_pages(&first_page,nbytes,unboxed);
540     bytes_found=(PAGE_BYTES - page_table[first_page].bytes_used)
541             + PAGE_BYTES*(last_page-first_page);
542
543     /* Set up the alloc_region. */
544     alloc_region->first_page = first_page;
545     alloc_region->last_page = last_page;
546     alloc_region->start_addr = page_table[first_page].bytes_used
547         + page_address(first_page);
548     alloc_region->free_pointer = alloc_region->start_addr;
549     alloc_region->end_addr = alloc_region->start_addr + bytes_found;
550
551     /* Set up the pages. */
552
553     /* The first page may have already been in use. */
554     if (page_table[first_page].bytes_used == 0) {
555         if (unboxed)
556             page_table[first_page].allocated = UNBOXED_PAGE_FLAG;
557         else
558             page_table[first_page].allocated = BOXED_PAGE_FLAG;
559         page_table[first_page].gen = gc_alloc_generation;
560         page_table[first_page].large_object = 0;
561         page_table[first_page].first_object_offset = 0;
562     }
563
564     if (unboxed)
565         gc_assert(page_table[first_page].allocated == UNBOXED_PAGE_FLAG);
566     else
567         gc_assert(page_table[first_page].allocated == BOXED_PAGE_FLAG);
568     page_table[first_page].allocated |= OPEN_REGION_PAGE_FLAG;
569
570     gc_assert(page_table[first_page].gen == gc_alloc_generation);
571     gc_assert(page_table[first_page].large_object == 0);
572
573     for (i = first_page+1; i <= last_page; i++) {
574         if (unboxed)
575             page_table[i].allocated = UNBOXED_PAGE_FLAG;
576         else
577             page_table[i].allocated = BOXED_PAGE_FLAG;
578         page_table[i].gen = gc_alloc_generation;
579         page_table[i].large_object = 0;
580         /* This may not be necessary for unboxed regions (think it was
581          * broken before!) */
582         page_table[i].first_object_offset =
583             alloc_region->start_addr - page_address(i);
584         page_table[i].allocated |= OPEN_REGION_PAGE_FLAG ;
585     }
586     /* Bump up last_free_page. */
587     if (last_page+1 > last_free_page) {
588         last_free_page = last_page+1;
589         SetSymbolValue(ALLOCATION_POINTER,
590                        (lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES),
591                        0);
592     }
593     thread_mutex_unlock(&free_pages_lock);
594
595     /* we can do this after releasing free_pages_lock */
596     if (gencgc_zero_check) {
597         long *p;
598         for (p = (long *)alloc_region->start_addr;
599              p < (long *)alloc_region->end_addr; p++) {
600             if (*p != 0) {
601                 /* KLUDGE: It would be nice to use %lx and explicit casts
602                  * (long) in code like this, so that it is less likely to
603                  * break randomly when running on a machine with different
604                  * word sizes. -- WHN 19991129 */
605                 lose("The new region at %x is not zero.\n", p);
606             }
607         }
608     }
609 }
610
611 /* If the record_new_objects flag is 2 then all new regions created
612  * are recorded.
613  *
614  * If it's 1 then then it is only recorded if the first page of the
615  * current region is <= new_areas_ignore_page. This helps avoid
616  * unnecessary recording when doing full scavenge pass.
617  *
618  * The new_object structure holds the page, byte offset, and size of
619  * new regions of objects. Each new area is placed in the array of
620  * these structures pointer to by new_areas. new_areas_index holds the
621  * offset into new_areas.
622  *
623  * If new_area overflows NUM_NEW_AREAS then it stops adding them. The
624  * later code must detect this and handle it, probably by doing a full
625  * scavenge of a generation. */
626 #define NUM_NEW_AREAS 512
627 static int record_new_objects = 0;
628 static page_index_t new_areas_ignore_page;
629 struct new_area {
630     page_index_t page;
631     long  offset;
632     long  size;
633 };
634 static struct new_area (*new_areas)[];
635 static long new_areas_index;
636 long max_new_areas;
637
638 /* Add a new area to new_areas. */
639 static void
640 add_new_area(page_index_t first_page, long offset, long size)
641 {
642     unsigned long new_area_start,c;
643     long i;
644
645     /* Ignore if full. */
646     if (new_areas_index >= NUM_NEW_AREAS)
647         return;
648
649     switch (record_new_objects) {
650     case 0:
651         return;
652     case 1:
653         if (first_page > new_areas_ignore_page)
654             return;
655         break;
656     case 2:
657         break;
658     default:
659         gc_abort();
660     }
661
662     new_area_start = PAGE_BYTES*first_page + offset;
663
664     /* Search backwards for a prior area that this follows from. If
665        found this will save adding a new area. */
666     for (i = new_areas_index-1, c = 0; (i >= 0) && (c < 8); i--, c++) {
667         unsigned long area_end =
668             PAGE_BYTES*((*new_areas)[i].page)
669             + (*new_areas)[i].offset
670             + (*new_areas)[i].size;
671         /*FSHOW((stderr,
672                "/add_new_area S1 %d %d %d %d\n",
673                i, c, new_area_start, area_end));*/
674         if (new_area_start == area_end) {
675             /*FSHOW((stderr,
676                    "/adding to [%d] %d %d %d with %d %d %d:\n",
677                    i,
678                    (*new_areas)[i].page,
679                    (*new_areas)[i].offset,
680                    (*new_areas)[i].size,
681                    first_page,
682                    offset,
683                     size);*/
684             (*new_areas)[i].size += size;
685             return;
686         }
687     }
688
689     (*new_areas)[new_areas_index].page = first_page;
690     (*new_areas)[new_areas_index].offset = offset;
691     (*new_areas)[new_areas_index].size = size;
692     /*FSHOW((stderr,
693            "/new_area %d page %d offset %d size %d\n",
694            new_areas_index, first_page, offset, size));*/
695     new_areas_index++;
696
697     /* Note the max new_areas used. */
698     if (new_areas_index > max_new_areas)
699         max_new_areas = new_areas_index;
700 }
701
702 /* Update the tables for the alloc_region. The region may be added to
703  * the new_areas.
704  *
705  * When done the alloc_region is set up so that the next quick alloc
706  * will fail safely and thus a new region will be allocated. Further
707  * it is safe to try to re-update the page table of this reset
708  * alloc_region. */
709 void
710 gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
711 {
712     int more;
713     page_index_t first_page;
714     page_index_t next_page;
715     int bytes_used;
716     long orig_first_page_bytes_used;
717     long region_size;
718     long byte_cnt;
719
720
721     first_page = alloc_region->first_page;
722
723     /* Catch an unused alloc_region. */
724     if ((first_page == 0) && (alloc_region->last_page == -1))
725         return;
726
727     next_page = first_page+1;
728
729     thread_mutex_lock(&free_pages_lock);
730     if (alloc_region->free_pointer != alloc_region->start_addr) {
731         /* some bytes were allocated in the region */
732         orig_first_page_bytes_used = page_table[first_page].bytes_used;
733
734         gc_assert(alloc_region->start_addr == (page_address(first_page) + page_table[first_page].bytes_used));
735
736         /* All the pages used need to be updated */
737
738         /* Update the first page. */
739
740         /* If the page was free then set up the gen, and
741          * first_object_offset. */
742         if (page_table[first_page].bytes_used == 0)
743             gc_assert(page_table[first_page].first_object_offset == 0);
744         page_table[first_page].allocated &= ~(OPEN_REGION_PAGE_FLAG);
745
746         if (unboxed)
747             gc_assert(page_table[first_page].allocated == UNBOXED_PAGE_FLAG);
748         else
749             gc_assert(page_table[first_page].allocated == BOXED_PAGE_FLAG);
750         gc_assert(page_table[first_page].gen == gc_alloc_generation);
751         gc_assert(page_table[first_page].large_object == 0);
752
753         byte_cnt = 0;
754
755         /* Calculate the number of bytes used in this page. This is not
756          * always the number of new bytes, unless it was free. */
757         more = 0;
758         if ((bytes_used = (alloc_region->free_pointer - page_address(first_page)))>PAGE_BYTES) {
759             bytes_used = PAGE_BYTES;
760             more = 1;
761         }
762         page_table[first_page].bytes_used = bytes_used;
763         byte_cnt += bytes_used;
764
765
766         /* All the rest of the pages should be free. We need to set their
767          * first_object_offset pointer to the start of the region, and set
768          * the bytes_used. */
769         while (more) {
770             page_table[next_page].allocated &= ~(OPEN_REGION_PAGE_FLAG);
771             if (unboxed)
772                 gc_assert(page_table[next_page].allocated==UNBOXED_PAGE_FLAG);
773             else
774                 gc_assert(page_table[next_page].allocated == BOXED_PAGE_FLAG);
775             gc_assert(page_table[next_page].bytes_used == 0);
776             gc_assert(page_table[next_page].gen == gc_alloc_generation);
777             gc_assert(page_table[next_page].large_object == 0);
778
779             gc_assert(page_table[next_page].first_object_offset ==
780                       alloc_region->start_addr - page_address(next_page));
781
782             /* Calculate the number of bytes used in this page. */
783             more = 0;
784             if ((bytes_used = (alloc_region->free_pointer
785                                - page_address(next_page)))>PAGE_BYTES) {
786                 bytes_used = PAGE_BYTES;
787                 more = 1;
788             }
789             page_table[next_page].bytes_used = bytes_used;
790             byte_cnt += bytes_used;
791
792             next_page++;
793         }
794
795         region_size = alloc_region->free_pointer - alloc_region->start_addr;
796         bytes_allocated += region_size;
797         generations[gc_alloc_generation].bytes_allocated += region_size;
798
799         gc_assert((byte_cnt- orig_first_page_bytes_used) == region_size);
800
801         /* Set the generations alloc restart page to the last page of
802          * the region. */
803         if (unboxed)
804             generations[gc_alloc_generation].alloc_unboxed_start_page =
805                 next_page-1;
806         else
807             generations[gc_alloc_generation].alloc_start_page = next_page-1;
808
809         /* Add the region to the new_areas if requested. */
810         if (!unboxed)
811             add_new_area(first_page,orig_first_page_bytes_used, region_size);
812
813         /*
814         FSHOW((stderr,
815                "/gc_alloc_update_page_tables update %d bytes to gen %d\n",
816                region_size,
817                gc_alloc_generation));
818         */
819     } else {
820         /* There are no bytes allocated. Unallocate the first_page if
821          * there are 0 bytes_used. */
822         page_table[first_page].allocated &= ~(OPEN_REGION_PAGE_FLAG);
823         if (page_table[first_page].bytes_used == 0)
824             page_table[first_page].allocated = FREE_PAGE_FLAG;
825     }
826
827     /* Unallocate any unused pages. */
828     while (next_page <= alloc_region->last_page) {
829         gc_assert(page_table[next_page].bytes_used == 0);
830         page_table[next_page].allocated = FREE_PAGE_FLAG;
831         next_page++;
832     }
833     thread_mutex_unlock(&free_pages_lock);
834     /* alloc_region is per-thread, we're ok to do this unlocked */
835     gc_set_region_empty(alloc_region);
836 }
837
838 static inline void *gc_quick_alloc(long nbytes);
839
840 /* Allocate a possibly large object. */
841 void *
842 gc_alloc_large(long nbytes, int unboxed, struct alloc_region *alloc_region)
843 {
844     page_index_t first_page;
845     page_index_t last_page;
846     int orig_first_page_bytes_used;
847     long byte_cnt;
848     int more;
849     long bytes_used;
850     page_index_t next_page;
851
852     thread_mutex_lock(&free_pages_lock);
853
854     if (unboxed) {
855         first_page =
856             generations[gc_alloc_generation].alloc_large_unboxed_start_page;
857     } else {
858         first_page = generations[gc_alloc_generation].alloc_large_start_page;
859     }
860     if (first_page <= alloc_region->last_page) {
861         first_page = alloc_region->last_page+1;
862     }
863
864     last_page=gc_find_freeish_pages(&first_page,nbytes,unboxed);
865
866     gc_assert(first_page > alloc_region->last_page);
867     if (unboxed)
868         generations[gc_alloc_generation].alloc_large_unboxed_start_page =
869             last_page;
870     else
871         generations[gc_alloc_generation].alloc_large_start_page = last_page;
872
873     /* Set up the pages. */
874     orig_first_page_bytes_used = page_table[first_page].bytes_used;
875
876     /* If the first page was free then set up the gen, and
877      * first_object_offset. */
878     if (page_table[first_page].bytes_used == 0) {
879         if (unboxed)
880             page_table[first_page].allocated = UNBOXED_PAGE_FLAG;
881         else
882             page_table[first_page].allocated = BOXED_PAGE_FLAG;
883         page_table[first_page].gen = gc_alloc_generation;
884         page_table[first_page].first_object_offset = 0;
885         page_table[first_page].large_object = 1;
886     }
887
888     if (unboxed)
889         gc_assert(page_table[first_page].allocated == UNBOXED_PAGE_FLAG);
890     else
891         gc_assert(page_table[first_page].allocated == BOXED_PAGE_FLAG);
892     gc_assert(page_table[first_page].gen == gc_alloc_generation);
893     gc_assert(page_table[first_page].large_object == 1);
894
895     byte_cnt = 0;
896
897     /* Calc. the number of bytes used in this page. This is not
898      * always the number of new bytes, unless it was free. */
899     more = 0;
900     if ((bytes_used = nbytes+orig_first_page_bytes_used) > PAGE_BYTES) {
901         bytes_used = PAGE_BYTES;
902         more = 1;
903     }
904     page_table[first_page].bytes_used = bytes_used;
905     byte_cnt += bytes_used;
906
907     next_page = first_page+1;
908
909     /* All the rest of the pages should be free. We need to set their
910      * first_object_offset pointer to the start of the region, and
911      * set the bytes_used. */
912     while (more) {
913         gc_assert(page_table[next_page].allocated == FREE_PAGE_FLAG);
914         gc_assert(page_table[next_page].bytes_used == 0);
915         if (unboxed)
916             page_table[next_page].allocated = UNBOXED_PAGE_FLAG;
917         else
918             page_table[next_page].allocated = BOXED_PAGE_FLAG;
919         page_table[next_page].gen = gc_alloc_generation;
920         page_table[next_page].large_object = 1;
921
922         page_table[next_page].first_object_offset =
923             orig_first_page_bytes_used - PAGE_BYTES*(next_page-first_page);
924
925         /* Calculate the number of bytes used in this page. */
926         more = 0;
927         if ((bytes_used=(nbytes+orig_first_page_bytes_used)-byte_cnt) > PAGE_BYTES) {
928             bytes_used = PAGE_BYTES;
929             more = 1;
930         }
931         page_table[next_page].bytes_used = bytes_used;
932         page_table[next_page].write_protected=0;
933         page_table[next_page].dont_move=0;
934         byte_cnt += bytes_used;
935         next_page++;
936     }
937
938     gc_assert((byte_cnt-orig_first_page_bytes_used) == nbytes);
939
940     bytes_allocated += nbytes;
941     generations[gc_alloc_generation].bytes_allocated += nbytes;
942
943     /* Add the region to the new_areas if requested. */
944     if (!unboxed)
945         add_new_area(first_page,orig_first_page_bytes_used,nbytes);
946
947     /* Bump up last_free_page */
948     if (last_page+1 > last_free_page) {
949         last_free_page = last_page+1;
950         SetSymbolValue(ALLOCATION_POINTER,
951                        (lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES),0);
952     }
953     thread_mutex_unlock(&free_pages_lock);
954
955     return((void *)(page_address(first_page)+orig_first_page_bytes_used));
956 }
957
958 static page_index_t gencgc_alloc_start_page = -1;
959
960 page_index_t
961 gc_find_freeish_pages(page_index_t *restart_page_ptr, long nbytes, int unboxed)
962 {
963     page_index_t first_page;
964     page_index_t last_page;
965     long region_size;
966     page_index_t restart_page=*restart_page_ptr;
967     long bytes_found;
968     long num_pages;
969     int large_p=(nbytes>=large_object_size);
970     /* FIXME: assert(free_pages_lock is held); */
971
972     /* Search for a contiguous free space of at least nbytes. If it's
973      * a large object then align it on a page boundary by searching
974      * for a free page. */
975
976     if (gencgc_alloc_start_page != -1) {
977         restart_page = gencgc_alloc_start_page;
978     }
979
980     do {
981         first_page = restart_page;
982         if (large_p)
983             while ((first_page < NUM_PAGES)
984                    && (page_table[first_page].allocated != FREE_PAGE_FLAG))
985                 first_page++;
986         else
987             while (first_page < NUM_PAGES) {
988                 if(page_table[first_page].allocated == FREE_PAGE_FLAG)
989                     break;
990                 if((page_table[first_page].allocated ==
991                     (unboxed ? UNBOXED_PAGE_FLAG : BOXED_PAGE_FLAG)) &&
992                    (page_table[first_page].large_object == 0) &&
993                    (page_table[first_page].gen == gc_alloc_generation) &&
994                    (page_table[first_page].bytes_used < (PAGE_BYTES-32)) &&
995                    (page_table[first_page].write_protected == 0) &&
996                    (page_table[first_page].dont_move == 0)) {
997                     break;
998                 }
999                 first_page++;
1000             }
1001
1002         if (first_page >= NUM_PAGES) {
1003             fprintf(stderr,
1004                     "Argh! gc_find_free_space failed (first_page), nbytes=%ld.\n",
1005                     nbytes);
1006             print_generation_stats(1);
1007             lose("\n");
1008         }
1009
1010         gc_assert(page_table[first_page].write_protected == 0);
1011
1012         last_page = first_page;
1013         bytes_found = PAGE_BYTES - page_table[first_page].bytes_used;
1014         num_pages = 1;
1015         while (((bytes_found < nbytes)
1016                 || (!large_p && (num_pages < 2)))
1017                && (last_page < (NUM_PAGES-1))
1018                && (page_table[last_page+1].allocated == FREE_PAGE_FLAG)) {
1019             last_page++;
1020             num_pages++;
1021             bytes_found += PAGE_BYTES;
1022             gc_assert(page_table[last_page].write_protected == 0);
1023         }
1024
1025         region_size = (PAGE_BYTES - page_table[first_page].bytes_used)
1026             + PAGE_BYTES*(last_page-first_page);
1027
1028         gc_assert(bytes_found == region_size);
1029         restart_page = last_page + 1;
1030     } while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
1031
1032     /* Check for a failure */
1033     if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
1034         fprintf(stderr,
1035                 "Argh! gc_find_freeish_pages failed (restart_page), nbytes=%ld.\n",
1036                 nbytes);
1037         print_generation_stats(1);
1038         lose("\n");
1039     }
1040     *restart_page_ptr=first_page;
1041
1042     return last_page;
1043 }
1044
1045 /* Allocate bytes.  All the rest of the special-purpose allocation
1046  * functions will eventually call this  */
1047
1048 void *
1049 gc_alloc_with_region(long nbytes,int unboxed_p, struct alloc_region *my_region,
1050                      int quick_p)
1051 {
1052     void *new_free_pointer;
1053
1054     if(nbytes>=large_object_size)
1055         return gc_alloc_large(nbytes,unboxed_p,my_region);
1056
1057     /* Check whether there is room in the current alloc region. */
1058     new_free_pointer = my_region->free_pointer + nbytes;
1059
1060     /* fprintf(stderr, "alloc %d bytes from %p to %p\n", nbytes,
1061        my_region->free_pointer, new_free_pointer); */
1062
1063     if (new_free_pointer <= my_region->end_addr) {
1064         /* If so then allocate from the current alloc region. */
1065         void *new_obj = my_region->free_pointer;
1066         my_region->free_pointer = new_free_pointer;
1067
1068         /* Unless a `quick' alloc was requested, check whether the
1069            alloc region is almost empty. */
1070         if (!quick_p &&
1071             (my_region->end_addr - my_region->free_pointer) <= 32) {
1072             /* If so, finished with the current region. */
1073             gc_alloc_update_page_tables(unboxed_p, my_region);
1074             /* Set up a new region. */
1075             gc_alloc_new_region(32 /*bytes*/, unboxed_p, my_region);
1076         }
1077
1078         return((void *)new_obj);
1079     }
1080
1081     /* Else not enough free space in the current region: retry with a
1082      * new region. */
1083
1084     gc_alloc_update_page_tables(unboxed_p, my_region);
1085     gc_alloc_new_region(nbytes, unboxed_p, my_region);
1086     return gc_alloc_with_region(nbytes,unboxed_p,my_region,0);
1087 }
1088
1089 /* these are only used during GC: all allocation from the mutator calls
1090  * alloc() -> gc_alloc_with_region() with the appropriate per-thread
1091  * region */
1092
1093 void *
1094 gc_general_alloc(long nbytes,int unboxed_p,int quick_p)
1095 {
1096     struct alloc_region *my_region =
1097       unboxed_p ? &unboxed_region : &boxed_region;
1098     return gc_alloc_with_region(nbytes,unboxed_p, my_region,quick_p);
1099 }
1100
1101 static inline void *
1102 gc_quick_alloc(long nbytes)
1103 {
1104     return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK);
1105 }
1106
1107 static inline void *
1108 gc_quick_alloc_large(long nbytes)
1109 {
1110     return gc_general_alloc(nbytes,ALLOC_BOXED,ALLOC_QUICK);
1111 }
1112
1113 static inline void *
1114 gc_alloc_unboxed(long nbytes)
1115 {
1116     return gc_general_alloc(nbytes,ALLOC_UNBOXED,0);
1117 }
1118
1119 static inline void *
1120 gc_quick_alloc_unboxed(long nbytes)
1121 {
1122     return gc_general_alloc(nbytes,ALLOC_UNBOXED,ALLOC_QUICK);
1123 }
1124
1125 static inline void *
1126 gc_quick_alloc_large_unboxed(long nbytes)
1127 {
1128     return gc_general_alloc(nbytes,ALLOC_UNBOXED,ALLOC_QUICK);
1129 }
1130 \f
1131 /*
1132  * scavenging/transporting routines derived from gc.c in CMU CL ca. 18b
1133  */
1134
1135 extern long (*scavtab[256])(lispobj *where, lispobj object);
1136 extern lispobj (*transother[256])(lispobj object);
1137 extern long (*sizetab[256])(lispobj *where);
1138
1139 /* Copy a large boxed object. If the object is in a large object
1140  * region then it is simply promoted, else it is copied. If it's large
1141  * enough then it's copied to a large object region.
1142  *
1143  * Vectors may have shrunk. If the object is not copied the space
1144  * needs to be reclaimed, and the page_tables corrected. */
1145 lispobj
1146 copy_large_object(lispobj object, long nwords)
1147 {
1148     int tag;
1149     lispobj *new;
1150     page_index_t first_page;
1151
1152     gc_assert(is_lisp_pointer(object));
1153     gc_assert(from_space_p(object));
1154     gc_assert((nwords & 0x01) == 0);
1155
1156
1157     /* Check whether it's in a large object region. */
1158     first_page = find_page_index((void *)object);
1159     gc_assert(first_page >= 0);
1160
1161     if (page_table[first_page].large_object) {
1162
1163         /* Promote the object. */
1164
1165         long remaining_bytes;
1166         page_index_t next_page;
1167         long bytes_freed;
1168         long old_bytes_used;
1169
1170         /* Note: Any page write-protection must be removed, else a
1171          * later scavenge_newspace may incorrectly not scavenge these
1172          * pages. This would not be necessary if they are added to the
1173          * new areas, but let's do it for them all (they'll probably
1174          * be written anyway?). */
1175
1176         gc_assert(page_table[first_page].first_object_offset == 0);
1177
1178         next_page = first_page;
1179         remaining_bytes = nwords*N_WORD_BYTES;
1180         while (remaining_bytes > PAGE_BYTES) {
1181             gc_assert(page_table[next_page].gen == from_space);
1182             gc_assert(page_table[next_page].allocated == BOXED_PAGE_FLAG);
1183             gc_assert(page_table[next_page].large_object);
1184             gc_assert(page_table[next_page].first_object_offset==
1185                       -PAGE_BYTES*(next_page-first_page));
1186             gc_assert(page_table[next_page].bytes_used == PAGE_BYTES);
1187
1188             page_table[next_page].gen = new_space;
1189
1190             /* Remove any write-protection. We should be able to rely
1191              * on the write-protect flag to avoid redundant calls. */
1192             if (page_table[next_page].write_protected) {
1193                 os_protect(page_address(next_page), PAGE_BYTES, OS_VM_PROT_ALL);
1194                 page_table[next_page].write_protected = 0;
1195             }
1196             remaining_bytes -= PAGE_BYTES;
1197             next_page++;
1198         }
1199
1200         /* Now only one page remains, but the object may have shrunk
1201          * so there may be more unused pages which will be freed. */
1202
1203         /* The object may have shrunk but shouldn't have grown. */
1204         gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
1205
1206         page_table[next_page].gen = new_space;
1207         gc_assert(page_table[next_page].allocated == BOXED_PAGE_FLAG);
1208
1209         /* Adjust the bytes_used. */
1210         old_bytes_used = page_table[next_page].bytes_used;
1211         page_table[next_page].bytes_used = remaining_bytes;
1212
1213         bytes_freed = old_bytes_used - remaining_bytes;
1214
1215         /* Free any remaining pages; needs care. */
1216         next_page++;
1217         while ((old_bytes_used == PAGE_BYTES) &&
1218                (page_table[next_page].gen == from_space) &&
1219                (page_table[next_page].allocated == BOXED_PAGE_FLAG) &&
1220                page_table[next_page].large_object &&
1221                (page_table[next_page].first_object_offset ==
1222                 -(next_page - first_page)*PAGE_BYTES)) {
1223             /* Checks out OK, free the page. Don't need to bother zeroing
1224              * pages as this should have been done before shrinking the
1225              * object. These pages shouldn't be write-protected as they
1226              * should be zero filled. */
1227             gc_assert(page_table[next_page].write_protected == 0);
1228
1229             old_bytes_used = page_table[next_page].bytes_used;
1230             page_table[next_page].allocated = FREE_PAGE_FLAG;
1231             page_table[next_page].bytes_used = 0;
1232             bytes_freed += old_bytes_used;
1233             next_page++;
1234         }
1235
1236         generations[from_space].bytes_allocated -= N_WORD_BYTES*nwords +
1237           bytes_freed;
1238         generations[new_space].bytes_allocated += N_WORD_BYTES*nwords;
1239         bytes_allocated -= bytes_freed;
1240
1241         /* Add the region to the new_areas if requested. */
1242         add_new_area(first_page,0,nwords*N_WORD_BYTES);
1243
1244         return(object);
1245     } else {
1246         /* Get tag of object. */
1247         tag = lowtag_of(object);
1248
1249         /* Allocate space. */
1250         new = gc_quick_alloc_large(nwords*N_WORD_BYTES);
1251
1252         memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
1253
1254         /* Return Lisp pointer of new object. */
1255         return ((lispobj) new) | tag;
1256     }
1257 }
1258
1259 /* to copy unboxed objects */
1260 lispobj
1261 copy_unboxed_object(lispobj object, long nwords)
1262 {
1263     long tag;
1264     lispobj *new;
1265
1266     gc_assert(is_lisp_pointer(object));
1267     gc_assert(from_space_p(object));
1268     gc_assert((nwords & 0x01) == 0);
1269
1270     /* Get tag of object. */
1271     tag = lowtag_of(object);
1272
1273     /* Allocate space. */
1274     new = gc_quick_alloc_unboxed(nwords*N_WORD_BYTES);
1275
1276     memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
1277
1278     /* Return Lisp pointer of new object. */
1279     return ((lispobj) new) | tag;
1280 }
1281
1282 /* to copy large unboxed objects
1283  *
1284  * If the object is in a large object region then it is simply
1285  * promoted, else it is copied. If it's large enough then it's copied
1286  * to a large object region.
1287  *
1288  * Bignums and vectors may have shrunk. If the object is not copied
1289  * the space needs to be reclaimed, and the page_tables corrected.
1290  *
1291  * KLUDGE: There's a lot of cut-and-paste duplication between this
1292  * function and copy_large_object(..). -- WHN 20000619 */
1293 lispobj
1294 copy_large_unboxed_object(lispobj object, long nwords)
1295 {
1296     int tag;
1297     lispobj *new;
1298     page_index_t first_page;
1299
1300     gc_assert(is_lisp_pointer(object));
1301     gc_assert(from_space_p(object));
1302     gc_assert((nwords & 0x01) == 0);
1303
1304     if ((nwords > 1024*1024) && gencgc_verbose)
1305         FSHOW((stderr, "/copy_large_unboxed_object: %d bytes\n", nwords*N_WORD_BYTES));
1306
1307     /* Check whether it's a large object. */
1308     first_page = find_page_index((void *)object);
1309     gc_assert(first_page >= 0);
1310
1311     if (page_table[first_page].large_object) {
1312         /* Promote the object. Note: Unboxed objects may have been
1313          * allocated to a BOXED region so it may be necessary to
1314          * change the region to UNBOXED. */
1315         long remaining_bytes;
1316         page_index_t next_page;
1317         long bytes_freed;
1318         long old_bytes_used;
1319
1320         gc_assert(page_table[first_page].first_object_offset == 0);
1321
1322         next_page = first_page;
1323         remaining_bytes = nwords*N_WORD_BYTES;
1324         while (remaining_bytes > PAGE_BYTES) {
1325             gc_assert(page_table[next_page].gen == from_space);
1326             gc_assert((page_table[next_page].allocated == UNBOXED_PAGE_FLAG)
1327                       || (page_table[next_page].allocated == BOXED_PAGE_FLAG));
1328             gc_assert(page_table[next_page].large_object);
1329             gc_assert(page_table[next_page].first_object_offset==
1330                       -PAGE_BYTES*(next_page-first_page));
1331             gc_assert(page_table[next_page].bytes_used == PAGE_BYTES);
1332
1333             page_table[next_page].gen = new_space;
1334             page_table[next_page].allocated = UNBOXED_PAGE_FLAG;
1335             remaining_bytes -= PAGE_BYTES;
1336             next_page++;
1337         }
1338
1339         /* Now only one page remains, but the object may have shrunk so
1340          * there may be more unused pages which will be freed. */
1341
1342         /* Object may have shrunk but shouldn't have grown - check. */
1343         gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
1344
1345         page_table[next_page].gen = new_space;
1346         page_table[next_page].allocated = UNBOXED_PAGE_FLAG;
1347
1348         /* Adjust the bytes_used. */
1349         old_bytes_used = page_table[next_page].bytes_used;
1350         page_table[next_page].bytes_used = remaining_bytes;
1351
1352         bytes_freed = old_bytes_used - remaining_bytes;
1353
1354         /* Free any remaining pages; needs care. */
1355         next_page++;
1356         while ((old_bytes_used == PAGE_BYTES) &&
1357                (page_table[next_page].gen == from_space) &&
1358                ((page_table[next_page].allocated == UNBOXED_PAGE_FLAG)
1359                 || (page_table[next_page].allocated == BOXED_PAGE_FLAG)) &&
1360                page_table[next_page].large_object &&
1361                (page_table[next_page].first_object_offset ==
1362                 -(next_page - first_page)*PAGE_BYTES)) {
1363             /* Checks out OK, free the page. Don't need to both zeroing
1364              * pages as this should have been done before shrinking the
1365              * object. These pages shouldn't be write-protected, even if
1366              * boxed they should be zero filled. */
1367             gc_assert(page_table[next_page].write_protected == 0);
1368
1369             old_bytes_used = page_table[next_page].bytes_used;
1370             page_table[next_page].allocated = FREE_PAGE_FLAG;
1371             page_table[next_page].bytes_used = 0;
1372             bytes_freed += old_bytes_used;
1373             next_page++;
1374         }
1375
1376         if ((bytes_freed > 0) && gencgc_verbose)
1377             FSHOW((stderr,
1378                    "/copy_large_unboxed bytes_freed=%d\n",
1379                    bytes_freed));
1380
1381         generations[from_space].bytes_allocated -= nwords*N_WORD_BYTES + bytes_freed;
1382         generations[new_space].bytes_allocated += nwords*N_WORD_BYTES;
1383         bytes_allocated -= bytes_freed;
1384
1385         return(object);
1386     }
1387     else {
1388         /* Get tag of object. */
1389         tag = lowtag_of(object);
1390
1391         /* Allocate space. */
1392         new = gc_quick_alloc_large_unboxed(nwords*N_WORD_BYTES);
1393
1394         /* Copy the object. */
1395         memcpy(new,native_pointer(object),nwords*N_WORD_BYTES);
1396
1397         /* Return Lisp pointer of new object. */
1398         return ((lispobj) new) | tag;
1399     }
1400 }
1401
1402
1403
1404 \f
1405
1406 /*
1407  * code and code-related objects
1408  */
1409 /*
1410 static lispobj trans_fun_header(lispobj object);
1411 static lispobj trans_boxed(lispobj object);
1412 */
1413
1414 /* Scan a x86 compiled code object, looking for possible fixups that
1415  * have been missed after a move.
1416  *
1417  * Two types of fixups are needed:
1418  * 1. Absolute fixups to within the code object.
1419  * 2. Relative fixups to outside the code object.
1420  *
1421  * Currently only absolute fixups to the constant vector, or to the
1422  * code area are checked. */
1423 void
1424 sniff_code_object(struct code *code, unsigned long displacement)
1425 {
1426 #ifdef LISP_FEATURE_X86
1427     long nheader_words, ncode_words, nwords;
1428     void *p;
1429     void *constants_start_addr = NULL, *constants_end_addr;
1430     void *code_start_addr, *code_end_addr;
1431     int fixup_found = 0;
1432
1433     if (!check_code_fixups)
1434         return;
1435
1436     ncode_words = fixnum_value(code->code_size);
1437     nheader_words = HeaderValue(*(lispobj *)code);
1438     nwords = ncode_words + nheader_words;
1439
1440     constants_start_addr = (void *)code + 5*N_WORD_BYTES;
1441     constants_end_addr = (void *)code + nheader_words*N_WORD_BYTES;
1442     code_start_addr = (void *)code + nheader_words*N_WORD_BYTES;
1443     code_end_addr = (void *)code + nwords*N_WORD_BYTES;
1444
1445     /* Work through the unboxed code. */
1446     for (p = code_start_addr; p < code_end_addr; p++) {
1447         void *data = *(void **)p;
1448         unsigned d1 = *((unsigned char *)p - 1);
1449         unsigned d2 = *((unsigned char *)p - 2);
1450         unsigned d3 = *((unsigned char *)p - 3);
1451         unsigned d4 = *((unsigned char *)p - 4);
1452 #ifdef QSHOW
1453         unsigned d5 = *((unsigned char *)p - 5);
1454         unsigned d6 = *((unsigned char *)p - 6);
1455 #endif
1456
1457         /* Check for code references. */
1458         /* Check for a 32 bit word that looks like an absolute
1459            reference to within the code adea of the code object. */
1460         if ((data >= (code_start_addr-displacement))
1461             && (data < (code_end_addr-displacement))) {
1462             /* function header */
1463             if ((d4 == 0x5e)
1464                 && (((unsigned)p - 4 - 4*HeaderValue(*((unsigned *)p-1))) == (unsigned)code)) {
1465                 /* Skip the function header */
1466                 p += 6*4 - 4 - 1;
1467                 continue;
1468             }
1469             /* the case of PUSH imm32 */
1470             if (d1 == 0x68) {
1471                 fixup_found = 1;
1472                 FSHOW((stderr,
1473                        "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1474                        p, d6, d5, d4, d3, d2, d1, data));
1475                 FSHOW((stderr, "/PUSH $0x%.8x\n", data));
1476             }
1477             /* the case of MOV [reg-8],imm32 */
1478             if ((d3 == 0xc7)
1479                 && (d2==0x40 || d2==0x41 || d2==0x42 || d2==0x43
1480                     || d2==0x45 || d2==0x46 || d2==0x47)
1481                 && (d1 == 0xf8)) {
1482                 fixup_found = 1;
1483                 FSHOW((stderr,
1484                        "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1485                        p, d6, d5, d4, d3, d2, d1, data));
1486                 FSHOW((stderr, "/MOV [reg-8],$0x%.8x\n", data));
1487             }
1488             /* the case of LEA reg,[disp32] */
1489             if ((d2 == 0x8d) && ((d1 & 0xc7) == 5)) {
1490                 fixup_found = 1;
1491                 FSHOW((stderr,
1492                        "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1493                        p, d6, d5, d4, d3, d2, d1, data));
1494                 FSHOW((stderr,"/LEA reg,[$0x%.8x]\n", data));
1495             }
1496         }
1497
1498         /* Check for constant references. */
1499         /* Check for a 32 bit word that looks like an absolute
1500            reference to within the constant vector. Constant references
1501            will be aligned. */
1502         if ((data >= (constants_start_addr-displacement))
1503             && (data < (constants_end_addr-displacement))
1504             && (((unsigned)data & 0x3) == 0)) {
1505             /*  Mov eax,m32 */
1506             if (d1 == 0xa1) {
1507                 fixup_found = 1;
1508                 FSHOW((stderr,
1509                        "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1510                        p, d6, d5, d4, d3, d2, d1, data));
1511                 FSHOW((stderr,"/MOV eax,0x%.8x\n", data));
1512             }
1513
1514             /*  the case of MOV m32,EAX */
1515             if (d1 == 0xa3) {
1516                 fixup_found = 1;
1517                 FSHOW((stderr,
1518                        "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1519                        p, d6, d5, d4, d3, d2, d1, data));
1520                 FSHOW((stderr, "/MOV 0x%.8x,eax\n", data));
1521             }
1522
1523             /* the case of CMP m32,imm32 */
1524             if ((d1 == 0x3d) && (d2 == 0x81)) {
1525                 fixup_found = 1;
1526                 FSHOW((stderr,
1527                        "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1528                        p, d6, d5, d4, d3, d2, d1, data));
1529                 /* XX Check this */
1530                 FSHOW((stderr, "/CMP 0x%.8x,immed32\n", data));
1531             }
1532
1533             /* Check for a mod=00, r/m=101 byte. */
1534             if ((d1 & 0xc7) == 5) {
1535                 /* Cmp m32,reg */
1536                 if (d2 == 0x39) {
1537                     fixup_found = 1;
1538                     FSHOW((stderr,
1539                            "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1540                            p, d6, d5, d4, d3, d2, d1, data));
1541                     FSHOW((stderr,"/CMP 0x%.8x,reg\n", data));
1542                 }
1543                 /* the case of CMP reg32,m32 */
1544                 if (d2 == 0x3b) {
1545                     fixup_found = 1;
1546                     FSHOW((stderr,
1547                            "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1548                            p, d6, d5, d4, d3, d2, d1, data));
1549                     FSHOW((stderr, "/CMP reg32,0x%.8x\n", data));
1550                 }
1551                 /* the case of MOV m32,reg32 */
1552                 if (d2 == 0x89) {
1553                     fixup_found = 1;
1554                     FSHOW((stderr,
1555                            "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1556                            p, d6, d5, d4, d3, d2, d1, data));
1557                     FSHOW((stderr, "/MOV 0x%.8x,reg32\n", data));
1558                 }
1559                 /* the case of MOV reg32,m32 */
1560                 if (d2 == 0x8b) {
1561                     fixup_found = 1;
1562                     FSHOW((stderr,
1563                            "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1564                            p, d6, d5, d4, d3, d2, d1, data));
1565                     FSHOW((stderr, "/MOV reg32,0x%.8x\n", data));
1566                 }
1567                 /* the case of LEA reg32,m32 */
1568                 if (d2 == 0x8d) {
1569                     fixup_found = 1;
1570                     FSHOW((stderr,
1571                            "abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1572                            p, d6, d5, d4, d3, d2, d1, data));
1573                     FSHOW((stderr, "/LEA reg32,0x%.8x\n", data));
1574                 }
1575             }
1576         }
1577     }
1578
1579     /* If anything was found, print some information on the code
1580      * object. */
1581     if (fixup_found) {
1582         FSHOW((stderr,
1583                "/compiled code object at %x: header words = %d, code words = %d\n",
1584                code, nheader_words, ncode_words));
1585         FSHOW((stderr,
1586                "/const start = %x, end = %x\n",
1587                constants_start_addr, constants_end_addr));
1588         FSHOW((stderr,
1589                "/code start = %x, end = %x\n",
1590                code_start_addr, code_end_addr));
1591     }
1592 #endif
1593 }
1594
1595 void
1596 gencgc_apply_code_fixups(struct code *old_code, struct code *new_code)
1597 {
1598 /* x86-64 uses pc-relative addressing instead of this kludge */
1599 #ifndef LISP_FEATURE_X86_64
1600     long nheader_words, ncode_words, nwords;
1601     void *constants_start_addr, *constants_end_addr;
1602     void *code_start_addr, *code_end_addr;
1603     lispobj fixups = NIL;
1604     unsigned long displacement = (unsigned long)new_code - (unsigned long)old_code;
1605     struct vector *fixups_vector;
1606
1607     ncode_words = fixnum_value(new_code->code_size);
1608     nheader_words = HeaderValue(*(lispobj *)new_code);
1609     nwords = ncode_words + nheader_words;
1610     /* FSHOW((stderr,
1611              "/compiled code object at %x: header words = %d, code words = %d\n",
1612              new_code, nheader_words, ncode_words)); */
1613     constants_start_addr = (void *)new_code + 5*N_WORD_BYTES;
1614     constants_end_addr = (void *)new_code + nheader_words*N_WORD_BYTES;
1615     code_start_addr = (void *)new_code + nheader_words*N_WORD_BYTES;
1616     code_end_addr = (void *)new_code + nwords*N_WORD_BYTES;
1617     /*
1618     FSHOW((stderr,
1619            "/const start = %x, end = %x\n",
1620            constants_start_addr,constants_end_addr));
1621     FSHOW((stderr,
1622            "/code start = %x; end = %x\n",
1623            code_start_addr,code_end_addr));
1624     */
1625
1626     /* The first constant should be a pointer to the fixups for this
1627        code objects. Check. */
1628     fixups = new_code->constants[0];
1629
1630     /* It will be 0 or the unbound-marker if there are no fixups (as
1631      * will be the case if the code object has been purified, for
1632      * example) and will be an other pointer if it is valid. */
1633     if ((fixups == 0) || (fixups == UNBOUND_MARKER_WIDETAG) ||
1634         !is_lisp_pointer(fixups)) {
1635         /* Check for possible errors. */
1636         if (check_code_fixups)
1637             sniff_code_object(new_code, displacement);
1638
1639         return;
1640     }
1641
1642     fixups_vector = (struct vector *)native_pointer(fixups);
1643
1644     /* Could be pointing to a forwarding pointer. */
1645     /* FIXME is this always in from_space?  if so, could replace this code with
1646      * forwarding_pointer_p/forwarding_pointer_value */
1647     if (is_lisp_pointer(fixups) &&
1648         (find_page_index((void*)fixups_vector) != -1) &&
1649         (fixups_vector->header == 0x01)) {
1650         /* If so, then follow it. */
1651         /*SHOW("following pointer to a forwarding pointer");*/
1652         fixups_vector = (struct vector *)native_pointer((lispobj)fixups_vector->length);
1653     }
1654
1655     /*SHOW("got fixups");*/
1656
1657     if (widetag_of(fixups_vector->header) == SIMPLE_ARRAY_WORD_WIDETAG) {
1658         /* Got the fixups for the code block. Now work through the vector,
1659            and apply a fixup at each address. */
1660         long length = fixnum_value(fixups_vector->length);
1661         long i;
1662         for (i = 0; i < length; i++) {
1663             unsigned long offset = fixups_vector->data[i];
1664             /* Now check the current value of offset. */
1665             unsigned long old_value =
1666                 *(unsigned long *)((unsigned long)code_start_addr + offset);
1667
1668             /* If it's within the old_code object then it must be an
1669              * absolute fixup (relative ones are not saved) */
1670             if ((old_value >= (unsigned long)old_code)
1671                 && (old_value < ((unsigned long)old_code + nwords*N_WORD_BYTES)))
1672                 /* So add the dispacement. */
1673                 *(unsigned long *)((unsigned long)code_start_addr + offset) =
1674                     old_value + displacement;
1675             else
1676                 /* It is outside the old code object so it must be a
1677                  * relative fixup (absolute fixups are not saved). So
1678                  * subtract the displacement. */
1679                 *(unsigned long *)((unsigned long)code_start_addr + offset) =
1680                     old_value - displacement;
1681         }
1682     } else {
1683         fprintf(stderr, "widetag of fixup vector is %d\n", widetag_of(fixups_vector->header));
1684     }
1685
1686     /* Check for possible errors. */
1687     if (check_code_fixups) {
1688         sniff_code_object(new_code,displacement);
1689     }
1690 #endif
1691 }
1692
1693
1694 static lispobj
1695 trans_boxed_large(lispobj object)
1696 {
1697     lispobj header;
1698     unsigned long length;
1699
1700     gc_assert(is_lisp_pointer(object));
1701
1702     header = *((lispobj *) native_pointer(object));
1703     length = HeaderValue(header) + 1;
1704     length = CEILING(length, 2);
1705
1706     return copy_large_object(object, length);
1707 }
1708
1709 /* Doesn't seem to be used, delete it after the grace period. */
1710 #if 0
1711 static lispobj
1712 trans_unboxed_large(lispobj object)
1713 {
1714     lispobj header;
1715     unsigned long length;
1716
1717     gc_assert(is_lisp_pointer(object));
1718
1719     header = *((lispobj *) native_pointer(object));
1720     length = HeaderValue(header) + 1;
1721     length = CEILING(length, 2);
1722
1723     return copy_large_unboxed_object(object, length);
1724 }
1725 #endif
1726
1727 \f
1728 /*
1729  * vector-like objects
1730  */
1731
1732
1733 /* FIXME: What does this mean? */
1734 int gencgc_hash = 1;
1735
1736 static long
1737 scav_vector(lispobj *where, lispobj object)
1738 {
1739     unsigned long kv_length;
1740     lispobj *kv_vector;
1741     unsigned long length = 0; /* (0 = dummy to stop GCC warning) */
1742     struct hash_table *hash_table;
1743     lispobj empty_symbol;
1744     unsigned long *index_vector = NULL; /* (NULL = dummy to stop GCC warning) */
1745     unsigned long *next_vector = NULL; /* (NULL = dummy to stop GCC warning) */
1746     unsigned long *hash_vector = NULL; /* (NULL = dummy to stop GCC warning) */
1747     lispobj weak_p_obj;
1748     unsigned long next_vector_length = 0;
1749
1750     /* FIXME: A comment explaining this would be nice. It looks as
1751      * though SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based
1752      * hash tables in the Lisp HASH-TABLE code, and nowhere else. */
1753     if (HeaderValue(object) != subtype_VectorValidHashing)
1754         return 1;
1755
1756     if (!gencgc_hash) {
1757         /* This is set for backward compatibility. FIXME: Do we need
1758          * this any more? */
1759         *where =
1760             (subtype_VectorMustRehash<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
1761         return 1;
1762     }
1763
1764     kv_length = fixnum_value(where[1]);
1765     kv_vector = where + 2;  /* Skip the header and length. */
1766     /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
1767
1768     /* Scavenge element 0, which may be a hash-table structure. */
1769     scavenge(where+2, 1);
1770     if (!is_lisp_pointer(where[2])) {
1771         lose("no pointer at %x in hash table\n", where[2]);
1772     }
1773     hash_table = (struct hash_table *)native_pointer(where[2]);
1774     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
1775     if (widetag_of(hash_table->header) != INSTANCE_HEADER_WIDETAG) {
1776         lose("hash table not instance (%x at %x)\n",
1777              hash_table->header,
1778              hash_table);
1779     }
1780
1781     /* Scavenge element 1, which should be some internal symbol that
1782      * the hash table code reserves for marking empty slots. */
1783     scavenge(where+3, 1);
1784     if (!is_lisp_pointer(where[3])) {
1785         lose("not empty-hash-table-slot symbol pointer: %x\n", where[3]);
1786     }
1787     empty_symbol = where[3];
1788     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
1789     if (widetag_of(*(lispobj *)native_pointer(empty_symbol)) !=
1790         SYMBOL_HEADER_WIDETAG) {
1791         lose("not a symbol where empty-hash-table-slot symbol expected: %x\n",
1792              *(lispobj *)native_pointer(empty_symbol));
1793     }
1794
1795     /* Scavenge hash table, which will fix the positions of the other
1796      * needed objects. */
1797     scavenge((lispobj *)hash_table,
1798              sizeof(struct hash_table) / sizeof(lispobj));
1799
1800     /* Cross-check the kv_vector. */
1801     if (where != (lispobj *)native_pointer(hash_table->table)) {
1802         lose("hash_table table!=this table %x\n", hash_table->table);
1803     }
1804
1805     /* WEAK-P */
1806     weak_p_obj = hash_table->weak_p;
1807
1808     /* index vector */
1809     {
1810         lispobj index_vector_obj = hash_table->index_vector;
1811
1812         if (is_lisp_pointer(index_vector_obj) &&
1813             (widetag_of(*(lispobj *)native_pointer(index_vector_obj)) ==
1814                  SIMPLE_ARRAY_WORD_WIDETAG)) {
1815             index_vector =
1816                 ((unsigned long *)native_pointer(index_vector_obj)) + 2;
1817             /*FSHOW((stderr, "/index_vector = %x\n",index_vector));*/
1818             length = fixnum_value(((lispobj *)native_pointer(index_vector_obj))[1]);
1819             /*FSHOW((stderr, "/length = %d\n", length));*/
1820         } else {
1821             lose("invalid index_vector %x\n", index_vector_obj);
1822         }
1823     }
1824
1825     /* next vector */
1826     {
1827         lispobj next_vector_obj = hash_table->next_vector;
1828
1829         if (is_lisp_pointer(next_vector_obj) &&
1830             (widetag_of(*(lispobj *)native_pointer(next_vector_obj)) ==
1831              SIMPLE_ARRAY_WORD_WIDETAG)) {
1832             next_vector = ((unsigned long *)native_pointer(next_vector_obj)) + 2;
1833             /*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/
1834             next_vector_length = fixnum_value(((lispobj *)native_pointer(next_vector_obj))[1]);
1835             /*FSHOW((stderr, "/next_vector_length = %d\n", next_vector_length));*/
1836         } else {
1837             lose("invalid next_vector %x\n", next_vector_obj);
1838         }
1839     }
1840
1841     /* maybe hash vector */
1842     {
1843         lispobj hash_vector_obj = hash_table->hash_vector;
1844
1845         if (is_lisp_pointer(hash_vector_obj) &&
1846             (widetag_of(*(lispobj *)native_pointer(hash_vector_obj)) ==
1847              SIMPLE_ARRAY_WORD_WIDETAG)){
1848             hash_vector =
1849                 ((unsigned long *)native_pointer(hash_vector_obj)) + 2;
1850             /*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/
1851             gc_assert(fixnum_value(((lispobj *)native_pointer(hash_vector_obj))[1])
1852                       == next_vector_length);
1853         } else {
1854             hash_vector = NULL;
1855             /*FSHOW((stderr, "/no hash_vector: %x\n", hash_vector_obj));*/
1856         }
1857     }
1858
1859     /* These lengths could be different as the index_vector can be a
1860      * different length from the others, a larger index_vector could help
1861      * reduce collisions. */
1862     gc_assert(next_vector_length*2 == kv_length);
1863
1864     /* now all set up.. */
1865
1866     /* Work through the KV vector. */
1867     {
1868         long i;
1869         for (i = 1; i < next_vector_length; i++) {
1870             lispobj old_key = kv_vector[2*i];
1871
1872 #if N_WORD_BITS == 32
1873             unsigned long old_index = (old_key & 0x1fffffff)%length;
1874 #elif N_WORD_BITS == 64
1875             unsigned long old_index = (old_key & 0x1fffffffffffffff)%length;
1876 #endif
1877
1878             /* Scavenge the key and value. */
1879             scavenge(&kv_vector[2*i],2);
1880
1881             /* Check whether the key has moved and is EQ based. */
1882             {
1883                 lispobj new_key = kv_vector[2*i];
1884 #if N_WORD_BITS == 32
1885                 unsigned long new_index = (new_key & 0x1fffffff)%length;
1886 #elif N_WORD_BITS == 64
1887                 unsigned long new_index = (new_key & 0x1fffffffffffffff)%length;
1888 #endif
1889
1890                 if ((old_index != new_index) &&
1891                     ((!hash_vector) ||
1892                      (hash_vector[i] == MAGIC_HASH_VECTOR_VALUE)) &&
1893                     ((new_key != empty_symbol) ||
1894                      (kv_vector[2*i] != empty_symbol))) {
1895
1896                      /*FSHOW((stderr,
1897                             "* EQ key %d moved from %x to %x; index %d to %d\n",
1898                             i, old_key, new_key, old_index, new_index));*/
1899
1900                     if (index_vector[old_index] != 0) {
1901                          /*FSHOW((stderr, "/P1 %d\n", index_vector[old_index]));*/
1902
1903                         /* Unlink the key from the old_index chain. */
1904                         if (index_vector[old_index] == i) {
1905                             /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/
1906                             index_vector[old_index] = next_vector[i];
1907                             /* Link it into the needing rehash chain. */
1908                             next_vector[i] = fixnum_value(hash_table->needing_rehash);
1909                             hash_table->needing_rehash = make_fixnum(i);
1910                             /*SHOW("P2");*/
1911                         } else {
1912                             unsigned long prior = index_vector[old_index];
1913                             unsigned long next = next_vector[prior];
1914
1915                             /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
1916
1917                             while (next != 0) {
1918                                  /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
1919                                 if (next == i) {
1920                                     /* Unlink it. */
1921                                     next_vector[prior] = next_vector[next];
1922                                     /* Link it into the needing rehash
1923                                      * chain. */
1924                                     next_vector[next] =
1925                                         fixnum_value(hash_table->needing_rehash);
1926                                     hash_table->needing_rehash = make_fixnum(next);
1927                                     /*SHOW("/P3");*/
1928                                     break;
1929                                 }
1930                                 prior = next;
1931                                 next = next_vector[next];
1932                             }
1933                         }
1934                     }
1935                 }
1936             }
1937         }
1938     }
1939     return (CEILING(kv_length + 2, 2));
1940 }
1941
1942
1943 \f
1944 /*
1945  * weak pointers
1946  */
1947
1948 /* XX This is a hack adapted from cgc.c. These don't work too
1949  * efficiently with the gencgc as a list of the weak pointers is
1950  * maintained within the objects which causes writes to the pages. A
1951  * limited attempt is made to avoid unnecessary writes, but this needs
1952  * a re-think. */
1953 #define WEAK_POINTER_NWORDS \
1954     CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1955
1956 static long
1957 scav_weak_pointer(lispobj *where, lispobj object)
1958 {
1959     struct weak_pointer *wp = weak_pointers;
1960     /* Push the weak pointer onto the list of weak pointers.
1961      * Do I have to watch for duplicates? Originally this was
1962      * part of trans_weak_pointer but that didn't work in the
1963      * case where the WP was in a promoted region.
1964      */
1965
1966     /* Check whether it's already in the list. */
1967     while (wp != NULL) {
1968         if (wp == (struct weak_pointer*)where) {
1969             break;
1970         }
1971         wp = wp->next;
1972     }
1973     if (wp == NULL) {
1974         /* Add it to the start of the list. */
1975         wp = (struct weak_pointer*)where;
1976         if (wp->next != weak_pointers) {
1977             wp->next = weak_pointers;
1978         } else {
1979             /*SHOW("avoided write to weak pointer");*/
1980         }
1981         weak_pointers = wp;
1982     }
1983
1984     /* Do not let GC scavenge the value slot of the weak pointer.
1985      * (That is why it is a weak pointer.) */
1986
1987     return WEAK_POINTER_NWORDS;
1988 }
1989
1990 \f
1991 lispobj *
1992 search_read_only_space(void *pointer)
1993 {
1994     lispobj *start = (lispobj *) READ_ONLY_SPACE_START;
1995     lispobj *end = (lispobj *) SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
1996     if ((pointer < (void *)start) || (pointer >= (void *)end))
1997         return NULL;
1998     return (gc_search_space(start,
1999                             (((lispobj *)pointer)+2)-start,
2000                             (lispobj *) pointer));
2001 }
2002
2003 lispobj *
2004 search_static_space(void *pointer)
2005 {
2006     lispobj *start = (lispobj *)STATIC_SPACE_START;
2007     lispobj *end = (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
2008     if ((pointer < (void *)start) || (pointer >= (void *)end))
2009         return NULL;
2010     return (gc_search_space(start,
2011                             (((lispobj *)pointer)+2)-start,
2012                             (lispobj *) pointer));
2013 }
2014
2015 /* a faster version for searching the dynamic space. This will work even
2016  * if the object is in a current allocation region. */
2017 lispobj *
2018 search_dynamic_space(void *pointer)
2019 {
2020     page_index_t page_index = find_page_index(pointer);
2021     lispobj *start;
2022
2023     /* The address may be invalid, so do some checks. */
2024     if ((page_index == -1) ||
2025         (page_table[page_index].allocated == FREE_PAGE_FLAG))
2026         return NULL;
2027     start = (lispobj *)((void *)page_address(page_index)
2028                         + page_table[page_index].first_object_offset);
2029     return (gc_search_space(start,
2030                             (((lispobj *)pointer)+2)-start,
2031                             (lispobj *)pointer));
2032 }
2033
2034 /* Is there any possibility that pointer is a valid Lisp object
2035  * reference, and/or something else (e.g. subroutine call return
2036  * address) which should prevent us from moving the referred-to thing?
2037  * This is called from preserve_pointers() */
2038 static int
2039 possibly_valid_dynamic_space_pointer(lispobj *pointer)
2040 {
2041     lispobj *start_addr;
2042
2043     /* Find the object start address. */
2044     if ((start_addr = search_dynamic_space(pointer)) == NULL) {
2045         return 0;
2046     }
2047
2048     /* We need to allow raw pointers into Code objects for return
2049      * addresses. This will also pick up pointers to functions in code
2050      * objects. */
2051     if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
2052         /* XXX could do some further checks here */
2053         return 1;
2054     }
2055
2056     /* If it's not a return address then it needs to be a valid Lisp
2057      * pointer. */
2058     if (!is_lisp_pointer((lispobj)pointer)) {
2059         return 0;
2060     }
2061
2062     /* Check that the object pointed to is consistent with the pointer
2063      * low tag.
2064      */
2065     switch (lowtag_of((lispobj)pointer)) {
2066     case FUN_POINTER_LOWTAG:
2067         /* Start_addr should be the enclosing code object, or a closure
2068          * header. */
2069         switch (widetag_of(*start_addr)) {
2070         case CODE_HEADER_WIDETAG:
2071             /* This case is probably caught above. */
2072             break;
2073         case CLOSURE_HEADER_WIDETAG:
2074         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2075             if ((unsigned long)pointer !=
2076                 ((unsigned long)start_addr+FUN_POINTER_LOWTAG)) {
2077                 if (gencgc_verbose)
2078                     FSHOW((stderr,
2079                            "/Wf2: %x %x %x\n",
2080                            pointer, start_addr, *start_addr));
2081                 return 0;
2082             }
2083             break;
2084         default:
2085             if (gencgc_verbose)
2086                 FSHOW((stderr,
2087                        "/Wf3: %x %x %x\n",
2088                        pointer, start_addr, *start_addr));
2089             return 0;
2090         }
2091         break;
2092     case LIST_POINTER_LOWTAG:
2093         if ((unsigned long)pointer !=
2094             ((unsigned long)start_addr+LIST_POINTER_LOWTAG)) {
2095             if (gencgc_verbose)
2096                 FSHOW((stderr,
2097                        "/Wl1: %x %x %x\n",
2098                        pointer, start_addr, *start_addr));
2099             return 0;
2100         }
2101         /* Is it plausible cons? */
2102         if ((is_lisp_pointer(start_addr[0])
2103             || (fixnump(start_addr[0]))
2104             || (widetag_of(start_addr[0]) == CHARACTER_WIDETAG)
2105 #if N_WORD_BITS == 64
2106             || (widetag_of(start_addr[0]) == SINGLE_FLOAT_WIDETAG)
2107 #endif
2108             || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG))
2109            && (is_lisp_pointer(start_addr[1])
2110                || (fixnump(start_addr[1]))
2111                || (widetag_of(start_addr[1]) == CHARACTER_WIDETAG)
2112 #if N_WORD_BITS == 64
2113                || (widetag_of(start_addr[1]) == SINGLE_FLOAT_WIDETAG)
2114 #endif
2115                || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG)))
2116             break;
2117         else {
2118             if (gencgc_verbose)
2119                 FSHOW((stderr,
2120                        "/Wl2: %x %x %x\n",
2121                        pointer, start_addr, *start_addr));
2122             return 0;
2123         }
2124     case INSTANCE_POINTER_LOWTAG:
2125         if ((unsigned long)pointer !=
2126             ((unsigned long)start_addr+INSTANCE_POINTER_LOWTAG)) {
2127             if (gencgc_verbose)
2128                 FSHOW((stderr,
2129                        "/Wi1: %x %x %x\n",
2130                        pointer, start_addr, *start_addr));
2131             return 0;
2132         }
2133         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
2134             if (gencgc_verbose)
2135                 FSHOW((stderr,
2136                        "/Wi2: %x %x %x\n",
2137                        pointer, start_addr, *start_addr));
2138             return 0;
2139         }
2140         break;
2141     case OTHER_POINTER_LOWTAG:
2142         if ((unsigned long)pointer !=
2143             ((unsigned long)start_addr+OTHER_POINTER_LOWTAG)) {
2144             if (gencgc_verbose)
2145                 FSHOW((stderr,
2146                        "/Wo1: %x %x %x\n",
2147                        pointer, start_addr, *start_addr));
2148             return 0;
2149         }
2150         /* Is it plausible?  Not a cons. XXX should check the headers. */
2151         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
2152             if (gencgc_verbose)
2153                 FSHOW((stderr,
2154                        "/Wo2: %x %x %x\n",
2155                        pointer, start_addr, *start_addr));
2156             return 0;
2157         }
2158         switch (widetag_of(start_addr[0])) {
2159         case UNBOUND_MARKER_WIDETAG:
2160         case NO_TLS_VALUE_MARKER_WIDETAG:
2161         case CHARACTER_WIDETAG:
2162 #if N_WORD_BITS == 64
2163         case SINGLE_FLOAT_WIDETAG:
2164 #endif
2165             if (gencgc_verbose)
2166                 FSHOW((stderr,
2167                        "*Wo3: %x %x %x\n",
2168                        pointer, start_addr, *start_addr));
2169             return 0;
2170
2171             /* only pointed to by function pointers? */
2172         case CLOSURE_HEADER_WIDETAG:
2173         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
2174             if (gencgc_verbose)
2175                 FSHOW((stderr,
2176                        "*Wo4: %x %x %x\n",
2177                        pointer, start_addr, *start_addr));
2178             return 0;
2179
2180         case INSTANCE_HEADER_WIDETAG:
2181             if (gencgc_verbose)
2182                 FSHOW((stderr,
2183                        "*Wo5: %x %x %x\n",
2184                        pointer, start_addr, *start_addr));
2185             return 0;
2186
2187             /* the valid other immediate pointer objects */
2188         case SIMPLE_VECTOR_WIDETAG:
2189         case RATIO_WIDETAG:
2190         case COMPLEX_WIDETAG:
2191 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
2192         case COMPLEX_SINGLE_FLOAT_WIDETAG:
2193 #endif
2194 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
2195         case COMPLEX_DOUBLE_FLOAT_WIDETAG:
2196 #endif
2197 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
2198         case COMPLEX_LONG_FLOAT_WIDETAG:
2199 #endif
2200         case SIMPLE_ARRAY_WIDETAG:
2201         case COMPLEX_BASE_STRING_WIDETAG:
2202 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
2203         case COMPLEX_CHARACTER_STRING_WIDETAG:
2204 #endif
2205         case COMPLEX_VECTOR_NIL_WIDETAG:
2206         case COMPLEX_BIT_VECTOR_WIDETAG:
2207         case COMPLEX_VECTOR_WIDETAG:
2208         case COMPLEX_ARRAY_WIDETAG:
2209         case VALUE_CELL_HEADER_WIDETAG:
2210         case SYMBOL_HEADER_WIDETAG:
2211         case FDEFN_WIDETAG:
2212         case CODE_HEADER_WIDETAG:
2213         case BIGNUM_WIDETAG:
2214 #if N_WORD_BITS != 64
2215         case SINGLE_FLOAT_WIDETAG:
2216 #endif
2217         case DOUBLE_FLOAT_WIDETAG:
2218 #ifdef LONG_FLOAT_WIDETAG
2219         case LONG_FLOAT_WIDETAG:
2220 #endif
2221         case SIMPLE_BASE_STRING_WIDETAG:
2222 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2223         case SIMPLE_CHARACTER_STRING_WIDETAG:
2224 #endif
2225         case SIMPLE_BIT_VECTOR_WIDETAG:
2226         case SIMPLE_ARRAY_NIL_WIDETAG:
2227         case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
2228         case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
2229         case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
2230         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
2231         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
2232         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
2233 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2234         case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
2235 #endif
2236         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
2237         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
2238 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2239         case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
2240 #endif
2241 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2242         case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
2243 #endif
2244 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2245         case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
2246 #endif
2247 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2248         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
2249 #endif
2250 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2251         case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
2252 #endif
2253 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2254         case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
2255 #endif
2256 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2257         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
2258 #endif
2259 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2260         case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
2261 #endif
2262 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2263         case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
2264 #endif
2265         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
2266         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
2267 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2268         case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
2269 #endif
2270 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2271         case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
2272 #endif
2273 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2274         case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
2275 #endif
2276 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2277         case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
2278 #endif
2279         case SAP_WIDETAG:
2280         case WEAK_POINTER_WIDETAG:
2281             break;
2282
2283         default:
2284             if (gencgc_verbose)
2285                 FSHOW((stderr,
2286                        "/Wo6: %x %x %x\n",
2287                        pointer, start_addr, *start_addr));
2288             return 0;
2289         }
2290         break;
2291     default:
2292         if (gencgc_verbose)
2293             FSHOW((stderr,
2294                    "*W?: %x %x %x\n",
2295                    pointer, start_addr, *start_addr));
2296         return 0;
2297     }
2298
2299     /* looks good */
2300     return 1;
2301 }
2302
2303 /* Adjust large bignum and vector objects. This will adjust the
2304  * allocated region if the size has shrunk, and move unboxed objects
2305  * into unboxed pages. The pages are not promoted here, and the
2306  * promoted region is not added to the new_regions; this is really
2307  * only designed to be called from preserve_pointer(). Shouldn't fail
2308  * if this is missed, just may delay the moving of objects to unboxed
2309  * pages, and the freeing of pages. */
2310 static void
2311 maybe_adjust_large_object(lispobj *where)
2312 {
2313     page_index_t first_page;
2314     page_index_t next_page;
2315     long nwords;
2316
2317     long remaining_bytes;
2318     long bytes_freed;
2319     long old_bytes_used;
2320
2321     int boxed;
2322
2323     /* Check whether it's a vector or bignum object. */
2324     switch (widetag_of(where[0])) {
2325     case SIMPLE_VECTOR_WIDETAG:
2326         boxed = BOXED_PAGE_FLAG;
2327         break;
2328     case BIGNUM_WIDETAG:
2329     case SIMPLE_BASE_STRING_WIDETAG:
2330 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
2331     case SIMPLE_CHARACTER_STRING_WIDETAG:
2332 #endif
2333     case SIMPLE_BIT_VECTOR_WIDETAG:
2334     case SIMPLE_ARRAY_NIL_WIDETAG:
2335     case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
2336     case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
2337     case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
2338     case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
2339     case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
2340     case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
2341 #ifdef  SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
2342     case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
2343 #endif
2344     case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
2345     case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
2346 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
2347     case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
2348 #endif
2349 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
2350     case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
2351 #endif
2352 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
2353     case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
2354 #endif
2355 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
2356     case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
2357 #endif
2358 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
2359     case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
2360 #endif
2361 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
2362     case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
2363 #endif
2364 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
2365     case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
2366 #endif
2367 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
2368     case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
2369 #endif
2370 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
2371     case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
2372 #endif
2373     case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
2374     case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
2375 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
2376     case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
2377 #endif
2378 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
2379     case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
2380 #endif
2381 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
2382     case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
2383 #endif
2384 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
2385     case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
2386 #endif
2387         boxed = UNBOXED_PAGE_FLAG;
2388         break;
2389     default:
2390         return;
2391     }
2392
2393     /* Find its current size. */
2394     nwords = (sizetab[widetag_of(where[0])])(where);
2395
2396     first_page = find_page_index((void *)where);
2397     gc_assert(first_page >= 0);
2398
2399     /* Note: Any page write-protection must be removed, else a later
2400      * scavenge_newspace may incorrectly not scavenge these pages.
2401      * This would not be necessary if they are added to the new areas,
2402      * but lets do it for them all (they'll probably be written
2403      * anyway?). */
2404
2405     gc_assert(page_table[first_page].first_object_offset == 0);
2406
2407     next_page = first_page;
2408     remaining_bytes = nwords*N_WORD_BYTES;
2409     while (remaining_bytes > PAGE_BYTES) {
2410         gc_assert(page_table[next_page].gen == from_space);
2411         gc_assert((page_table[next_page].allocated == BOXED_PAGE_FLAG)
2412                   || (page_table[next_page].allocated == UNBOXED_PAGE_FLAG));
2413         gc_assert(page_table[next_page].large_object);
2414         gc_assert(page_table[next_page].first_object_offset ==
2415                   -PAGE_BYTES*(next_page-first_page));
2416         gc_assert(page_table[next_page].bytes_used == PAGE_BYTES);
2417
2418         page_table[next_page].allocated = boxed;
2419
2420         /* Shouldn't be write-protected at this stage. Essential that the
2421          * pages aren't. */
2422         gc_assert(!page_table[next_page].write_protected);
2423         remaining_bytes -= PAGE_BYTES;
2424         next_page++;
2425     }
2426
2427     /* Now only one page remains, but the object may have shrunk so
2428      * there may be more unused pages which will be freed. */
2429
2430     /* Object may have shrunk but shouldn't have grown - check. */
2431     gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
2432
2433     page_table[next_page].allocated = boxed;
2434     gc_assert(page_table[next_page].allocated ==
2435               page_table[first_page].allocated);
2436
2437     /* Adjust the bytes_used. */
2438     old_bytes_used = page_table[next_page].bytes_used;
2439     page_table[next_page].bytes_used = remaining_bytes;
2440
2441     bytes_freed = old_bytes_used - remaining_bytes;
2442
2443     /* Free any remaining pages; needs care. */
2444     next_page++;
2445     while ((old_bytes_used == PAGE_BYTES) &&
2446            (page_table[next_page].gen == from_space) &&
2447            ((page_table[next_page].allocated == UNBOXED_PAGE_FLAG)
2448             || (page_table[next_page].allocated == BOXED_PAGE_FLAG)) &&
2449            page_table[next_page].large_object &&
2450            (page_table[next_page].first_object_offset ==
2451             -(next_page - first_page)*PAGE_BYTES)) {
2452         /* It checks out OK, free the page. We don't need to both zeroing
2453          * pages as this should have been done before shrinking the
2454          * object. These pages shouldn't be write protected as they
2455          * should be zero filled. */
2456         gc_assert(page_table[next_page].write_protected == 0);
2457
2458         old_bytes_used = page_table[next_page].bytes_used;
2459         page_table[next_page].allocated = FREE_PAGE_FLAG;
2460         page_table[next_page].bytes_used = 0;
2461         bytes_freed += old_bytes_used;
2462         next_page++;
2463     }
2464
2465     if ((bytes_freed > 0) && gencgc_verbose) {
2466         FSHOW((stderr,
2467                "/maybe_adjust_large_object() freed %d\n",
2468                bytes_freed));
2469     }
2470
2471     generations[from_space].bytes_allocated -= bytes_freed;
2472     bytes_allocated -= bytes_freed;
2473
2474     return;
2475 }
2476
2477 /* Take a possible pointer to a Lisp object and mark its page in the
2478  * page_table so that it will not be relocated during a GC.
2479  *
2480  * This involves locating the page it points to, then backing up to
2481  * the start of its region, then marking all pages dont_move from there
2482  * up to the first page that's not full or has a different generation
2483  *
2484  * It is assumed that all the page static flags have been cleared at
2485  * the start of a GC.
2486  *
2487  * It is also assumed that the current gc_alloc() region has been
2488  * flushed and the tables updated. */
2489 static void
2490 preserve_pointer(void *addr)
2491 {
2492     page_index_t addr_page_index = find_page_index(addr);
2493     page_index_t first_page;
2494     page_index_t i;
2495     unsigned int region_allocation;
2496
2497     /* quick check 1: Address is quite likely to have been invalid. */
2498     if ((addr_page_index == -1)
2499         || (page_table[addr_page_index].allocated == FREE_PAGE_FLAG)
2500         || (page_table[addr_page_index].bytes_used == 0)
2501         || (page_table[addr_page_index].gen != from_space)
2502         /* Skip if already marked dont_move. */
2503         || (page_table[addr_page_index].dont_move != 0))
2504         return;
2505     gc_assert(!(page_table[addr_page_index].allocated&OPEN_REGION_PAGE_FLAG));
2506     /* (Now that we know that addr_page_index is in range, it's
2507      * safe to index into page_table[] with it.) */
2508     region_allocation = page_table[addr_page_index].allocated;
2509
2510     /* quick check 2: Check the offset within the page.
2511      *
2512      */
2513     if (((unsigned long)addr & (PAGE_BYTES - 1)) > page_table[addr_page_index].bytes_used)
2514         return;
2515
2516     /* Filter out anything which can't be a pointer to a Lisp object
2517      * (or, as a special case which also requires dont_move, a return
2518      * address referring to something in a CodeObject). This is
2519      * expensive but important, since it vastly reduces the
2520      * probability that random garbage will be bogusly interpreted as
2521      * a pointer which prevents a page from moving. */
2522     if (!(possibly_valid_dynamic_space_pointer(addr)))
2523         return;
2524
2525     /* Find the beginning of the region.  Note that there may be
2526      * objects in the region preceding the one that we were passed a
2527      * pointer to: if this is the case, we will write-protect all the
2528      * previous objects' pages too.     */
2529
2530 #if 0
2531     /* I think this'd work just as well, but without the assertions.
2532      * -dan 2004.01.01 */
2533     first_page=
2534         find_page_index(page_address(addr_page_index)+
2535                         page_table[addr_page_index].first_object_offset);
2536 #else
2537     first_page = addr_page_index;
2538     while (page_table[first_page].first_object_offset != 0) {
2539         --first_page;
2540         /* Do some checks. */
2541         gc_assert(page_table[first_page].bytes_used == PAGE_BYTES);
2542         gc_assert(page_table[first_page].gen == from_space);
2543         gc_assert(page_table[first_page].allocated == region_allocation);
2544     }
2545 #endif
2546
2547     /* Adjust any large objects before promotion as they won't be
2548      * copied after promotion. */
2549     if (page_table[first_page].large_object) {
2550         maybe_adjust_large_object(page_address(first_page));
2551         /* If a large object has shrunk then addr may now point to a
2552          * free area in which case it's ignored here. Note it gets
2553          * through the valid pointer test above because the tail looks
2554          * like conses. */
2555         if ((page_table[addr_page_index].allocated == FREE_PAGE_FLAG)
2556             || (page_table[addr_page_index].bytes_used == 0)
2557             /* Check the offset within the page. */
2558             || (((unsigned long)addr & (PAGE_BYTES - 1))
2559                 > page_table[addr_page_index].bytes_used)) {
2560             FSHOW((stderr,
2561                    "weird? ignore ptr 0x%x to freed area of large object\n",
2562                    addr));
2563             return;
2564         }
2565         /* It may have moved to unboxed pages. */
2566         region_allocation = page_table[first_page].allocated;
2567     }
2568
2569     /* Now work forward until the end of this contiguous area is found,
2570      * marking all pages as dont_move. */
2571     for (i = first_page; ;i++) {
2572         gc_assert(page_table[i].allocated == region_allocation);
2573
2574         /* Mark the page static. */
2575         page_table[i].dont_move = 1;
2576
2577         /* Move the page to the new_space. XX I'd rather not do this
2578          * but the GC logic is not quite able to copy with the static
2579          * pages remaining in the from space. This also requires the
2580          * generation bytes_allocated counters be updated. */
2581         page_table[i].gen = new_space;
2582         generations[new_space].bytes_allocated += page_table[i].bytes_used;
2583         generations[from_space].bytes_allocated -= page_table[i].bytes_used;
2584
2585         /* It is essential that the pages are not write protected as
2586          * they may have pointers into the old-space which need
2587          * scavenging. They shouldn't be write protected at this
2588          * stage. */
2589         gc_assert(!page_table[i].write_protected);
2590
2591         /* Check whether this is the last page in this contiguous block.. */
2592         if ((page_table[i].bytes_used < PAGE_BYTES)
2593             /* ..or it is PAGE_BYTES and is the last in the block */
2594             || (page_table[i+1].allocated == FREE_PAGE_FLAG)
2595             || (page_table[i+1].bytes_used == 0) /* next page free */
2596             || (page_table[i+1].gen != from_space) /* diff. gen */
2597             || (page_table[i+1].first_object_offset == 0))
2598             break;
2599     }
2600
2601     /* Check that the page is now static. */
2602     gc_assert(page_table[addr_page_index].dont_move != 0);
2603 }
2604 \f
2605 /* If the given page is not write-protected, then scan it for pointers
2606  * to younger generations or the top temp. generation, if no
2607  * suspicious pointers are found then the page is write-protected.
2608  *
2609  * Care is taken to check for pointers to the current gc_alloc()
2610  * region if it is a younger generation or the temp. generation. This
2611  * frees the caller from doing a gc_alloc_update_page_tables(). Actually
2612  * the gc_alloc_generation does not need to be checked as this is only
2613  * called from scavenge_generation() when the gc_alloc generation is
2614  * younger, so it just checks if there is a pointer to the current
2615  * region.
2616  *
2617  * We return 1 if the page was write-protected, else 0. */
2618 static int
2619 update_page_write_prot(page_index_t page)
2620 {
2621     generation_index_t gen = page_table[page].gen;
2622     long j;
2623     int wp_it = 1;
2624     void **page_addr = (void **)page_address(page);
2625     long num_words = page_table[page].bytes_used / N_WORD_BYTES;
2626
2627     /* Shouldn't be a free page. */
2628     gc_assert(page_table[page].allocated != FREE_PAGE_FLAG);
2629     gc_assert(page_table[page].bytes_used != 0);
2630
2631     /* Skip if it's already write-protected, pinned, or unboxed */
2632     if (page_table[page].write_protected
2633         /* FIXME: What's the reason for not write-protecting pinned pages? */
2634         || page_table[page].dont_move
2635         || (page_table[page].allocated & UNBOXED_PAGE_FLAG))
2636         return (0);
2637
2638     /* Scan the page for pointers to younger generations or the
2639      * top temp. generation. */
2640
2641     for (j = 0; j < num_words; j++) {
2642         void *ptr = *(page_addr+j);
2643         page_index_t index = find_page_index(ptr);
2644
2645         /* Check that it's in the dynamic space */
2646         if (index != -1)
2647             if (/* Does it point to a younger or the temp. generation? */
2648                 ((page_table[index].allocated != FREE_PAGE_FLAG)
2649                  && (page_table[index].bytes_used != 0)
2650                  && ((page_table[index].gen < gen)
2651                      || (page_table[index].gen == SCRATCH_GENERATION)))
2652
2653                 /* Or does it point within a current gc_alloc() region? */
2654                 || ((boxed_region.start_addr <= ptr)
2655                     && (ptr <= boxed_region.free_pointer))
2656                 || ((unboxed_region.start_addr <= ptr)
2657                     && (ptr <= unboxed_region.free_pointer))) {
2658                 wp_it = 0;
2659                 break;
2660             }
2661     }
2662
2663     if (wp_it == 1) {
2664         /* Write-protect the page. */
2665         /*FSHOW((stderr, "/write-protecting page %d gen %d\n", page, gen));*/
2666
2667         os_protect((void *)page_addr,
2668                    PAGE_BYTES,
2669                    OS_VM_PROT_READ|OS_VM_PROT_EXECUTE);
2670
2671         /* Note the page as protected in the page tables. */
2672         page_table[page].write_protected = 1;
2673     }
2674
2675     return (wp_it);
2676 }
2677
2678 /* Scavenge all generations from FROM to TO, inclusive, except for
2679  * new_space which needs special handling, as new objects may be
2680  * added which are not checked here - use scavenge_newspace generation.
2681  *
2682  * Write-protected pages should not have any pointers to the
2683  * from_space so do need scavenging; thus write-protected pages are
2684  * not always scavenged. There is some code to check that these pages
2685  * are not written; but to check fully the write-protected pages need
2686  * to be scavenged by disabling the code to skip them.
2687  *
2688  * Under the current scheme when a generation is GCed the younger
2689  * generations will be empty. So, when a generation is being GCed it
2690  * is only necessary to scavenge the older generations for pointers
2691  * not the younger. So a page that does not have pointers to younger
2692  * generations does not need to be scavenged.
2693  *
2694  * The write-protection can be used to note pages that don't have
2695  * pointers to younger pages. But pages can be written without having
2696  * pointers to younger generations. After the pages are scavenged here
2697  * they can be scanned for pointers to younger generations and if
2698  * there are none the page can be write-protected.
2699  *
2700  * One complication is when the newspace is the top temp. generation.
2701  *
2702  * Enabling SC_GEN_CK scavenges the write-protected pages and checks
2703  * that none were written, which they shouldn't be as they should have
2704  * no pointers to younger generations. This breaks down for weak
2705  * pointers as the objects contain a link to the next and are written
2706  * if a weak pointer is scavenged. Still it's a useful check. */
2707 static void
2708 scavenge_generations(generation_index_t from, generation_index_t to)
2709 {
2710     page_index_t i;
2711     int num_wp = 0;
2712
2713 #define SC_GEN_CK 0
2714 #if SC_GEN_CK
2715     /* Clear the write_protected_cleared flags on all pages. */
2716     for (i = 0; i < NUM_PAGES; i++)
2717         page_table[i].write_protected_cleared = 0;
2718 #endif
2719
2720     for (i = 0; i < last_free_page; i++) {
2721         generation_index_t generation = page_table[i].gen;
2722         if ((page_table[i].allocated & BOXED_PAGE_FLAG)
2723             && (page_table[i].bytes_used != 0)
2724             && (generation != new_space)
2725             && (generation >= from)
2726             && (generation <= to)) {
2727             page_index_t last_page,j;
2728             int write_protected=1;
2729
2730             /* This should be the start of a region */
2731             gc_assert(page_table[i].first_object_offset == 0);
2732
2733             /* Now work forward until the end of the region */
2734             for (last_page = i; ; last_page++) {
2735                 write_protected =
2736                     write_protected && page_table[last_page].write_protected;
2737                 if ((page_table[last_page].bytes_used < PAGE_BYTES)
2738                     /* Or it is PAGE_BYTES and is the last in the block */
2739                     || (!(page_table[last_page+1].allocated & BOXED_PAGE_FLAG))
2740                     || (page_table[last_page+1].bytes_used == 0)
2741                     || (page_table[last_page+1].gen != generation)
2742                     || (page_table[last_page+1].first_object_offset == 0))
2743                     break;
2744             }
2745             if (!write_protected) {
2746                 scavenge(page_address(i),
2747                          (page_table[last_page].bytes_used +
2748                           (last_page-i)*PAGE_BYTES)/N_WORD_BYTES);
2749
2750                 /* Now scan the pages and write protect those that
2751                  * don't have pointers to younger generations. */
2752                 if (enable_page_protection) {
2753                     for (j = i; j <= last_page; j++) {
2754                         num_wp += update_page_write_prot(j);
2755                     }
2756                 }
2757                 if ((gencgc_verbose > 1) && (num_wp != 0)) {
2758                     FSHOW((stderr,
2759                            "/write protected %d pages within generation %d\n",
2760                            num_wp, generation));
2761                 }
2762             }
2763             i = last_page;
2764         }
2765     }
2766
2767 #if SC_GEN_CK
2768     /* Check that none of the write_protected pages in this generation
2769      * have been written to. */
2770     for (i = 0; i < NUM_PAGES; i++) {
2771         if ((page_table[i].allocation != FREE_PAGE_FLAG)
2772             && (page_table[i].bytes_used != 0)
2773             && (page_table[i].gen == generation)
2774             && (page_table[i].write_protected_cleared != 0)) {
2775             FSHOW((stderr, "/scavenge_generation() %d\n", generation));
2776             FSHOW((stderr,
2777                    "/page bytes_used=%d first_object_offset=%d dont_move=%d\n",
2778                     page_table[i].bytes_used,
2779                     page_table[i].first_object_offset,
2780                     page_table[i].dont_move));
2781             lose("write to protected page %d in scavenge_generation()\n", i);
2782         }
2783     }
2784 #endif
2785 }
2786
2787 \f
2788 /* Scavenge a newspace generation. As it is scavenged new objects may
2789  * be allocated to it; these will also need to be scavenged. This
2790  * repeats until there are no more objects unscavenged in the
2791  * newspace generation.
2792  *
2793  * To help improve the efficiency, areas written are recorded by
2794  * gc_alloc() and only these scavenged. Sometimes a little more will be
2795  * scavenged, but this causes no harm. An easy check is done that the
2796  * scavenged bytes equals the number allocated in the previous
2797  * scavenge.
2798  *
2799  * Write-protected pages are not scanned except if they are marked
2800  * dont_move in which case they may have been promoted and still have
2801  * pointers to the from space.
2802  *
2803  * Write-protected pages could potentially be written by alloc however
2804  * to avoid having to handle re-scavenging of write-protected pages
2805  * gc_alloc() does not write to write-protected pages.
2806  *
2807  * New areas of objects allocated are recorded alternatively in the two
2808  * new_areas arrays below. */
2809 static struct new_area new_areas_1[NUM_NEW_AREAS];
2810 static struct new_area new_areas_2[NUM_NEW_AREAS];
2811
2812 /* Do one full scan of the new space generation. This is not enough to
2813  * complete the job as new objects may be added to the generation in
2814  * the process which are not scavenged. */
2815 static void
2816 scavenge_newspace_generation_one_scan(generation_index_t generation)
2817 {
2818     page_index_t i;
2819
2820     FSHOW((stderr,
2821            "/starting one full scan of newspace generation %d\n",
2822            generation));
2823     for (i = 0; i < last_free_page; i++) {
2824         /* Note that this skips over open regions when it encounters them. */
2825         if ((page_table[i].allocated & BOXED_PAGE_FLAG)
2826             && (page_table[i].bytes_used != 0)
2827             && (page_table[i].gen == generation)
2828             && ((page_table[i].write_protected == 0)
2829                 /* (This may be redundant as write_protected is now
2830                  * cleared before promotion.) */
2831                 || (page_table[i].dont_move == 1))) {
2832             page_index_t last_page;
2833             int all_wp=1;
2834
2835             /* The scavenge will start at the first_object_offset of page i.
2836              *
2837              * We need to find the full extent of this contiguous
2838              * block in case objects span pages.
2839              *
2840              * Now work forward until the end of this contiguous area
2841              * is found. A small area is preferred as there is a
2842              * better chance of its pages being write-protected. */
2843             for (last_page = i; ;last_page++) {
2844                 /* If all pages are write-protected and movable,
2845                  * then no need to scavenge */
2846                 all_wp=all_wp && page_table[last_page].write_protected &&
2847                     !page_table[last_page].dont_move;
2848
2849                 /* Check whether this is the last page in this
2850                  * contiguous block */
2851                 if ((page_table[last_page].bytes_used < PAGE_BYTES)
2852                     /* Or it is PAGE_BYTES and is the last in the block */
2853                     || (!(page_table[last_page+1].allocated & BOXED_PAGE_FLAG))
2854                     || (page_table[last_page+1].bytes_used == 0)
2855                     || (page_table[last_page+1].gen != generation)
2856                     || (page_table[last_page+1].first_object_offset == 0))
2857                     break;
2858             }
2859
2860             /* Do a limited check for write-protected pages.  */
2861             if (!all_wp) {
2862                 long size;
2863
2864                 size = (page_table[last_page].bytes_used
2865                         + (last_page-i)*PAGE_BYTES
2866                         - page_table[i].first_object_offset)/N_WORD_BYTES;
2867                 new_areas_ignore_page = last_page;
2868
2869                 scavenge(page_address(i) +
2870                          page_table[i].first_object_offset,
2871                          size);
2872
2873             }
2874             i = last_page;
2875         }
2876     }
2877     FSHOW((stderr,
2878            "/done with one full scan of newspace generation %d\n",
2879            generation));
2880 }
2881
2882 /* Do a complete scavenge of the newspace generation. */
2883 static void
2884 scavenge_newspace_generation(generation_index_t generation)
2885 {
2886     long i;
2887
2888     /* the new_areas array currently being written to by gc_alloc() */
2889     struct new_area (*current_new_areas)[] = &new_areas_1;
2890     long current_new_areas_index;
2891
2892     /* the new_areas created by the previous scavenge cycle */
2893     struct new_area (*previous_new_areas)[] = NULL;
2894     long previous_new_areas_index;
2895
2896     /* Flush the current regions updating the tables. */
2897     gc_alloc_update_all_page_tables();
2898
2899     /* Turn on the recording of new areas by gc_alloc(). */
2900     new_areas = current_new_areas;
2901     new_areas_index = 0;
2902
2903     /* Don't need to record new areas that get scavenged anyway during
2904      * scavenge_newspace_generation_one_scan. */
2905     record_new_objects = 1;
2906
2907     /* Start with a full scavenge. */
2908     scavenge_newspace_generation_one_scan(generation);
2909
2910     /* Record all new areas now. */
2911     record_new_objects = 2;
2912
2913     /* Flush the current regions updating the tables. */
2914     gc_alloc_update_all_page_tables();
2915
2916     /* Grab new_areas_index. */
2917     current_new_areas_index = new_areas_index;
2918
2919     /*FSHOW((stderr,
2920              "The first scan is finished; current_new_areas_index=%d.\n",
2921              current_new_areas_index));*/
2922
2923     while (current_new_areas_index > 0) {
2924         /* Move the current to the previous new areas */
2925         previous_new_areas = current_new_areas;
2926         previous_new_areas_index = current_new_areas_index;
2927
2928         /* Scavenge all the areas in previous new areas. Any new areas
2929          * allocated are saved in current_new_areas. */
2930
2931         /* Allocate an array for current_new_areas; alternating between
2932          * new_areas_1 and 2 */
2933         if (previous_new_areas == &new_areas_1)
2934             current_new_areas = &new_areas_2;
2935         else
2936             current_new_areas = &new_areas_1;
2937
2938         /* Set up for gc_alloc(). */
2939         new_areas = current_new_areas;
2940         new_areas_index = 0;
2941
2942         /* Check whether previous_new_areas had overflowed. */
2943         if (previous_new_areas_index >= NUM_NEW_AREAS) {
2944
2945             /* New areas of objects allocated have been lost so need to do a
2946              * full scan to be sure! If this becomes a problem try
2947              * increasing NUM_NEW_AREAS. */
2948             if (gencgc_verbose)
2949                 SHOW("new_areas overflow, doing full scavenge");
2950
2951             /* Don't need to record new areas that get scavenge anyway
2952              * during scavenge_newspace_generation_one_scan. */
2953             record_new_objects = 1;
2954
2955             scavenge_newspace_generation_one_scan(generation);
2956
2957             /* Record all new areas now. */
2958             record_new_objects = 2;
2959
2960             /* Flush the current regions updating the tables. */
2961             gc_alloc_update_all_page_tables();
2962
2963         } else {
2964
2965             /* Work through previous_new_areas. */
2966             for (i = 0; i < previous_new_areas_index; i++) {
2967                 long page = (*previous_new_areas)[i].page;
2968                 long offset = (*previous_new_areas)[i].offset;
2969                 long size = (*previous_new_areas)[i].size / N_WORD_BYTES;
2970                 gc_assert((*previous_new_areas)[i].size % N_WORD_BYTES == 0);
2971                 scavenge(page_address(page)+offset, size);
2972             }
2973
2974             /* Flush the current regions updating the tables. */
2975             gc_alloc_update_all_page_tables();
2976         }
2977
2978         current_new_areas_index = new_areas_index;
2979
2980         /*FSHOW((stderr,
2981                  "The re-scan has finished; current_new_areas_index=%d.\n",
2982                  current_new_areas_index));*/
2983     }
2984
2985     /* Turn off recording of areas allocated by gc_alloc(). */
2986     record_new_objects = 0;
2987
2988 #if SC_NS_GEN_CK
2989     /* Check that none of the write_protected pages in this generation
2990      * have been written to. */
2991     for (i = 0; i < NUM_PAGES; i++) {
2992         if ((page_table[i].allocation != FREE_PAGE_FLAG)
2993             && (page_table[i].bytes_used != 0)
2994             && (page_table[i].gen == generation)
2995             && (page_table[i].write_protected_cleared != 0)
2996             && (page_table[i].dont_move == 0)) {
2997             lose("write protected page %d written to in scavenge_newspace_generation\ngeneration=%d dont_move=%d\n",
2998                  i, generation, page_table[i].dont_move);
2999         }
3000     }
3001 #endif
3002 }
3003 \f
3004 /* Un-write-protect all the pages in from_space. This is done at the
3005  * start of a GC else there may be many page faults while scavenging
3006  * the newspace (I've seen drive the system time to 99%). These pages
3007  * would need to be unprotected anyway before unmapping in
3008  * free_oldspace; not sure what effect this has on paging.. */
3009 static void
3010 unprotect_oldspace(void)
3011 {
3012     page_index_t i;
3013
3014     for (i = 0; i < last_free_page; i++) {
3015         if ((page_table[i].allocated != FREE_PAGE_FLAG)
3016             && (page_table[i].bytes_used != 0)
3017             && (page_table[i].gen == from_space)) {
3018             void *page_start;
3019
3020             page_start = (void *)page_address(i);
3021
3022             /* Remove any write-protection. We should be able to rely
3023              * on the write-protect flag to avoid redundant calls. */
3024             if (page_table[i].write_protected) {
3025                 os_protect(page_start, PAGE_BYTES, OS_VM_PROT_ALL);
3026                 page_table[i].write_protected = 0;
3027             }
3028         }
3029     }
3030 }
3031
3032 /* Work through all the pages and free any in from_space. This
3033  * assumes that all objects have been copied or promoted to an older
3034  * generation. Bytes_allocated and the generation bytes_allocated
3035  * counter are updated. The number of bytes freed is returned. */
3036 static long
3037 free_oldspace(void)
3038 {
3039     long bytes_freed = 0;
3040     page_index_t first_page, last_page;
3041
3042     first_page = 0;
3043
3044     do {
3045         /* Find a first page for the next region of pages. */
3046         while ((first_page < last_free_page)
3047                && ((page_table[first_page].allocated == FREE_PAGE_FLAG)
3048                    || (page_table[first_page].bytes_used == 0)
3049                    || (page_table[first_page].gen != from_space)))
3050             first_page++;
3051
3052         if (first_page >= last_free_page)
3053             break;
3054
3055         /* Find the last page of this region. */
3056         last_page = first_page;
3057
3058         do {
3059             /* Free the page. */
3060             bytes_freed += page_table[last_page].bytes_used;
3061             generations[page_table[last_page].gen].bytes_allocated -=
3062                 page_table[last_page].bytes_used;
3063             page_table[last_page].allocated = FREE_PAGE_FLAG;
3064             page_table[last_page].bytes_used = 0;
3065
3066             /* Remove any write-protection. We should be able to rely
3067              * on the write-protect flag to avoid redundant calls. */
3068             {
3069                 void  *page_start = (void *)page_address(last_page);
3070
3071                 if (page_table[last_page].write_protected) {
3072                     os_protect(page_start, PAGE_BYTES, OS_VM_PROT_ALL);
3073                     page_table[last_page].write_protected = 0;
3074                 }
3075             }
3076             last_page++;
3077         }
3078         while ((last_page < last_free_page)
3079                && (page_table[last_page].allocated != FREE_PAGE_FLAG)
3080                && (page_table[last_page].bytes_used != 0)
3081                && (page_table[last_page].gen == from_space));
3082
3083         /* Zero pages from first_page to (last_page-1).
3084          *
3085          * FIXME: Why not use os_zero(..) function instead of
3086          * hand-coding this again? (Check other gencgc_unmap_zero
3087          * stuff too. */
3088         if (gencgc_unmap_zero) {
3089             void *page_start, *addr;
3090
3091             page_start = (void *)page_address(first_page);
3092
3093             os_invalidate(page_start, PAGE_BYTES*(last_page-first_page));
3094             addr = os_validate(page_start, PAGE_BYTES*(last_page-first_page));
3095             if (addr == NULL || addr != page_start) {
3096                 lose("free_oldspace: page moved, 0x%08x ==> 0x%08x\n",
3097                      page_start, addr);
3098             }
3099         } else {
3100             long *page_start;
3101
3102             page_start = (long *)page_address(first_page);
3103             memset(page_start, 0,PAGE_BYTES*(last_page-first_page));
3104         }
3105
3106         first_page = last_page;
3107
3108     } while (first_page < last_free_page);
3109
3110     bytes_allocated -= bytes_freed;
3111     return bytes_freed;
3112 }
3113 \f
3114 #if 0
3115 /* Print some information about a pointer at the given address. */
3116 static void
3117 print_ptr(lispobj *addr)
3118 {
3119     /* If addr is in the dynamic space then out the page information. */
3120     page_index_t pi1 = find_page_index((void*)addr);
3121
3122     if (pi1 != -1)
3123         fprintf(stderr,"  %x: page %d  alloc %d  gen %d  bytes_used %d  offset %d  dont_move %d\n",
3124                 (unsigned long) addr,
3125                 pi1,
3126                 page_table[pi1].allocated,
3127                 page_table[pi1].gen,
3128                 page_table[pi1].bytes_used,
3129                 page_table[pi1].first_object_offset,
3130                 page_table[pi1].dont_move);
3131     fprintf(stderr,"  %x %x %x %x (%x) %x %x %x %x\n",
3132             *(addr-4),
3133             *(addr-3),
3134             *(addr-2),
3135             *(addr-1),
3136             *(addr-0),
3137             *(addr+1),
3138             *(addr+2),
3139             *(addr+3),
3140             *(addr+4));
3141 }
3142 #endif
3143
3144 extern long undefined_tramp;
3145
3146 static void
3147 verify_space(lispobj *start, size_t words)
3148 {
3149     int is_in_dynamic_space = (find_page_index((void*)start) != -1);
3150     int is_in_readonly_space =
3151         (READ_ONLY_SPACE_START <= (unsigned long)start &&
3152          (unsigned long)start < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0));
3153
3154     while (words > 0) {
3155         size_t count = 1;
3156         lispobj thing = *(lispobj*)start;
3157
3158         if (is_lisp_pointer(thing)) {
3159             page_index_t page_index = find_page_index((void*)thing);
3160             long to_readonly_space =
3161                 (READ_ONLY_SPACE_START <= thing &&
3162                  thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0));
3163             long to_static_space =
3164                 (STATIC_SPACE_START <= thing &&
3165                  thing < SymbolValue(STATIC_SPACE_FREE_POINTER,0));
3166
3167             /* Does it point to the dynamic space? */
3168             if (page_index != -1) {
3169                 /* If it's within the dynamic space it should point to a used
3170                  * page. XX Could check the offset too. */
3171                 if ((page_table[page_index].allocated != FREE_PAGE_FLAG)
3172                     && (page_table[page_index].bytes_used == 0))
3173                     lose ("Ptr %x @ %x sees free page.\n", thing, start);
3174                 /* Check that it doesn't point to a forwarding pointer! */
3175                 if (*((lispobj *)native_pointer(thing)) == 0x01) {
3176                     lose("Ptr %x @ %x sees forwarding ptr.\n", thing, start);
3177                 }
3178                 /* Check that its not in the RO space as it would then be a
3179                  * pointer from the RO to the dynamic space. */
3180                 if (is_in_readonly_space) {
3181                     lose("ptr to dynamic space %x from RO space %x\n",
3182                          thing, start);
3183                 }
3184                 /* Does it point to a plausible object? This check slows
3185                  * it down a lot (so it's commented out).
3186                  *
3187                  * "a lot" is serious: it ate 50 minutes cpu time on
3188                  * my duron 950 before I came back from lunch and
3189                  * killed it.
3190                  *
3191                  *   FIXME: Add a variable to enable this
3192                  * dynamically. */
3193                 /*
3194                 if (!possibly_valid_dynamic_space_pointer((lispobj *)thing)) {
3195                     lose("ptr %x to invalid object %x\n", thing, start);
3196                 }
3197                 */
3198             } else {
3199                 /* Verify that it points to another valid space. */
3200                 if (!to_readonly_space && !to_static_space
3201                     && (thing != (unsigned long)&undefined_tramp)) {
3202                     lose("Ptr %x @ %x sees junk.\n", thing, start);
3203                 }
3204             }
3205         } else {
3206             if (!(fixnump(thing))) {
3207                 /* skip fixnums */
3208                 switch(widetag_of(*start)) {
3209
3210                     /* boxed objects */
3211                 case SIMPLE_VECTOR_WIDETAG:
3212                 case RATIO_WIDETAG:
3213                 case COMPLEX_WIDETAG:
3214                 case SIMPLE_ARRAY_WIDETAG:
3215                 case COMPLEX_BASE_STRING_WIDETAG:
3216 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
3217                 case COMPLEX_CHARACTER_STRING_WIDETAG:
3218 #endif
3219                 case COMPLEX_VECTOR_NIL_WIDETAG:
3220                 case COMPLEX_BIT_VECTOR_WIDETAG:
3221                 case COMPLEX_VECTOR_WIDETAG:
3222                 case COMPLEX_ARRAY_WIDETAG:
3223                 case CLOSURE_HEADER_WIDETAG:
3224                 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
3225                 case VALUE_CELL_HEADER_WIDETAG:
3226                 case SYMBOL_HEADER_WIDETAG:
3227                 case CHARACTER_WIDETAG:
3228 #if N_WORD_BITS == 64
3229                 case SINGLE_FLOAT_WIDETAG:
3230 #endif
3231                 case UNBOUND_MARKER_WIDETAG:
3232                 case INSTANCE_HEADER_WIDETAG:
3233                 case FDEFN_WIDETAG:
3234                     count = 1;
3235                     break;
3236
3237                 case CODE_HEADER_WIDETAG:
3238                     {
3239                         lispobj object = *start;
3240                         struct code *code;
3241                         long nheader_words, ncode_words, nwords;
3242                         lispobj fheaderl;
3243                         struct simple_fun *fheaderp;
3244
3245                         code = (struct code *) start;
3246
3247                         /* Check that it's not in the dynamic space.
3248                          * FIXME: Isn't is supposed to be OK for code
3249                          * objects to be in the dynamic space these days? */
3250                         if (is_in_dynamic_space
3251                             /* It's ok if it's byte compiled code. The trace
3252                              * table offset will be a fixnum if it's x86
3253                              * compiled code - check.
3254                              *
3255                              * FIXME: #^#@@! lack of abstraction here..
3256                              * This line can probably go away now that
3257                              * there's no byte compiler, but I've got
3258                              * too much to worry about right now to try
3259                              * to make sure. -- WHN 2001-10-06 */
3260                             && fixnump(code->trace_table_offset)
3261                             /* Only when enabled */
3262                             && verify_dynamic_code_check) {
3263                             FSHOW((stderr,
3264                                    "/code object at %x in the dynamic space\n",
3265                                    start));
3266                         }
3267
3268                         ncode_words = fixnum_value(code->code_size);
3269                         nheader_words = HeaderValue(object);
3270                         nwords = ncode_words + nheader_words;
3271                         nwords = CEILING(nwords, 2);
3272                         /* Scavenge the boxed section of the code data block */
3273                         verify_space(start + 1, nheader_words - 1);
3274
3275                         /* Scavenge the boxed section of each function
3276                          * object in the code data block. */
3277                         fheaderl = code->entry_points;
3278                         while (fheaderl != NIL) {
3279                             fheaderp =
3280                                 (struct simple_fun *) native_pointer(fheaderl);
3281                             gc_assert(widetag_of(fheaderp->header) == SIMPLE_FUN_HEADER_WIDETAG);
3282                             verify_space(&fheaderp->name, 1);
3283                             verify_space(&fheaderp->arglist, 1);
3284                             verify_space(&fheaderp->type, 1);
3285                             fheaderl = fheaderp->next;
3286                         }
3287                         count = nwords;
3288                         break;
3289                     }
3290
3291                     /* unboxed objects */
3292                 case BIGNUM_WIDETAG:
3293 #if N_WORD_BITS != 64
3294                 case SINGLE_FLOAT_WIDETAG:
3295 #endif
3296                 case DOUBLE_FLOAT_WIDETAG:
3297 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
3298                 case LONG_FLOAT_WIDETAG:
3299 #endif
3300 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
3301                 case COMPLEX_SINGLE_FLOAT_WIDETAG:
3302 #endif
3303 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
3304                 case COMPLEX_DOUBLE_FLOAT_WIDETAG:
3305 #endif
3306 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
3307                 case COMPLEX_LONG_FLOAT_WIDETAG:
3308 #endif
3309                 case SIMPLE_BASE_STRING_WIDETAG:
3310 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
3311                 case SIMPLE_CHARACTER_STRING_WIDETAG:
3312 #endif
3313                 case SIMPLE_BIT_VECTOR_WIDETAG:
3314                 case SIMPLE_ARRAY_NIL_WIDETAG:
3315                 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
3316                 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
3317                 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
3318                 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
3319                 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
3320                 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
3321 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
3322                 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
3323 #endif
3324                 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
3325                 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
3326 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
3327                 case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
3328 #endif
3329 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
3330                 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
3331 #endif
3332 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
3333                 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
3334 #endif
3335 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
3336                 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
3337 #endif
3338 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
3339                 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
3340 #endif
3341 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
3342                 case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
3343 #endif
3344 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
3345                 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
3346 #endif
3347 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
3348                 case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
3349 #endif
3350 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
3351                 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
3352 #endif
3353                 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
3354                 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
3355 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
3356                 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
3357 #endif
3358 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
3359                 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
3360 #endif
3361 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
3362                 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
3363 #endif
3364 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
3365                 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
3366 #endif
3367                 case SAP_WIDETAG:
3368                 case WEAK_POINTER_WIDETAG:
3369                     count = (sizetab[widetag_of(*start)])(start);
3370                     break;
3371
3372                 default:
3373                     gc_abort();
3374                 }
3375             }
3376         }
3377         start += count;
3378         words -= count;
3379     }
3380 }
3381
3382 static void
3383 verify_gc(void)
3384 {
3385     /* FIXME: It would be nice to make names consistent so that
3386      * foo_size meant size *in* *bytes* instead of size in some
3387      * arbitrary units. (Yes, this caused a bug, how did you guess?:-)
3388      * Some counts of lispobjs are called foo_count; it might be good
3389      * to grep for all foo_size and rename the appropriate ones to
3390      * foo_count. */
3391     long read_only_space_size =
3392         (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0)
3393         - (lispobj*)READ_ONLY_SPACE_START;
3394     long static_space_size =
3395         (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0)
3396         - (lispobj*)STATIC_SPACE_START;
3397     struct thread *th;
3398     for_each_thread(th) {
3399     long binding_stack_size =
3400             (lispobj*)SymbolValue(BINDING_STACK_POINTER,th)
3401             - (lispobj*)th->binding_stack_start;
3402         verify_space(th->binding_stack_start, binding_stack_size);
3403     }
3404     verify_space((lispobj*)READ_ONLY_SPACE_START, read_only_space_size);
3405     verify_space((lispobj*)STATIC_SPACE_START   , static_space_size);
3406 }
3407
3408 static void
3409 verify_generation(generation_index_t generation)
3410 {
3411     page_index_t i;
3412
3413     for (i = 0; i < last_free_page; i++) {
3414         if ((page_table[i].allocated != FREE_PAGE_FLAG)
3415             && (page_table[i].bytes_used != 0)
3416             && (page_table[i].gen == generation)) {
3417             page_index_t last_page;
3418             int region_allocation = page_table[i].allocated;
3419
3420             /* This should be the start of a contiguous block */
3421             gc_assert(page_table[i].first_object_offset == 0);
3422
3423             /* Need to find the full extent of this contiguous block in case
3424                objects span pages. */
3425
3426             /* Now work forward until the end of this contiguous area is
3427                found. */
3428             for (last_page = i; ;last_page++)
3429                 /* Check whether this is the last page in this contiguous
3430                  * block. */
3431                 if ((page_table[last_page].bytes_used < PAGE_BYTES)
3432                     /* Or it is PAGE_BYTES and is the last in the block */
3433                     || (page_table[last_page+1].allocated != region_allocation)
3434                     || (page_table[last_page+1].bytes_used == 0)
3435                     || (page_table[last_page+1].gen != generation)
3436                     || (page_table[last_page+1].first_object_offset == 0))
3437                     break;
3438
3439             verify_space(page_address(i), (page_table[last_page].bytes_used
3440                                            + (last_page-i)*PAGE_BYTES)/N_WORD_BYTES);
3441             i = last_page;
3442         }
3443     }
3444 }
3445
3446 /* Check that all the free space is zero filled. */
3447 static void
3448 verify_zero_fill(void)
3449 {
3450     page_index_t page;
3451
3452     for (page = 0; page < last_free_page; page++) {
3453         if (page_table[page].allocated == FREE_PAGE_FLAG) {
3454             /* The whole page should be zero filled. */
3455             long *start_addr = (long *)page_address(page);
3456             long size = 1024;
3457             long i;
3458             for (i = 0; i < size; i++) {
3459                 if (start_addr[i] != 0) {
3460                     lose("free page not zero at %x\n", start_addr + i);
3461                 }
3462             }
3463         } else {
3464             long free_bytes = PAGE_BYTES - page_table[page].bytes_used;
3465             if (free_bytes > 0) {
3466                 long *start_addr = (long *)((unsigned long)page_address(page)
3467                                           + page_table[page].bytes_used);
3468                 long size = free_bytes / N_WORD_BYTES;
3469                 long i;
3470                 for (i = 0; i < size; i++) {
3471                     if (start_addr[i] != 0) {
3472                         lose("free region not zero at %x\n", start_addr + i);
3473                     }
3474                 }
3475             }
3476         }
3477     }
3478 }
3479
3480 /* External entry point for verify_zero_fill */
3481 void
3482 gencgc_verify_zero_fill(void)
3483 {
3484     /* Flush the alloc regions updating the tables. */
3485     gc_alloc_update_all_page_tables();
3486     SHOW("verifying zero fill");
3487     verify_zero_fill();
3488 }
3489
3490 static void
3491 verify_dynamic_space(void)
3492 {
3493     generation_index_t i;
3494
3495     for (i = 0; i <= HIGHEST_NORMAL_GENERATION; i++)
3496         verify_generation(i);
3497
3498     if (gencgc_enable_verify_zero_fill)
3499         verify_zero_fill();
3500 }
3501 \f
3502 /* Write-protect all the dynamic boxed pages in the given generation. */
3503 static void
3504 write_protect_generation_pages(generation_index_t generation)
3505 {
3506     page_index_t start;
3507
3508     gc_assert(generation < SCRATCH_GENERATION);
3509
3510     for (start = 0; start < last_free_page; start++) {
3511         if ((page_table[start].allocated == BOXED_PAGE_FLAG)
3512             && (page_table[start].bytes_used != 0)
3513             && !page_table[start].dont_move
3514             && (page_table[start].gen == generation))  {
3515             void *page_start;
3516             page_index_t last;
3517
3518             /* Note the page as protected in the page tables. */
3519             page_table[start].write_protected = 1;
3520
3521             for (last = start + 1; last < last_free_page; last++) {
3522                 if ((page_table[last].allocated != BOXED_PAGE_FLAG)
3523                     || (page_table[last].bytes_used == 0)
3524                     || page_table[last].dont_move
3525                     || (page_table[last].gen != generation))
3526                   break;
3527                 page_table[last].write_protected = 1;
3528             }
3529
3530             page_start = (void *)page_address(start);
3531
3532             os_protect(page_start,
3533                        PAGE_BYTES * (last - start),
3534                        OS_VM_PROT_READ | OS_VM_PROT_EXECUTE);
3535
3536             start = last;
3537         }
3538     }
3539
3540     if (gencgc_verbose > 1) {
3541         FSHOW((stderr,
3542                "/write protected %d of %d pages in generation %d\n",
3543                count_write_protect_generation_pages(generation),
3544                count_generation_pages(generation),
3545                generation));
3546     }
3547 }
3548
3549 /* Garbage collect a generation. If raise is 0 then the remains of the
3550  * generation are not raised to the next generation. */
3551 static void
3552 garbage_collect_generation(generation_index_t generation, int raise)
3553 {
3554     unsigned long bytes_freed;
3555     page_index_t i;
3556     unsigned long static_space_size;
3557     struct thread *th;
3558     gc_assert(generation <= HIGHEST_NORMAL_GENERATION);
3559
3560     /* The oldest generation can't be raised. */
3561     gc_assert((generation != HIGHEST_NORMAL_GENERATION) || (raise == 0));
3562
3563     /* Initialize the weak pointer list. */
3564     weak_pointers = NULL;
3565
3566     /* When a generation is not being raised it is transported to a
3567      * temporary generation (NUM_GENERATIONS), and lowered when
3568      * done. Set up this new generation. There should be no pages
3569      * allocated to it yet. */
3570     if (!raise) {
3571          gc_assert(generations[SCRATCH_GENERATION].bytes_allocated == 0);
3572     }
3573
3574     /* Set the global src and dest. generations */
3575     from_space = generation;
3576     if (raise)
3577         new_space = generation+1;
3578     else
3579         new_space = SCRATCH_GENERATION;
3580
3581     /* Change to a new space for allocation, resetting the alloc_start_page */
3582     gc_alloc_generation = new_space;
3583     generations[new_space].alloc_start_page = 0;
3584     generations[new_space].alloc_unboxed_start_page = 0;
3585     generations[new_space].alloc_large_start_page = 0;
3586     generations[new_space].alloc_large_unboxed_start_page = 0;
3587
3588     /* Before any pointers are preserved, the dont_move flags on the
3589      * pages need to be cleared. */
3590     for (i = 0; i < last_free_page; i++)
3591         if(page_table[i].gen==from_space)
3592             page_table[i].dont_move = 0;
3593
3594     /* Un-write-protect the old-space pages. This is essential for the
3595      * promoted pages as they may contain pointers into the old-space
3596      * which need to be scavenged. It also helps avoid unnecessary page
3597      * faults as forwarding pointers are written into them. They need to
3598      * be un-protected anyway before unmapping later. */
3599     unprotect_oldspace();
3600
3601     /* Scavenge the stacks' conservative roots. */
3602
3603     /* there are potentially two stacks for each thread: the main
3604      * stack, which may contain Lisp pointers, and the alternate stack.
3605      * We don't ever run Lisp code on the altstack, but it may
3606      * host a sigcontext with lisp objects in it */
3607
3608     /* what we need to do: (1) find the stack pointer for the main
3609      * stack; scavenge it (2) find the interrupt context on the
3610      * alternate stack that might contain lisp values, and scavenge
3611      * that */
3612
3613     /* we assume that none of the preceding applies to the thread that
3614      * initiates GC.  If you ever call GC from inside an altstack
3615      * handler, you will lose. */
3616
3617     /* And if we're saving a core, there's no point in being conservative. */
3618     if (conservative_stack) {
3619         for_each_thread(th) {
3620             void **ptr;
3621             void **esp=(void **)-1;
3622 #ifdef LISP_FEATURE_SB_THREAD
3623             long i,free;
3624             if(th==arch_os_get_current_thread()) {
3625                 /* Somebody is going to burn in hell for this, but casting
3626                  * it in two steps shuts gcc up about strict aliasing. */
3627                 esp = (void **)((void *)&raise);
3628             } else {
3629                 void **esp1;
3630                 free=fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
3631                 for(i=free-1;i>=0;i--) {
3632                     os_context_t *c=th->interrupt_contexts[i];
3633                     esp1 = (void **) *os_context_register_addr(c,reg_SP);
3634                     if (esp1>=(void **)th->control_stack_start &&
3635                         esp1<(void **)th->control_stack_end) {
3636                         if(esp1<esp) esp=esp1;
3637                         for(ptr = (void **)(c+1); ptr>=(void **)c; ptr--) {
3638                             preserve_pointer(*ptr);
3639                         }
3640                     }
3641                 }
3642             }
3643 #else
3644             esp = (void **)((void *)&raise);
3645 #endif
3646             for (ptr = (void **)th->control_stack_end; ptr > esp;  ptr--) {
3647                 preserve_pointer(*ptr);
3648             }
3649         }
3650     }
3651 #ifdef QSHOW
3652     if (gencgc_verbose > 1) {
3653         long num_dont_move_pages = count_dont_move_pages();
3654         fprintf(stderr,
3655                 "/non-movable pages due to conservative pointers = %d (%d bytes)\n",
3656                 num_dont_move_pages,
3657                 num_dont_move_pages * PAGE_BYTES);
3658     }
3659 #endif
3660
3661     /* Scavenge all the rest of the roots. */
3662
3663     /* Scavenge the Lisp functions of the interrupt handlers, taking
3664      * care to avoid SIG_DFL and SIG_IGN. */
3665     for (i = 0; i < NSIG; i++) {
3666         union interrupt_handler handler = interrupt_handlers[i];
3667         if (!ARE_SAME_HANDLER(handler.c, SIG_IGN) &&
3668             !ARE_SAME_HANDLER(handler.c, SIG_DFL)) {
3669             scavenge((lispobj *)(interrupt_handlers + i), 1);
3670         }
3671     }
3672     /* Scavenge the binding stacks. */
3673     {
3674         struct thread *th;
3675         for_each_thread(th) {
3676             long len= (lispobj *)SymbolValue(BINDING_STACK_POINTER,th) -
3677                 th->binding_stack_start;
3678             scavenge((lispobj *) th->binding_stack_start,len);
3679 #ifdef LISP_FEATURE_SB_THREAD
3680             /* do the tls as well */
3681             len=fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) -
3682                 (sizeof (struct thread))/(sizeof (lispobj));
3683             scavenge((lispobj *) (th+1),len);
3684 #endif
3685         }
3686     }
3687
3688     /* The original CMU CL code had scavenge-read-only-space code
3689      * controlled by the Lisp-level variable
3690      * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
3691      * wasn't documented under what circumstances it was useful or
3692      * safe to turn it on, so it's been turned off in SBCL. If you
3693      * want/need this functionality, and can test and document it,
3694      * please submit a patch. */
3695 #if 0
3696     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
3697         unsigned long read_only_space_size =
3698             (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
3699             (lispobj*)READ_ONLY_SPACE_START;
3700         FSHOW((stderr,
3701                "/scavenge read only space: %d bytes\n",
3702                read_only_space_size * sizeof(lispobj)));
3703         scavenge( (lispobj *) READ_ONLY_SPACE_START, read_only_space_size);
3704     }
3705 #endif
3706
3707     /* Scavenge static space. */
3708     static_space_size =
3709         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0) -
3710         (lispobj *)STATIC_SPACE_START;
3711     if (gencgc_verbose > 1) {
3712         FSHOW((stderr,
3713                "/scavenge static space: %d bytes\n",
3714                static_space_size * sizeof(lispobj)));
3715     }
3716     scavenge( (lispobj *) STATIC_SPACE_START, static_space_size);
3717
3718     /* All generations but the generation being GCed need to be
3719      * scavenged. The new_space generation needs special handling as
3720      * objects may be moved in - it is handled separately below. */
3721     scavenge_generations(generation+1, PSEUDO_STATIC_GENERATION);
3722
3723     /* Finally scavenge the new_space generation. Keep going until no
3724      * more objects are moved into the new generation */
3725     scavenge_newspace_generation(new_space);
3726
3727     /* FIXME: I tried reenabling this check when debugging unrelated
3728      * GC weirdness ca. sbcl-0.6.12.45, and it failed immediately.
3729      * Since the current GC code seems to work well, I'm guessing that
3730      * this debugging code is just stale, but I haven't tried to
3731      * figure it out. It should be figured out and then either made to
3732      * work or just deleted. */
3733 #define RESCAN_CHECK 0
3734 #if RESCAN_CHECK
3735     /* As a check re-scavenge the newspace once; no new objects should
3736      * be found. */
3737     {
3738         long old_bytes_allocated = bytes_allocated;
3739         long bytes_allocated;
3740
3741         /* Start with a full scavenge. */
3742         scavenge_newspace_generation_one_scan(new_space);
3743
3744         /* Flush the current regions, updating the tables. */
3745         gc_alloc_update_all_page_tables();
3746
3747         bytes_allocated = bytes_allocated - old_bytes_allocated;
3748
3749         if (bytes_allocated != 0) {
3750             lose("Rescan of new_space allocated %d more bytes.\n",
3751                  bytes_allocated);
3752         }
3753     }
3754 #endif
3755
3756     scan_weak_pointers();
3757
3758     /* Flush the current regions, updating the tables. */
3759     gc_alloc_update_all_page_tables();
3760
3761     /* Free the pages in oldspace, but not those marked dont_move. */
3762     bytes_freed = free_oldspace();
3763
3764     /* If the GC is not raising the age then lower the generation back
3765      * to its normal generation number */
3766     if (!raise) {
3767         for (i = 0; i < last_free_page; i++)
3768             if ((page_table[i].bytes_used != 0)
3769                 && (page_table[i].gen == SCRATCH_GENERATION))
3770                 page_table[i].gen = generation;
3771         gc_assert(generations[generation].bytes_allocated == 0);
3772         generations[generation].bytes_allocated =
3773             generations[SCRATCH_GENERATION].bytes_allocated;
3774         generations[SCRATCH_GENERATION].bytes_allocated = 0;
3775     }
3776
3777     /* Reset the alloc_start_page for generation. */
3778     generations[generation].alloc_start_page = 0;
3779     generations[generation].alloc_unboxed_start_page = 0;
3780     generations[generation].alloc_large_start_page = 0;
3781     generations[generation].alloc_large_unboxed_start_page = 0;
3782
3783     if (generation >= verify_gens) {
3784         if (gencgc_verbose)
3785             SHOW("verifying");
3786         verify_gc();
3787         verify_dynamic_space();
3788     }
3789
3790     /* Set the new gc trigger for the GCed generation. */
3791     generations[generation].gc_trigger =
3792         generations[generation].bytes_allocated
3793         + generations[generation].bytes_consed_between_gc;
3794
3795     if (raise)
3796         generations[generation].num_gc = 0;
3797     else
3798         ++generations[generation].num_gc;
3799 }
3800
3801 /* Update last_free_page, then SymbolValue(ALLOCATION_POINTER). */
3802 long
3803 update_dynamic_space_free_pointer(void)
3804 {
3805     page_index_t last_page = -1, i;
3806
3807     for (i = 0; i < last_free_page; i++)
3808         if ((page_table[i].allocated != FREE_PAGE_FLAG)
3809             && (page_table[i].bytes_used != 0))
3810             last_page = i;
3811
3812     last_free_page = last_page+1;
3813
3814     SetSymbolValue(ALLOCATION_POINTER,
3815                    (lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES),0);
3816     return 0; /* dummy value: return something ... */
3817 }
3818
3819 /* GC all generations newer than last_gen, raising the objects in each
3820  * to the next older generation - we finish when all generations below
3821  * last_gen are empty.  Then if last_gen is due for a GC, or if
3822  * last_gen==NUM_GENERATIONS (the scratch generation?  eh?) we GC that
3823  * too.  The valid range for last_gen is: 0,1,...,NUM_GENERATIONS.
3824  *
3825  * We stop collecting at gencgc_oldest_gen_to_gc, even if this is less than
3826  * last_gen (oh, and note that by default it is NUM_GENERATIONS-1) */
3827
3828 void
3829 collect_garbage(generation_index_t last_gen)
3830 {
3831     generation_index_t gen = 0, i;
3832     int raise;
3833     int gen_to_wp;
3834
3835     FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen));
3836
3837     if (last_gen > HIGHEST_NORMAL_GENERATION+1) {
3838         FSHOW((stderr,
3839                "/collect_garbage: last_gen = %d, doing a level 0 GC\n",
3840                last_gen));
3841         last_gen = 0;
3842     }
3843
3844     /* Flush the alloc regions updating the tables. */
3845     gc_alloc_update_all_page_tables();
3846
3847     /* Verify the new objects created by Lisp code. */
3848     if (pre_verify_gen_0) {
3849         FSHOW((stderr, "pre-checking generation 0\n"));
3850         verify_generation(0);
3851     }
3852
3853     if (gencgc_verbose > 1)
3854         print_generation_stats(0);
3855
3856     do {
3857         /* Collect the generation. */
3858
3859         if (gen >= gencgc_oldest_gen_to_gc) {
3860             /* Never raise the oldest generation. */
3861             raise = 0;
3862         } else {
3863             raise =
3864                 (gen < last_gen)
3865                 || (generations[gen].num_gc >= generations[gen].trigger_age);
3866         }
3867
3868         if (gencgc_verbose > 1) {
3869             FSHOW((stderr,
3870                    "starting GC of generation %d with raise=%d alloc=%d trig=%d GCs=%d\n",
3871                    gen,
3872                    raise,
3873                    generations[gen].bytes_allocated,
3874                    generations[gen].gc_trigger,
3875                    generations[gen].num_gc));
3876         }
3877
3878         /* If an older generation is being filled, then update its
3879          * memory age. */
3880         if (raise == 1) {
3881             generations[gen+1].cum_sum_bytes_allocated +=
3882                 generations[gen+1].bytes_allocated;
3883         }
3884
3885         garbage_collect_generation(gen, raise);
3886
3887         /* Reset the memory age cum_sum. */
3888         generations[gen].cum_sum_bytes_allocated = 0;
3889
3890         if (gencgc_verbose > 1) {
3891             FSHOW((stderr, "GC of generation %d finished:\n", gen));
3892             print_generation_stats(0);
3893         }
3894
3895         gen++;
3896     } while ((gen <= gencgc_oldest_gen_to_gc)
3897              && ((gen < last_gen)
3898                  || ((gen <= gencgc_oldest_gen_to_gc)
3899                      && raise
3900                      && (generations[gen].bytes_allocated
3901                          > generations[gen].gc_trigger)
3902                      && (gen_av_mem_age(gen)
3903                          > generations[gen].min_av_mem_age))));
3904
3905     /* Now if gen-1 was raised all generations before gen are empty.
3906      * If it wasn't raised then all generations before gen-1 are empty.
3907      *
3908      * Now objects within this gen's pages cannot point to younger
3909      * generations unless they are written to. This can be exploited
3910      * by write-protecting the pages of gen; then when younger
3911      * generations are GCed only the pages which have been written
3912      * need scanning. */
3913     if (raise)
3914         gen_to_wp = gen;
3915     else
3916         gen_to_wp = gen - 1;
3917
3918     /* There's not much point in WPing pages in generation 0 as it is
3919      * never scavenged (except promoted pages). */
3920     if ((gen_to_wp > 0) && enable_page_protection) {
3921         /* Check that they are all empty. */
3922         for (i = 0; i < gen_to_wp; i++) {
3923             if (generations[i].bytes_allocated)
3924                 lose("trying to write-protect gen. %d when gen. %d nonempty\n",
3925                      gen_to_wp, i);
3926         }
3927         write_protect_generation_pages(gen_to_wp);
3928     }
3929
3930     /* Set gc_alloc() back to generation 0. The current regions should
3931      * be flushed after the above GCs. */
3932     gc_assert((boxed_region.free_pointer - boxed_region.start_addr) == 0);
3933     gc_alloc_generation = 0;
3934
3935     update_dynamic_space_free_pointer();
3936     auto_gc_trigger = bytes_allocated + bytes_consed_between_gcs;
3937     if(gencgc_verbose)
3938         fprintf(stderr,"Next gc when %ld bytes have been consed\n",
3939                 auto_gc_trigger);
3940     SHOW("returning from collect_garbage");
3941 }
3942
3943 /* This is called by Lisp PURIFY when it is finished. All live objects
3944  * will have been moved to the RO and Static heaps. The dynamic space
3945  * will need a full re-initialization. We don't bother having Lisp
3946  * PURIFY flush the current gc_alloc() region, as the page_tables are
3947  * re-initialized, and every page is zeroed to be sure. */
3948 void
3949 gc_free_heap(void)
3950 {
3951     page_index_t page;
3952
3953     if (gencgc_verbose > 1)
3954         SHOW("entering gc_free_heap");
3955
3956     for (page = 0; page < NUM_PAGES; page++) {
3957         /* Skip free pages which should already be zero filled. */
3958         if (page_table[page].allocated != FREE_PAGE_FLAG) {
3959             void *page_start, *addr;
3960
3961             /* Mark the page free. The other slots are assumed invalid
3962              * when it is a FREE_PAGE_FLAG and bytes_used is 0 and it
3963              * should not be write-protected -- except that the
3964              * generation is used for the current region but it sets
3965              * that up. */
3966             page_table[page].allocated = FREE_PAGE_FLAG;
3967             page_table[page].bytes_used = 0;
3968
3969             /* Zero the page. */
3970             page_start = (void *)page_address(page);
3971
3972             /* First, remove any write-protection. */
3973             os_protect(page_start, PAGE_BYTES, OS_VM_PROT_ALL);
3974             page_table[page].write_protected = 0;
3975
3976             os_invalidate(page_start,PAGE_BYTES);
3977             addr = os_validate(page_start,PAGE_BYTES);
3978             if (addr == NULL || addr != page_start) {
3979                 lose("gc_free_heap: page moved, 0x%08x ==> 0x%08x\n",
3980                      page_start,
3981                      addr);
3982             }
3983         } else if (gencgc_zero_check_during_free_heap) {
3984             /* Double-check that the page is zero filled. */
3985             long *page_start;
3986             page_index_t i;
3987             gc_assert(page_table[page].allocated == FREE_PAGE_FLAG);
3988             gc_assert(page_table[page].bytes_used == 0);
3989             page_start = (long *)page_address(page);
3990             for (i=0; i<1024; i++) {
3991                 if (page_start[i] != 0) {
3992                     lose("free region not zero at %x\n", page_start + i);
3993                 }
3994             }
3995         }
3996     }
3997
3998     bytes_allocated = 0;
3999
4000     /* Initialize the generations. */
4001     for (page = 0; page < NUM_GENERATIONS; page++) {
4002         generations[page].alloc_start_page = 0;
4003         generations[page].alloc_unboxed_start_page = 0;
4004         generations[page].alloc_large_start_page = 0;
4005         generations[page].alloc_large_unboxed_start_page = 0;
4006         generations[page].bytes_allocated = 0;
4007         generations[page].gc_trigger = 2000000;
4008         generations[page].num_gc = 0;
4009         generations[page].cum_sum_bytes_allocated = 0;
4010     }
4011
4012     if (gencgc_verbose > 1)
4013         print_generation_stats(0);
4014
4015     /* Initialize gc_alloc(). */
4016     gc_alloc_generation = 0;
4017
4018     gc_set_region_empty(&boxed_region);
4019     gc_set_region_empty(&unboxed_region);
4020
4021     last_free_page = 0;
4022     SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base),0);
4023
4024     if (verify_after_free_heap) {
4025         /* Check whether purify has left any bad pointers. */
4026         if (gencgc_verbose)
4027             SHOW("checking after free_heap\n");
4028         verify_gc();
4029     }
4030 }
4031 \f
4032 void
4033 gc_init(void)
4034 {
4035     page_index_t i;
4036
4037     gc_init_tables();
4038     scavtab[SIMPLE_VECTOR_WIDETAG] = scav_vector;
4039     scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
4040     transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed_large;
4041
4042     heap_base = (void*)DYNAMIC_SPACE_START;
4043
4044     /* Initialize each page structure. */
4045     for (i = 0; i < NUM_PAGES; i++) {
4046         /* Initialize all pages as free. */
4047         page_table[i].allocated = FREE_PAGE_FLAG;
4048         page_table[i].bytes_used = 0;
4049
4050         /* Pages are not write-protected at startup. */
4051         page_table[i].write_protected = 0;
4052     }
4053
4054     bytes_allocated = 0;
4055
4056     /* Initialize the generations.
4057      *
4058      * FIXME: very similar to code in gc_free_heap(), should be shared */
4059     for (i = 0; i < NUM_GENERATIONS; i++) {
4060         generations[i].alloc_start_page = 0;
4061         generations[i].alloc_unboxed_start_page = 0;
4062         generations[i].alloc_large_start_page = 0;
4063         generations[i].alloc_large_unboxed_start_page = 0;
4064         generations[i].bytes_allocated = 0;
4065         generations[i].gc_trigger = 2000000;
4066         generations[i].num_gc = 0;
4067         generations[i].cum_sum_bytes_allocated = 0;
4068         /* the tune-able parameters */
4069         generations[i].bytes_consed_between_gc = 2000000;
4070         generations[i].trigger_age = 1;
4071         generations[i].min_av_mem_age = 0.75;
4072     }
4073
4074     /* Initialize gc_alloc. */
4075     gc_alloc_generation = 0;
4076     gc_set_region_empty(&boxed_region);
4077     gc_set_region_empty(&unboxed_region);
4078
4079     last_free_page = 0;
4080 }
4081
4082 /*  Pick up the dynamic space from after a core load.
4083  *
4084  *  The ALLOCATION_POINTER points to the end of the dynamic space.
4085  */
4086
4087 static void
4088 gencgc_pickup_dynamic(void)
4089 {
4090     page_index_t page = 0;
4091     long alloc_ptr = SymbolValue(ALLOCATION_POINTER,0);
4092     lispobj *prev=(lispobj *)page_address(page);
4093     generation_index_t gen = PSEUDO_STATIC_GENERATION;
4094
4095     do {
4096         lispobj *first,*ptr= (lispobj *)page_address(page);
4097         page_table[page].allocated = BOXED_PAGE_FLAG;
4098         page_table[page].gen = gen;
4099         page_table[page].bytes_used = PAGE_BYTES;
4100         page_table[page].large_object = 0;
4101         page_table[page].write_protected = 0;
4102         page_table[page].write_protected_cleared = 0;
4103         page_table[page].dont_move = 0;
4104
4105         if (!gencgc_partial_pickup) {
4106             first=gc_search_space(prev,(ptr+2)-prev,ptr);
4107             if(ptr == first)  prev=ptr;
4108             page_table[page].first_object_offset =
4109                 (void *)prev - page_address(page);
4110         }
4111         page++;
4112     } while ((long)page_address(page) < alloc_ptr);
4113
4114     last_free_page = page;
4115
4116     generations[gen].bytes_allocated = PAGE_BYTES*page;
4117     bytes_allocated = PAGE_BYTES*page;
4118
4119     gc_alloc_update_all_page_tables();
4120     write_protect_generation_pages(gen);
4121 }
4122
4123 void
4124 gc_initialize_pointers(void)
4125 {
4126     gencgc_pickup_dynamic();
4127 }
4128
4129
4130 \f
4131
4132 /* alloc(..) is the external interface for memory allocation. It
4133  * allocates to generation 0. It is not called from within the garbage
4134  * collector as it is only external uses that need the check for heap
4135  * size (GC trigger) and to disable the interrupts (interrupts are
4136  * always disabled during a GC).
4137  *
4138  * The vops that call alloc(..) assume that the returned space is zero-filled.
4139  * (E.g. the most significant word of a 2-word bignum in MOVE-FROM-UNSIGNED.)
4140  *
4141  * The check for a GC trigger is only performed when the current
4142  * region is full, so in most cases it's not needed. */
4143
4144 char *
4145 alloc(long nbytes)
4146 {
4147     struct thread *thread=arch_os_get_current_thread();
4148     struct alloc_region *region=
4149 #ifdef LISP_FEATURE_SB_THREAD
4150         thread ? &(thread->alloc_region) : &boxed_region;
4151 #else
4152         &boxed_region;
4153 #endif
4154     void *new_obj;
4155     void *new_free_pointer;
4156     gc_assert(nbytes>0);
4157     /* Check for alignment allocation problems. */
4158     gc_assert((((unsigned long)region->free_pointer & LOWTAG_MASK) == 0)
4159               && ((nbytes & LOWTAG_MASK) == 0));
4160 #if 0
4161     if(all_threads)
4162         /* there are a few places in the C code that allocate data in the
4163          * heap before Lisp starts.  This is before interrupts are enabled,
4164          * so we don't need to check for pseudo-atomic */
4165 #ifdef LISP_FEATURE_SB_THREAD
4166         if(!SymbolValue(PSEUDO_ATOMIC_ATOMIC,th)) {
4167             register u32 fs;
4168             fprintf(stderr, "fatal error in thread 0x%x, tid=%ld\n",
4169                     th,th->os_thread);
4170             __asm__("movl %fs,%0" : "=r" (fs)  : );
4171             fprintf(stderr, "fs is %x, th->tls_cookie=%x \n",
4172                     debug_get_fs(),th->tls_cookie);
4173             lose("If you see this message before 2004.01.31, mail details to sbcl-devel\n");
4174         }
4175 #else
4176     gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th));
4177 #endif
4178 #endif
4179
4180     /* maybe we can do this quickly ... */
4181     new_free_pointer = region->free_pointer + nbytes;
4182     if (new_free_pointer <= region->end_addr) {
4183         new_obj = (void*)(region->free_pointer);
4184         region->free_pointer = new_free_pointer;
4185         return(new_obj);        /* yup */
4186     }
4187
4188     /* we have to go the long way around, it seems.  Check whether
4189      * we should GC in the near future
4190      */
4191     if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) {
4192         gc_assert(fixnum_value(SymbolValue(PSEUDO_ATOMIC_ATOMIC,thread)));
4193         /* Don't flood the system with interrupts if the need to gc is
4194          * already noted. This can happen for example when SUB-GC
4195          * allocates or after a gc triggered in a WITHOUT-GCING. */
4196         if (SymbolValue(GC_PENDING,thread) == NIL) {
4197             /* set things up so that GC happens when we finish the PA
4198              * section */
4199             SetSymbolValue(GC_PENDING,T,thread);
4200             if (SymbolValue(GC_INHIBIT,thread) == NIL)
4201                 arch_set_pseudo_atomic_interrupted(0);
4202         }
4203     }
4204     new_obj = gc_alloc_with_region(nbytes,0,region,0);
4205     return (new_obj);
4206 }
4207 \f
4208 /*
4209  * shared support for the OS-dependent signal handlers which
4210  * catch GENCGC-related write-protect violations
4211  */
4212
4213 void unhandled_sigmemoryfault(void);
4214
4215 /* Depending on which OS we're running under, different signals might
4216  * be raised for a violation of write protection in the heap. This
4217  * function factors out the common generational GC magic which needs
4218  * to invoked in this case, and should be called from whatever signal
4219  * handler is appropriate for the OS we're running under.
4220  *
4221  * Return true if this signal is a normal generational GC thing that
4222  * we were able to handle, or false if it was abnormal and control
4223  * should fall through to the general SIGSEGV/SIGBUS/whatever logic. */
4224
4225 int
4226 gencgc_handle_wp_violation(void* fault_addr)
4227 {
4228     page_index_t page_index = find_page_index(fault_addr);
4229
4230 #ifdef QSHOW_SIGNALS
4231     FSHOW((stderr, "heap WP violation? fault_addr=%x, page_index=%d\n",
4232            fault_addr, page_index));
4233 #endif
4234
4235     /* Check whether the fault is within the dynamic space. */
4236     if (page_index == (-1)) {
4237
4238         /* It can be helpful to be able to put a breakpoint on this
4239          * case to help diagnose low-level problems. */
4240         unhandled_sigmemoryfault();
4241
4242         /* not within the dynamic space -- not our responsibility */
4243         return 0;
4244
4245     } else {
4246         if (page_table[page_index].write_protected) {
4247             /* Unprotect the page. */
4248             os_protect(page_address(page_index), PAGE_BYTES, OS_VM_PROT_ALL);
4249             page_table[page_index].write_protected_cleared = 1;
4250             page_table[page_index].write_protected = 0;
4251         } else {
4252             /* The only acceptable reason for this signal on a heap
4253              * access is that GENCGC write-protected the page.
4254              * However, if two CPUs hit a wp page near-simultaneously,
4255              * we had better not have the second one lose here if it
4256              * does this test after the first one has already set wp=0
4257              */
4258             if(page_table[page_index].write_protected_cleared != 1)
4259                 lose("fault in heap page not marked as write-protected\n");
4260         }
4261         /* Don't worry, we can handle it. */
4262         return 1;
4263     }
4264 }
4265 /* This is to be called when we catch a SIGSEGV/SIGBUS, determine that
4266  * it's not just a case of the program hitting the write barrier, and
4267  * are about to let Lisp deal with it. It's basically just a
4268  * convenient place to set a gdb breakpoint. */
4269 void
4270 unhandled_sigmemoryfault()
4271 {}
4272
4273 void gc_alloc_update_all_page_tables(void)
4274 {
4275     /* Flush the alloc regions updating the tables. */
4276     struct thread *th;
4277     for_each_thread(th)
4278         gc_alloc_update_page_tables(0, &th->alloc_region);
4279     gc_alloc_update_page_tables(1, &unboxed_region);
4280     gc_alloc_update_page_tables(0, &boxed_region);
4281 }
4282
4283 void
4284 gc_set_region_empty(struct alloc_region *region)
4285 {
4286     region->first_page = 0;
4287     region->last_page = -1;
4288     region->start_addr = page_address(0);
4289     region->free_pointer = page_address(0);
4290     region->end_addr = page_address(0);
4291 }
4292
4293 /* Things to do before doing a final GC before saving a core (without
4294  * purify).
4295  *
4296  * + Pages in large_object pages aren't moved by the GC, so we need to
4297  *   unset that flag from all pages.
4298  * + The pseudo-static generation isn't normally collected, but it seems
4299  *   reasonable to collect it at least when saving a core. So move the
4300  *   pages to a normal generation.
4301  */
4302 static void
4303 prepare_for_final_gc ()
4304 {
4305     page_index_t i;
4306     for (i = 0; i < last_free_page; i++) {
4307         page_table[i].large_object = 0;
4308         if (page_table[i].gen == PSEUDO_STATIC_GENERATION) {
4309             int used = page_table[i].bytes_used;
4310             page_table[i].gen = HIGHEST_NORMAL_GENERATION;
4311             generations[PSEUDO_STATIC_GENERATION].bytes_allocated -= used;
4312             generations[HIGHEST_NORMAL_GENERATION].bytes_allocated += used;
4313         }
4314     }
4315 }
4316
4317
4318 /* Do a non-conservative GC, and then save a core with the initial
4319  * function being set to the value of the static symbol
4320  * SB!VM:RESTART-LISP-FUNCTION */
4321 void
4322 gc_and_save(char *filename)
4323 {
4324     FILE *file = open_core_for_saving(filename);
4325     if (!file) {
4326         perror(filename);
4327         return;
4328     }
4329     conservative_stack = 0;
4330
4331     /* The filename might come from Lisp, and be moved by the now
4332      * non-conservative GC. */
4333     filename = strdup(filename);
4334
4335     /* Collect twice: once into relatively high memory, and then back
4336      * into low memory. This compacts the retained data into the lower
4337      * pages, minimizing the size of the core file.
4338      */
4339     prepare_for_final_gc();
4340     gencgc_alloc_start_page = last_free_page;
4341     collect_garbage(HIGHEST_NORMAL_GENERATION+1);
4342
4343     prepare_for_final_gc();
4344     gencgc_alloc_start_page = -1;
4345     collect_garbage(HIGHEST_NORMAL_GENERATION+1);
4346
4347     save_to_filehandle(file, filename, SymbolValue(RESTART_LISP_FUNCTION,0));
4348     /* Oops. Save still managed to fail. Since we've mangled the stack
4349      * beyond hope, there's not much we can do.
4350      * (beyond FUNCALLing RESTART_LISP_FUNCTION, but I suspect that's
4351      * going to be rather unsatisfactory too... */
4352     lose("Attempt to save core after non-conservative GC failed.\n");
4353 }