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