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