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