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