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