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