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