/[cmucl]/src/lisp/gencgc.c
ViewVC logotype

Contents of /src/lisp/gencgc.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Wed Dec 31 18:07:42 1997 UTC (16 years, 3 months ago) by dtc
Branch: MAIN
Changes since 1.7: +25 -9 lines
File MIME type: text/plain
Enhance scavenge_thread_stacks to only scavenge the live portion of
the saved stack vectors.
1 dtc 1.1 /*
2     * Generational Conservative Garbage Collector for CMUCL x86.
3     *
4     * This code was written by Douglas T. Crosher, based on Public Domain
5     * codes from Carnegie Mellon University. This code has been placed in
6     * the public domain, and is provided 'as is'.
7     *
8 dtc 1.8 * Douglas Crosher, 1996, 1997, 1998.
9 dtc 1.1 *
10 dtc 1.8 * $Header: /tiger/var/lib/cvsroots/cmucl/src/lisp/gencgc.c,v 1.8 1997/12/31 18:07:42 dtc Exp $
11 dtc 1.1 * */
12    
13     #include <stdio.h>
14     #include <signal.h>
15     #include "lisp.h"
16     #include "internals.h"
17     #include "os.h"
18     #include "globals.h"
19     #include "interrupt.h"
20     #include "validate.h"
21     #include "lispregs.h"
22    
23     #include "gencgc.h"
24    
25     #define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
26     __FILE__, __LINE__)
27    
28 dtc 1.3 #if 0
29 dtc 1.1 #define gc_assert(ex) do { \
30     if (!(ex)) gc_abort(); \
31     } while (0)
32     #else
33     #define gc_assert(ex)
34     #endif
35    
36    
37     /* The number of generations, an extra is added to this for use as a
38     temp. */
39     #define NUM_GENERATIONS 6
40    
41     /* Debugging variables. */
42    
43 dtc 1.6 /* The verbose level. All non-error messages are disabled at level 0;
44     and only a few rare messages are printed at level 1. */
45     unsigned gencgc_verbose = 0;
46 dtc 1.1
47     /* To enable the use of page protection to help avoid the scavenging
48     of pages that don't have pointers to younger generations. */
49     boolean enable_page_protection = TRUE;
50    
51     /* Hunt for pointers to old-space, when GCing generations >=
52     verify_gen. Set to NUM_GENERATIONS to disable. */
53 dtc 1.3 int verify_gens = NUM_GENERATIONS;
54 dtc 1.1
55     /* Enable a pre-scan verify of generation 0 before it's GCed */
56     boolean pre_verify_gen_0 = FALSE;
57    
58 dtc 1.3 /*
59     * Enable checking for bad pointers after gc_free_heap called
60     * from purify
61     */
62     boolean verify_after_free_heap = FALSE;
63    
64 dtc 1.1 /* Enable the printing of a note when code objects are found in the
65     dynamic space during a heap verify. */
66     boolean verify_dynamic_code_check = FALSE;
67    
68     /* Enable the checking of code objects for fixup errors after they are
69     transported. */
70 dtc 1.3 boolean check_code_fixups = FALSE;
71 dtc 1.1
72     /* To enable unmapping of a page and re-mmaping it to have it zero
73     filled. */
74     #if defined(__FreeBSD__)
75     /* Note: this can waste a lot of swap on FreeBSD so don't unmap. */
76     boolean gencgc_unmap_zero = FALSE;
77     #else
78     boolean gencgc_unmap_zero = TRUE;
79     #endif
80    
81     /* Enable checking that newly allocated regions are zero filled. */
82     boolean gencgc_zero_check = FALSE;
83    
84 dtc 1.3 /*
85     * Enable checking that free pages are zero filled during gc_free_heap
86     * called after purify.
87     */
88     boolean gencgc_zero_check_during_free_heap = FALSE;
89    
90 dtc 1.1 /* The minimum size for a large object. */
91     unsigned large_object_size = 4*4096;
92    
93     /* Enable the filtering of stack/register pointers. This could reduce
94     the number of invalid pointers accepted. It will probably degrades
95     interrupt safety during object initialisation. */
96     boolean enable_pointer_filter = TRUE;
97    
98    
99     /* The total bytes allocated. Seen by (dynamic-usage) */
100     unsigned long bytes_allocated = 0;
101     static unsigned long auto_gc_trigger = 0;
102    
103     /* The src. and dest. generations. Set before a GC starts scavenging */
104     static int from_space;
105     static int new_space;
106    
107    
108     /* GC structures and variables.*/
109    
110     #define PAGE_BYTES 4096
111    
112     /* An array of page structures is statically allocated.
113     This helps quickly map between an address its page structure.
114     NUM_PAGES is set from the size of the dynamic space. */
115     struct page page_table[NUM_PAGES];
116    
117     /* To map addresses to page structures the address of the first page
118     is needed. */
119     static void *heap_base = NULL;
120    
121     /* Calculate the start address for the given page number. */
122     inline void
123     *page_address(int page_num)
124     {
125     return (heap_base + (page_num * 4096));
126     }
127    
128     /* Find the page index within the page_table for the given
129     address. Returns -1 on failure. */
130     inline int
131     find_page_index(void *addr)
132     {
133     int index = addr-heap_base;
134    
135     if (index >= 0) {
136     index = ((unsigned int)index)/4096;
137     if (index < NUM_PAGES)
138     return (index);
139     }
140    
141     return (-1);
142     }
143    
144    
145     /* A structure to hold the state of a generation */
146     struct generation {
147    
148     /* The first page that gc_alloc checks on its next call. */
149     int alloc_start_page;
150    
151     /* The first page that gc_alloc_unboxed checks on its next call. */
152     int alloc_unboxed_start_page;
153    
154     /* The first page that gc_alloc_large (boxed) considers on its next
155     call. Although it always allocates after the boxed_region. */
156     int alloc_large_start_page;
157    
158     /* The first page that gc_alloc_large (unboxed) considers on its
159     next call. Although it always allocates after the
160     current_unboxed_region. */
161     int alloc_large_unboxed_start_page;
162    
163     /* The bytes allocate to this generation. */
164     int bytes_allocated;
165    
166     /* The number of bytes at which to trigger a GC */
167     int gc_trigger;
168    
169     /* To calculate a new level for gc_trigger */
170     int bytes_consed_between_gc;
171    
172     /* The number of GCs since the last raise. */
173     int num_gc;
174    
175     /* The average age at after which a GC will raise objects to the
176     next generation. */
177     int trigger_age;
178    
179     /* The cumulative sum of the bytes allocated to this generation. It is
180     cleared after a GC on this generations, and update before new
181     objects are added from a GC of a younger generation. Dividing by
182     the bytes_allocated will give the average age of the memory in
183     this generation since its last GC. */
184     int cum_sum_bytes_allocated;
185    
186     /* A minimum average memory age before a GC will occur helps
187     prevent a GC when a large number of new live objects have been
188     added, in which case a GC could be a waste of time. */
189     double min_av_mem_age;
190     };
191    
192     /* An array of generation structures. There needs to be one more
193     generation structure than actual generations as the oldest
194     generations is temporarily raised then lowered. */
195     static struct generation generations[NUM_GENERATIONS+1];
196    
197     /* The oldest generation that is will currently be GCed by default.
198     Valid values are: 0, 1, ... (NUM_GENERATIONS-1)
199    
200     The default of (NUM_GENERATIONS-1) enables GC on all generations.
201    
202     Setting this to 0 effectively disables the generational nature of
203     the GC. In some applications generational GC may not be useful
204     because there are no long-lived objects.
205    
206     An intermediate value could be handy after moving long-lived data
207     into an older generation so an unnecessary GC of this long-lived
208     data can be avoided. */
209     unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS-1;
210    
211    
212     /* The maximum free page in the heap is maintained and used to update
213     ALLOCATION_POINTER which is used by the room function
214     to limit its search of the heap. XX Gencgc obviously needs to be
215     better integrated with the lisp code. */
216     static int last_free_page;
217     static int last_used_page = 0;
218    
219    
220    
221     /* Misc. heap functions. */
222    
223     /* Count the number of pages write protected within the given
224     generation */
225     static int
226     count_write_protect_generation_pages(int generation)
227     {
228     int i;
229     int cnt = 0;
230    
231     for (i = 0; i < last_free_page; i++)
232     if ((page_table[i].allocated != FREE_PAGE)
233     && (page_table[i].gen == generation)
234     && (page_table[i].write_protected == 1))
235     cnt++;
236     return(cnt);
237     }
238    
239     /* Count the number of pages within the given generation */
240     static int
241     count_generation_pages(int generation)
242     {
243     int i;
244     int cnt = 0;
245    
246     for (i = 0; i < last_free_page; i++)
247     if ((page_table[i].allocated != 0)
248     && (page_table[i].gen == generation))
249     cnt++;
250     return(cnt);
251     }
252    
253     /* Count the number of dont_move pages. */
254     static int
255     count_dont_move_pages(void)
256     {
257     int i;
258     int cnt = 0;
259    
260     for (i = 0; i < last_free_page; i++)
261     if ((page_table[i].allocated != 0)
262     && (page_table[i].dont_move != 0))
263     cnt++;
264     return(cnt);
265     }
266    
267     /* Work through the pages and add up the number of bytes used for the
268     given generation. */
269     static int
270     generation_bytes_allocated (int gen)
271     {
272     int i;
273     int bytes_allocated = 0;
274    
275     for (i = 0; i < last_free_page; i++) {
276     if ((page_table[i].allocated != 0) && (page_table[i].gen == gen))
277     bytes_allocated += page_table[i].bytes_used;
278     }
279     return (bytes_allocated);
280     }
281    
282     /* Return the average age of the memory in a generation. */
283     static double
284     gen_av_mem_age(int gen)
285     {
286     if (generations[gen].bytes_allocated == 0)
287     return (0.0);
288    
289     return (((double)generations[gen].cum_sum_bytes_allocated)/((double)generations[gen].bytes_allocated));
290     }
291    
292     /* The verbose argument controls how much to print out: 0 for normal
293     level of detail; 1 for debugging. */
294     static void
295     print_generation_stats(int verbose)
296     {
297     int i, gens;
298    
299     /* Number of generations to print out. */
300     if (verbose)
301     gens = NUM_GENERATIONS+1;
302     else
303     gens = NUM_GENERATIONS;
304    
305     /* Print the heap stats */
306     fprintf(stderr," Generation Boxed Unboxed LB LUB Alloc Waste Trig WP GCs Mem-age\n");
307    
308     for (i = 0; i < gens; i++) {
309     int j;
310     int boxed_cnt = 0;
311     int unboxed_cnt = 0;
312     int large_boxed_cnt = 0;
313     int large_unboxed_cnt = 0;
314    
315     for (j = 0; j < last_free_page; j++)
316     if (page_table[j].gen == i) {
317     /* Count the number of boxed pages within the given generation */
318     if (page_table[j].allocated == BOXED_PAGE)
319     if (page_table[j].large_object)
320     large_boxed_cnt++;
321     else
322     boxed_cnt++;
323    
324     /* Count the number of unboxed pages within the given generation */
325     if (page_table[j].allocated == UNBOXED_PAGE)
326     if (page_table[j].large_object)
327     large_unboxed_cnt++;
328     else
329     unboxed_cnt++;
330     }
331    
332     gc_assert(generations[i].bytes_allocated == generation_bytes_allocated(i));
333     fprintf(stderr," %8d: %5d %5d %5d %5d %8d %5d %8d %4d %3d %7.4lf\n",
334     i,
335     boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt,
336     generations[i].bytes_allocated,
337     (count_generation_pages(i)*4096 - generations[i].bytes_allocated),
338     generations[i].gc_trigger,
339     count_write_protect_generation_pages(i),
340     generations[i].num_gc,
341     gen_av_mem_age(i));
342     }
343     fprintf(stderr," Total bytes alloc=%d\n", bytes_allocated);
344     }
345    
346    
347    
348     /* Allocation routines */
349    
350     /* To support quick and inline allocation, regions of memory can be
351     allocated and then allocated from with just a free pointer and a
352     check against an end address.
353    
354     Since objects can be allocated to spaces with different properties
355     e.g. boxed/unboxed, generation, ages; there may need to be many
356     allocation regions.
357    
358     Each allocation region may be start within a partly used page.
359     Many features of memory use are noted on a page wise basis,
360     E.g. the generation; so if a region starts within an existing
361     allocated page it must be consistent with this page.
362    
363     During the scavenging of the newspace, objects will be transported
364     into an allocation region, and pointers updated to point to this
365     allocation region. It is possible that these pointers will be
366     scavenged again before the allocation region is closed, E.g. due to
367     trans_list which jumps all over the place to cleanup the list. It
368     is important to be able to determine properties of all objects
369     pointed to when scavenging, E.g to detect pointers to the
370     oldspace. Thus it's important that the allocation regions have the
371     correct properties set when allocated, and not just set when
372     closed. The region allocation routines return regions with the
373     specified properties, and grab all the pages, setting there
374     properties appropriately, except that the amount used is not known.
375    
376     These regions are used to support quicker allocation using just a
377     free pointer. The actual space used by the region is not reflected
378     in the pages tables until it is closed. It can't be scavenged until
379     closed.
380    
381     When finished with the region it should be closed, which will
382     update the page tables for the actual space used returning unused
383     space. Further it may be noted in the new regions which is
384     necessary when scavenging the newspace.
385    
386     Large objects may be allocated directly without an allocation
387     region, the page tables are updated immediately.
388    
389     Unboxed objects don't contain points to other objects so don't need
390     scavenging. Further they can't contain pointers to younger
391     generations so WP is not needed. By allocating pages to unboxed
392     objects the whole page never needs scavenging or write protecting.
393    
394     */
395    
396     /* Only using two regions at present, both are for the current
397     newspace generation. */
398     struct alloc_region boxed_region;
399     struct alloc_region unboxed_region;
400    
401     /* X hack. current lisp code uses the following. Need coping
402     in/out. */
403     void *current_region_free_pointer;
404     void *current_region_end_addr;
405    
406     /* The generation currently being allocated to. X */
407     static int gc_alloc_generation;
408    
409     /* Find a new region with room for at least the given number of bytes.
410    
411     It starts looking at the current generations alloc_start_page. So
412     may pick up from the previous region if there is enough space. This
413     keeps the allocation contiguous when scavenging the newspace.
414    
415     The alloc_region is should have been closed by a call to
416     gc_alloc_update_page_tables, and will thus be in an empty state.
417    
418     To assist the scavenging functions write protected pages are not
419     used. Free pages should not be write protected.
420    
421     It is critical to the conservative GC that the start of regions be
422     known. To help achieve this only small regions are allocated at a
423     time.
424    
425     During scavenging pointers may be found to within the current
426     region and the page generation must be set so pointers to the from
427     space can be recognised. So the generation of pages in the region
428     are set to gc_alloc_generation. To prevent another allocation call
429     using the same pages, all the pages in the region are allocated,
430     although they will initially be empty.
431    
432     */
433     static void
434     gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
435     {
436     int first_page;
437     int last_page;
438     int region_size;
439     int restart_page;
440     int bytes_found;
441     int num_pages;
442     int i;
443    
444     /* fprintf(stderr,"alloc_new_region for %d bytes from gen %d\n",
445     nbytes, gc_alloc_generation);*/
446    
447     /* Check that the region is in a reset state. */
448     gc_assert((alloc_region->first_page == 0)
449     && (alloc_region->last_page == -1)
450     && (alloc_region->free_pointer == alloc_region->end_addr));
451    
452     if (unboxed)
453     restart_page = generations[gc_alloc_generation].alloc_unboxed_start_page;
454     else
455     restart_page = generations[gc_alloc_generation].alloc_start_page;
456    
457     /* Search for a contiguous free region of at least nbytes with the
458     given properties: boxed/unboxed, generation. */
459     do {
460     first_page = restart_page;
461    
462     /* First search for a page with at least 32 bytes free, that is
463     not write protected, or marked dont_move. */
464     while ((first_page < NUM_PAGES)
465     && (page_table[first_page].allocated != FREE_PAGE) /* Not free page */
466     && ((unboxed && (page_table[first_page].allocated != UNBOXED_PAGE))
467     || (!unboxed &&
468     (page_table[first_page].allocated != BOXED_PAGE))
469     || (page_table[first_page].large_object != 0)
470     || (page_table[first_page].gen != gc_alloc_generation)
471     || (page_table[first_page].bytes_used >= (4096-32))
472     || (page_table[first_page].write_protected != 0)
473     || (page_table[first_page].dont_move != 0)))
474     first_page++;
475     /* Check for a failure */
476     if (first_page >= NUM_PAGES) {
477     fprintf(stderr,"*A2 gc_alloc_new_region failed, nbytes=%d.\n", nbytes);
478     print_generation_stats(1);
479     exit(1);
480     }
481    
482     gc_assert(page_table[first_page].write_protected == 0);
483    
484     /* fprintf(stderr," first_page=%d bytes_used=%d\n",first_page, page_table[first_page].bytes_used);*/
485    
486     /* Now search forward to calculate the available region size. It
487     tries to keeps going until nbytes are found and the number of
488     pages is greater than some level. This helps keep down the
489     number of pages in a region. */
490     last_page = first_page;
491     bytes_found = 4096 - page_table[first_page].bytes_used;
492     num_pages = 1;
493     while (((bytes_found < nbytes) || (num_pages < 2))
494     && (last_page < (NUM_PAGES-1))
495     && (page_table[last_page+1].allocated == FREE_PAGE)) {
496     last_page++;
497     num_pages++;
498     bytes_found += 4096;
499     gc_assert(page_table[last_page].write_protected == 0);
500     }
501    
502     region_size = (4096 - page_table[first_page].bytes_used)
503     + 4096*(last_page-first_page);
504    
505     gc_assert(bytes_found == region_size);
506    
507     /* fprintf(stderr," last_page=%d bytes_found=%d num_pages=%d\n",last_page, bytes_found, num_pages);*/
508    
509     restart_page = last_page + 1;
510     }
511     while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
512    
513     /* Check for a failure */
514     if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
515     fprintf(stderr,"*A1 gc_alloc_new_region failed, nbytes=%d.\n", nbytes);
516     print_generation_stats(1);
517     exit(1);
518     }
519    
520     /*fprintf(stderr,"gc_alloc_new_region gen %d: %d bytes: from pages %d to %d: addr=%x\n", gc_alloc_generation, bytes_found, first_page, last_page, page_address(first_page));*/
521    
522     /* Setup the alloc_region. */
523     alloc_region->first_page = first_page;
524     alloc_region->last_page = last_page;
525     alloc_region->start_addr = page_table[first_page].bytes_used
526     + page_address(first_page);
527     alloc_region->free_pointer = alloc_region->start_addr;
528     alloc_region->end_addr = alloc_region->start_addr + bytes_found;
529    
530     if (gencgc_zero_check) {
531     int *p;
532     for(p = (int *)alloc_region->start_addr;
533     p < (int *)alloc_region->end_addr; p++)
534     if (*p != 0)
535     fprintf(stderr,"** new region not zero @ %x\n",p);
536     }
537    
538     /* Setup the pages. */
539    
540     /* The first page may have already been in use. */
541     if (page_table[first_page].bytes_used == 0) {
542     if (unboxed)
543     page_table[first_page].allocated = UNBOXED_PAGE;
544     else
545     page_table[first_page].allocated = BOXED_PAGE;
546     page_table[first_page].gen = gc_alloc_generation;
547     page_table[first_page].large_object = 0;
548     page_table[first_page].first_object_offset = 0;
549     }
550    
551     if (unboxed)
552     gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
553     else
554     gc_assert(page_table[first_page].allocated == BOXED_PAGE);
555     gc_assert(page_table[first_page].gen == gc_alloc_generation);
556     gc_assert(page_table[first_page].large_object == 0);
557    
558     for (i = first_page+1; i <= last_page; i++) {
559     if (unboxed)
560     page_table[i].allocated = UNBOXED_PAGE;
561     else
562     page_table[i].allocated = BOXED_PAGE;
563     page_table[i].gen = gc_alloc_generation;
564     page_table[i].large_object = 0;
565     /* This may not be necessary for unboxed regions (think it was
566     broken before!) */
567     page_table[i].first_object_offset =
568     alloc_region->start_addr - page_address(i);
569     }
570    
571     /* Bump up last_free_page */
572     if (last_page+1 > last_free_page) {
573     last_free_page = last_page+1;
574     SetSymbolValue(ALLOCATION_POINTER,
575     (lispobj)(((char *)heap_base) + last_free_page*4096));
576     if (last_page+1 > last_used_page)
577     last_used_page = last_page+1;
578     }
579     }
580    
581    
582    
583     /* If the record_new_objects flag is 2 then all new regions created
584     are recorded.
585    
586     If it's 1 then then it is only recorded if the first page of the
587     current region is <= new_areas_ignore_page. This helps avoid
588     unnecessary recording when doing full scavenge pass.
589    
590     The new_object structure holds the page, byte offset, and size of
591     new regions of objects. Each new area is placed in the array of
592     these structures pointer to by new_areas. new_areas_index holds the
593     offset into new_areas.
594    
595     If new_area overflows NUM_NEW_AREAS then it stops adding them. The
596     later code must detect this an handle it, probably by doing a full
597     scavenge of a generation. */
598    
599     #define NUM_NEW_AREAS 512
600     static int record_new_objects = 0;
601     static int new_areas_ignore_page;
602     struct new_area {
603     int page;
604     int offset;
605     int size;
606     };
607     static struct new_area (*new_areas)[];
608     static new_areas_index;
609     int max_new_areas;
610    
611     /* Add a new area to new_areas. */
612     static void
613     add_new_area(int first_page, int offset, int size)
614     {
615     unsigned new_area_start,c;
616     int i;
617    
618     /* Ignore if full */
619     if (new_areas_index >= NUM_NEW_AREAS)
620     return;
621    
622     switch (record_new_objects) {
623     case 0:
624     return;
625     case 1:
626     if (first_page > new_areas_ignore_page)
627     return;
628     break;
629     case 2:
630     break;
631     default:
632     gc_abort();
633     }
634    
635     new_area_start = 4096*first_page + offset;
636    
637     /* Search backwards for a prior area that this follows from. If
638     found this will save adding a new area. */
639     for (i = new_areas_index-1, c = 0; (i >= 0) && (c < 8); i--, c++) {
640     unsigned area_end = 4096*((*new_areas)[i].page)
641     + (*new_areas)[i].offset + (*new_areas)[i].size;
642     /*fprintf(stderr,"*S1 %d %d %d %d\n",i,c,new_area_start,area_end);*/
643     if (new_area_start == area_end) {
644     /*fprintf(stderr,"-> Adding to [%d] %d %d %d with %d %d %d:\n",
645     i, (*new_areas)[i].page, (*new_areas)[i].offset ,
646     (*new_areas)[i].size, first_page, offset, size);*/
647     (*new_areas)[i].size += size;
648     return;
649     }
650     }
651     /*fprintf(stderr,"*S1 %d %d %d\n",i,c,new_area_start);*/
652    
653     (*new_areas)[new_areas_index].page = first_page;
654     (*new_areas)[new_areas_index].offset = offset;
655     (*new_areas)[new_areas_index].size = size;
656     /*fprintf(stderr," new_area %d page %d offset %d size %d\n",
657     new_areas_index, first_page, offset, size);*/
658     new_areas_index++;
659    
660     /* Note the max new_areas used. */
661     if (new_areas_index > max_new_areas)
662     max_new_areas = new_areas_index;
663     }
664    
665    
666     /* Update the tables for the alloc_region. The region maybe added to
667     the new_areas.
668    
669     When done the alloc_region its setup so that the next quick alloc
670     will fail safely and thus a new regions will be allocated. Further
671     it is safe to try and re-update the page table of this reset
672     alloc_region.
673    
674     */
675     void
676     gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
677     {
678     int more;
679     int first_page;
680     int next_page;
681     int bytes_used;
682     int orig_first_page_bytes_used;
683     int region_size;
684     int byte_cnt;
685    
686     /*fprintf(stderr,"gc_alloc_update_page_tables to gen %d: ",
687     gc_alloc_generation);*/
688    
689     first_page = alloc_region->first_page;
690    
691     /* Catch an unused alloc_region. */
692     if ((first_page == 0) && (alloc_region->last_page == -1))
693     return;
694    
695     next_page = first_page+1;
696    
697     /* Skip if no bytes were allocated */
698     if (alloc_region->free_pointer != alloc_region->start_addr) {
699     orig_first_page_bytes_used = page_table[first_page].bytes_used;
700    
701     gc_assert(alloc_region->start_addr == (page_address(first_page) + page_table[first_page].bytes_used));
702    
703     /* All the pages used need to be updated */
704    
705     /* Update the first page. */
706    
707     /* fprintf(stderr,"0");*/
708    
709     /* If the page was free then setup the gen, and
710     first_object_offset. */
711     if (page_table[first_page].bytes_used == 0)
712     gc_assert(page_table[first_page].first_object_offset == 0);
713    
714     if (unboxed)
715     gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
716     else
717     gc_assert(page_table[first_page].allocated == BOXED_PAGE);
718     gc_assert(page_table[first_page].gen == gc_alloc_generation);
719     gc_assert(page_table[first_page].large_object == 0);
720    
721     byte_cnt = 0;
722    
723     /* Calc. the number of bytes used in this page. This is not always
724     the number of new bytes, unless it was free. */
725     more = 0;
726     if ((bytes_used = (alloc_region->free_pointer - page_address(first_page)))>4096) {
727     bytes_used = 4096;
728     more = 1;
729     }
730     page_table[first_page].bytes_used = bytes_used;
731     byte_cnt += bytes_used;
732    
733    
734     /* All the rest of the pages should be free. Need to set their
735     first_object_offset pointer to the start of the region, and set
736     the bytes_used. */
737     while (more) {
738     /* fprintf(stderr,"+")*/
739     if (unboxed)
740     gc_assert(page_table[next_page].allocated == UNBOXED_PAGE);
741     else
742     gc_assert(page_table[next_page].allocated == BOXED_PAGE);
743     gc_assert(page_table[next_page].bytes_used == 0);
744     gc_assert(page_table[next_page].gen == gc_alloc_generation);
745     gc_assert(page_table[next_page].large_object == 0);
746    
747     gc_assert(page_table[next_page].first_object_offset ==
748     alloc_region->start_addr - page_address(next_page));
749    
750     /* Calc. the number of bytes used in this page. */
751     more = 0;
752     if ((bytes_used = (alloc_region->free_pointer
753     - page_address(next_page)))>4096) {
754     bytes_used = 4096;
755     more = 1;
756     }
757     page_table[next_page].bytes_used = bytes_used;
758     byte_cnt += bytes_used;
759    
760     next_page++;
761     }
762    
763     region_size = alloc_region->free_pointer - alloc_region->start_addr;
764     bytes_allocated += region_size;
765     generations[gc_alloc_generation].bytes_allocated += region_size;
766    
767     gc_assert((byte_cnt- orig_first_page_bytes_used) == region_size);
768    
769     /* Set the generations alloc restart page to the last page of
770     the region. */
771     if (unboxed)
772     generations[gc_alloc_generation].alloc_unboxed_start_page =
773     next_page-1;
774     else
775     generations[gc_alloc_generation].alloc_start_page = next_page-1;
776    
777     /* Add the region to the new_areas if requested. */
778     if (!unboxed)
779     add_new_area(first_page,orig_first_page_bytes_used, region_size);
780    
781     /* fprintf(stderr," gc_alloc_update_page_tables update %d bytes to gen %d\n",region_size,gc_alloc_generation);*/
782     }
783     else
784     /* No bytes allocated. Unallocate the first_page if there are 0
785     bytes_used. */
786     if (page_table[first_page].bytes_used == 0)
787     page_table[first_page].allocated = FREE_PAGE;
788    
789     /* Unallocate any unused pages. */
790     while (next_page <= alloc_region->last_page) {
791     gc_assert(page_table[next_page].bytes_used == 0);
792     page_table[next_page].allocated = FREE_PAGE;
793     next_page++;
794     }
795    
796     /* Reset the alloc_region. */
797     alloc_region->first_page = 0;
798     alloc_region->last_page = -1;
799     alloc_region->start_addr = page_address(0);
800     alloc_region->free_pointer = page_address(0);
801     alloc_region->end_addr = page_address(0);
802    
803     /* fprintf(stderr,"\n");*/
804     }
805    
806    
807    
808     static inline void *gc_quick_alloc(int nbytes);
809    
810     /* Allocate a possibly large object. */
811     static void
812     *gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
813     {
814     int first_page;
815     int last_page;
816     int region_size;
817     int restart_page;
818     int bytes_found;
819     int num_pages;
820     int orig_first_page_bytes_used;
821     int byte_cnt;
822     int more;
823     int bytes_used;
824     int next_page;
825     int large = (nbytes >= large_object_size);
826    
827     /* if (nbytes > 200000)
828     fprintf(stderr,"*** alloc_large %d\n",nbytes);*/
829    
830     /* fprintf(stderr,"gc_alloc_large for %d bytes from gen %d\n",
831     nbytes, gc_alloc_generation);*/
832    
833     /* If the object is small, and there is room in the current region
834     then allocation it in the current region. */
835     if (!large
836     && ((alloc_region->end_addr-alloc_region->free_pointer) >= nbytes))
837     return gc_quick_alloc(nbytes);
838    
839     /* Search for a contiguous free region of at least nbytes. If it's a
840     large object then align it on a page boundary by searching for a
841     free page. */
842    
843     /* To allow the allocation of small objects without the danger of
844     using a page in the current boxed region, the search starts after
845     the current boxed free region. XX could probably keep a page
846     index ahead of the current region and bumped up here to save a
847     lot of re-scanning. */
848     if (unboxed)
849     restart_page = generations[gc_alloc_generation].alloc_large_unboxed_start_page;
850     else
851     restart_page = generations[gc_alloc_generation].alloc_large_start_page;
852     if (restart_page <= alloc_region->last_page)
853     restart_page = alloc_region->last_page+1;
854    
855     do {
856     first_page = restart_page;
857    
858     if (large)
859     while ((first_page < NUM_PAGES)
860     && (page_table[first_page].allocated != FREE_PAGE))
861     first_page++;
862     else
863     while ((first_page < NUM_PAGES)
864     && (page_table[first_page].allocated != FREE_PAGE)
865     && ((unboxed &&
866     (page_table[first_page].allocated != UNBOXED_PAGE))
867     || (!unboxed &&
868     (page_table[first_page].allocated != BOXED_PAGE))
869     || (page_table[first_page].large_object != 0)
870     || (page_table[first_page].gen != gc_alloc_generation)
871     || (page_table[first_page].bytes_used >= (4096-32))
872     || (page_table[first_page].write_protected != 0)
873     || (page_table[first_page].dont_move != 0)))
874     first_page++;
875    
876     /* Check for a failure */
877     if (first_page >= NUM_PAGES) {
878     fprintf(stderr,"*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes);
879     print_generation_stats(1);
880     exit(1);
881     }
882    
883     gc_assert(page_table[first_page].write_protected == 0);
884    
885     /* fprintf(stderr," first_page=%d bytes_used=%d\n",first_page, page_table[first_page].bytes_used);*/
886    
887     last_page = first_page;
888     bytes_found = 4096 - page_table[first_page].bytes_used;
889     num_pages = 1;
890     while ((bytes_found < nbytes)
891     && (last_page < (NUM_PAGES-1))
892     && (page_table[last_page+1].allocated == FREE_PAGE)) {
893     last_page++;
894     num_pages++;
895     bytes_found += 4096;
896     gc_assert(page_table[last_page].write_protected == 0);
897     }
898    
899     region_size = (4096 - page_table[first_page].bytes_used)
900     + 4096*(last_page-first_page);
901    
902     gc_assert(bytes_found == region_size);
903    
904     /* fprintf(stderr," last_page=%d bytes_found=%d num_pages=%d\n",last_page, bytes_found, num_pages);*/
905    
906     restart_page = last_page + 1;
907     }
908     while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
909    
910     /* Check for a failure */
911     if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
912     fprintf(stderr,"*A1 gc_alloc_large failed, nbytes=%d.\n", nbytes);
913     print_generation_stats(1);
914     exit(1);
915     }
916    
917     /* if (large)
918     fprintf(stderr,"gc_alloc_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
919     gc_alloc_generation, nbytes, bytes_found,
920     first_page, last_page, page_address(first_page));*/
921    
922     gc_assert(first_page > alloc_region->last_page);
923     if (unboxed)
924     generations[gc_alloc_generation].alloc_large_unboxed_start_page =
925     last_page;
926     else
927     generations[gc_alloc_generation].alloc_large_start_page = last_page;
928    
929     /* Setup the pages. */
930     orig_first_page_bytes_used = page_table[first_page].bytes_used;
931    
932     /* If the first page was free then setup the gen, and
933     first_object_offset. */
934     if (page_table[first_page].bytes_used == 0) {
935     if (unboxed)
936     page_table[first_page].allocated = UNBOXED_PAGE;
937     else
938     page_table[first_page].allocated = BOXED_PAGE;
939     page_table[first_page].gen = gc_alloc_generation;
940     page_table[first_page].first_object_offset = 0;
941     page_table[first_page].large_object = large;
942     }
943    
944     if (unboxed)
945     gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
946     else
947     gc_assert(page_table[first_page].allocated == BOXED_PAGE);
948     gc_assert(page_table[first_page].gen == gc_alloc_generation);
949     gc_assert(page_table[first_page].large_object == large);
950    
951     byte_cnt = 0;
952    
953     /* Calc. the number of bytes used in this page. This is not
954     always the number of new bytes, unless it was free. */
955     more = 0;
956     if ((bytes_used = nbytes+orig_first_page_bytes_used) > 4096) {
957     bytes_used = 4096;
958     more = 1;
959     }
960     page_table[first_page].bytes_used = bytes_used;
961     byte_cnt += bytes_used;
962    
963     next_page = first_page+1;
964    
965     /* All the rest of the pages should be free. Need to set their
966     first_object_offset pointer to the start of the region, and
967     set the bytes_used. */
968     while (more) {
969     /* fprintf(stderr,"+");*/
970    
971     gc_assert(page_table[next_page].allocated == FREE_PAGE);
972     gc_assert(page_table[next_page].bytes_used == 0);
973     if (unboxed)
974     page_table[next_page].allocated = UNBOXED_PAGE;
975     else
976     page_table[next_page].allocated = BOXED_PAGE;
977     page_table[next_page].gen = gc_alloc_generation;
978     page_table[next_page].large_object = large;
979    
980     page_table[next_page].first_object_offset =
981     orig_first_page_bytes_used - 4096*(next_page-first_page);
982    
983     /* Calc. the number of bytes used in this page. */
984     more = 0;
985     if ((bytes_used=(nbytes+orig_first_page_bytes_used)-byte_cnt) > 4096) {
986     bytes_used = 4096;
987     more = 1;
988     }
989     page_table[next_page].bytes_used = bytes_used;
990     byte_cnt += bytes_used;
991    
992     next_page++;
993     }
994    
995     gc_assert((byte_cnt-orig_first_page_bytes_used) == nbytes);
996    
997     bytes_allocated += nbytes;
998     generations[gc_alloc_generation].bytes_allocated += nbytes;
999    
1000     /* Add the region to the new_areas if requested. */
1001     if (!unboxed)
1002     add_new_area(first_page,orig_first_page_bytes_used,nbytes);
1003    
1004     /* Bump up last_free_page */
1005     if (last_page+1 > last_free_page) {
1006     last_free_page = last_page+1;
1007     SetSymbolValue(ALLOCATION_POINTER,
1008     (lispobj)(((char *)heap_base) + last_free_page*4096));
1009     if (last_page+1 > last_used_page)
1010     last_used_page = last_page+1;
1011     }
1012    
1013     return((void *)(page_address(first_page)+orig_first_page_bytes_used));
1014     }
1015    
1016     /* Allocate bytes from the boxed_region. It first checks if there is
1017     room, if not then it calls gc_alloc_new_region to find a new region
1018     with enough space. A pointer to the start of the region is returned. */
1019     static void
1020     *gc_alloc(int nbytes)
1021     {
1022     void *new_free_pointer;
1023    
1024     /* fprintf(stderr,"gc_alloc %d\n",nbytes);*/
1025    
1026     /* Check if there is room in the current alloc region. */
1027     new_free_pointer = boxed_region.free_pointer + nbytes;
1028    
1029     if (new_free_pointer <= boxed_region.end_addr) {
1030     /* If so then allocate from the current alloc region. */
1031     void *new_obj = boxed_region.free_pointer;
1032     boxed_region.free_pointer = new_free_pointer;
1033    
1034     /* Check if the alloc region is almost empty. */
1035     if ((boxed_region.end_addr - boxed_region.free_pointer) <= 32) {
1036     /* If so finished with the current region. */
1037     gc_alloc_update_page_tables(0,&boxed_region);
1038     /* Setup a new region. */
1039     gc_alloc_new_region(32,0,&boxed_region);
1040     }
1041     return((void *)new_obj);
1042     }
1043    
1044     /* Else not enough free space in the current region. */
1045    
1046     /* If there is a bit of room left in the current region then
1047     allocate a large object. */
1048     if ((boxed_region.end_addr-boxed_region.free_pointer) > 32)
1049     return gc_alloc_large(nbytes,0,&boxed_region);
1050    
1051     /* Else find a new region. */
1052    
1053     /* Finished with the current region. */
1054     gc_alloc_update_page_tables(0,&boxed_region);
1055    
1056     /* Setup a new region. */
1057     gc_alloc_new_region(nbytes,0,&boxed_region);
1058    
1059     /* Should now be enough room. */
1060    
1061     /* Check if there is room in the current region. */
1062     new_free_pointer = boxed_region.free_pointer + nbytes;
1063    
1064     if (new_free_pointer <= boxed_region.end_addr) {
1065     /* If so then allocate from the current region. */
1066     void *new_obj = boxed_region.free_pointer;
1067     boxed_region.free_pointer = new_free_pointer;
1068    
1069     /* Check if the current region is almost empty. */
1070     if ((boxed_region.end_addr - boxed_region.free_pointer) <= 32) {
1071     /* If so find, finished with the current region. */
1072     gc_alloc_update_page_tables(0,&boxed_region);
1073    
1074     /* Setup a new region. */
1075     gc_alloc_new_region(32,0,&boxed_region);
1076     }
1077    
1078     return((void *)new_obj);
1079     }
1080    
1081     /* Shouldn't happen? */
1082     gc_assert(0);
1083     }
1084    
1085     /* Allocate space from the boxed_region. If there is not enough free
1086     space then call gc_alloc to do the job. A pointer to the start of
1087     the region is returned. */
1088     static inline void
1089     *gc_quick_alloc(int nbytes)
1090     {
1091     void *new_free_pointer;
1092    
1093     /* Check if there is room in the current region. */
1094     new_free_pointer = boxed_region.free_pointer + nbytes;
1095    
1096     if (new_free_pointer <= boxed_region.end_addr) {
1097     /* If so then allocate from the current region. */
1098     void *new_obj = boxed_region.free_pointer;
1099     boxed_region.free_pointer = new_free_pointer;
1100     return((void *)new_obj);
1101     }
1102    
1103     /* Else call gc_alloc */
1104     return (gc_alloc(nbytes));
1105     }
1106    
1107     /* Allocate space for the boxed object. If it is a large object then
1108     do a large alloc else allocate from the current region. If there is
1109     not enough free space then call gc_alloc to do the job. A pointer
1110     to the start of the region is returned. */
1111     static inline void
1112     *gc_quick_alloc_large(int nbytes)
1113     {
1114     void *new_free_pointer;
1115    
1116     if (nbytes >= large_object_size)
1117     return gc_alloc_large(nbytes,0,&boxed_region);
1118    
1119     /* Check if there is room in the current region. */
1120     new_free_pointer = boxed_region.free_pointer + nbytes;
1121    
1122     if (new_free_pointer <= boxed_region.end_addr) {
1123     /* If so then allocate from the current region. */
1124     void *new_obj = boxed_region.free_pointer;
1125     boxed_region.free_pointer = new_free_pointer;
1126     return((void *)new_obj);
1127     }
1128    
1129     /* Else call gc_alloc */
1130     return (gc_alloc(nbytes));
1131     }
1132    
1133    
1134    
1135    
1136     static void
1137     *gc_alloc_unboxed(int nbytes)
1138     {
1139     void *new_free_pointer;
1140    
1141     /* fprintf(stderr,"gc_alloc_unboxed %d\n",nbytes);*/
1142    
1143     /* Check if there is room in the current region. */
1144     new_free_pointer = unboxed_region.free_pointer + nbytes;
1145    
1146     if (new_free_pointer <= unboxed_region.end_addr) {
1147     /* If so then allocate from the current region. */
1148     void *new_obj = unboxed_region.free_pointer;
1149     unboxed_region.free_pointer = new_free_pointer;
1150    
1151     /* Check if the current region is almost empty. */
1152     if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {
1153     /* If so finished with the current region. */
1154     gc_alloc_update_page_tables(1,&unboxed_region);
1155    
1156     /* Setup a new region. */
1157     gc_alloc_new_region(32,1,&unboxed_region);
1158     }
1159    
1160     return((void *)new_obj);
1161     }
1162    
1163     /* Else not enough free space in the current region. */
1164    
1165     /* If there is a bit of room left in the current region then
1166     allocate a large object. */
1167     if ((unboxed_region.end_addr-unboxed_region.free_pointer) > 32)
1168     return gc_alloc_large(nbytes,1,&unboxed_region);
1169    
1170     /* Else find a new region. */
1171    
1172     /* Finished with the current region. */
1173     gc_alloc_update_page_tables(1,&unboxed_region);
1174    
1175     /* Setup a new region. */
1176     gc_alloc_new_region(nbytes,1,&unboxed_region);
1177    
1178     /* Should now be enough room. */
1179    
1180     /* Check if there is room in the current region. */
1181     new_free_pointer = unboxed_region.free_pointer + nbytes;
1182    
1183     if (new_free_pointer <= unboxed_region.end_addr) {
1184     /* If so then allocate from the current region. */
1185     void *new_obj = unboxed_region.free_pointer;
1186     unboxed_region.free_pointer = new_free_pointer;
1187    
1188     /* Check if the current region is almost empty. */
1189     if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {
1190     /* If so find, finished with the current region. */
1191     gc_alloc_update_page_tables(1,&unboxed_region);
1192    
1193     /* Setup a new region. */
1194     gc_alloc_new_region(32,1,&unboxed_region);
1195     }
1196    
1197     return((void *)new_obj);
1198     }
1199    
1200     /* Shouldn't happen? */
1201     gc_assert(0);
1202     }
1203    
1204     static inline void
1205     *gc_quick_alloc_unboxed(int nbytes)
1206     {
1207     void *new_free_pointer;
1208    
1209     /* Check if there is room in the current region. */
1210     new_free_pointer = unboxed_region.free_pointer + nbytes;
1211    
1212     if (new_free_pointer <= unboxed_region.end_addr) {
1213     /* If so then allocate from the current region. */
1214     void *new_obj = unboxed_region.free_pointer;
1215     unboxed_region.free_pointer = new_free_pointer;
1216    
1217     return((void *)new_obj);
1218     }
1219    
1220     /* Else call gc_alloc */
1221     return (gc_alloc_unboxed(nbytes));
1222     }
1223    
1224     /* Allocate space for the object. If it is a large object then do a
1225     large alloc else allocate from the current region. If there is not
1226     enough free space then call gc_alloc to do the job.
1227    
1228     A pointer to the start of the region is returned. */
1229     static inline void
1230     *gc_quick_alloc_large_unboxed(int nbytes)
1231     {
1232     void *new_free_pointer;
1233    
1234     if (nbytes >= large_object_size)
1235     return gc_alloc_large(nbytes,1,&unboxed_region);
1236    
1237     /* Check if there is room in the current region. */
1238     new_free_pointer = unboxed_region.free_pointer + nbytes;
1239    
1240     if (new_free_pointer <= unboxed_region.end_addr) {
1241     /* If so then allocate from the current region. */
1242     void *new_obj = unboxed_region.free_pointer;
1243     unboxed_region.free_pointer = new_free_pointer;
1244    
1245     return((void *)new_obj);
1246     }
1247    
1248     /* Else call gc_alloc */
1249     return (gc_alloc_unboxed(nbytes));
1250     }
1251    
1252     /***************************************************************************/
1253    
1254    
1255     /* Scavenging/transporting routines derived from gc.c */
1256    
1257     static int (*scavtab[256])(lispobj *where, lispobj object);
1258     static lispobj (*transother[256])(lispobj object);
1259     static int (*sizetab[256])(lispobj *where);
1260    
1261     static struct weak_pointer *weak_pointers;
1262     static struct scavenger_hook *scavenger_hooks = NIL;
1263    
1264     #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
1265    
1266    
1267     /* Predicates */
1268    
1269     static inline boolean
1270     from_space_p(lispobj obj)
1271     {
1272     int page_index=(void*)obj - heap_base;
1273     return ((page_index >= 0)
1274     && ((page_index = ((unsigned int)page_index)/4096) < NUM_PAGES)
1275     && (page_table[page_index].gen == from_space));
1276     }
1277    
1278     static inline boolean
1279     new_space_p(lispobj obj)
1280     {
1281     int page_index = (void*)obj - heap_base;
1282     return ((page_index >= 0)
1283     && ((page_index = ((unsigned int)page_index)/4096) < NUM_PAGES)
1284     && (page_table[page_index].gen == new_space));
1285     }
1286    
1287    
1288     /* Copying Objects */
1289    
1290    
1291     /* Copying Boxed Objects */
1292     static inline lispobj
1293     copy_object(lispobj object, int nwords)
1294     {
1295     int tag;
1296     lispobj *new;
1297     lispobj *source, *dest;
1298    
1299     gc_assert(Pointerp(object));
1300     gc_assert(from_space_p(object));
1301     gc_assert((nwords & 0x01) == 0);
1302    
1303     /* get tag of object */
1304     tag = LowtagOf(object);
1305    
1306     /* allocate space */
1307     new = gc_quick_alloc(nwords*4);
1308    
1309     dest = new;
1310     source = (lispobj *) PTR(object);
1311    
1312     /* copy the object */
1313     while (nwords > 0) {
1314     dest[0] = source[0];
1315     dest[1] = source[1];
1316     dest += 2;
1317     source += 2;
1318     nwords -= 2;
1319     }
1320    
1321     /* return lisp pointer of new object */
1322     return ((lispobj) new) | tag;
1323     }
1324    
1325     /* Copying Large Boxed Objects. If the object is in a large object
1326     region then it is simply promoted, else it is copied. If it's large
1327     enough then it's copied to a large object region.
1328    
1329     Vectors may have shrunk. If the object is not copied the space
1330     needs to be reclaimed, and the page_tables corrected. */
1331     static lispobj
1332     copy_large_object(lispobj object, int nwords)
1333     {
1334     int tag;
1335     lispobj *new;
1336     lispobj *source, *dest;
1337     int first_page;
1338    
1339     gc_assert(Pointerp(object));
1340     gc_assert(from_space_p(object));
1341     gc_assert((nwords & 0x01) == 0);
1342    
1343 dtc 1.6 if ((nwords > 1024*1024) && gencgc_verbose)
1344 dtc 1.1 fprintf(stderr,"** copy_large_object: %d\n",nwords*4);
1345    
1346     /* Check if it's a large object. */
1347     first_page = find_page_index((void *)object);
1348     gc_assert(first_page >= 0);
1349    
1350     if (page_table[first_page].large_object) {
1351     /* Promote the object. */
1352     int remaining_bytes;
1353     int next_page;
1354     int bytes_freed;
1355     int old_bytes_used;
1356    
1357     /* Note: Any page write protection must be removed, else a later
1358     scavenge_newspace may incorrectly not scavenge these pages.
1359     This would not be necessary if they are added to the new areas,
1360     but lets do it for them all (they'll probably be written
1361     anyway?). */
1362    
1363     gc_assert(page_table[first_page].first_object_offset == 0);
1364    
1365     next_page = first_page;
1366     remaining_bytes = nwords*4;
1367     while (remaining_bytes > 4096) {
1368     gc_assert(page_table[next_page].gen == from_space);
1369     gc_assert(page_table[next_page].allocated == BOXED_PAGE);
1370     gc_assert(page_table[next_page].large_object);
1371     gc_assert(page_table[next_page].first_object_offset==
1372     -4096*(next_page-first_page));
1373     gc_assert(page_table[next_page].bytes_used == 4096);
1374    
1375     page_table[next_page].gen = new_space;
1376    
1377     /* Remove any write protection. Should be able to religh on the
1378     WP flag to avoid redundant calls. */
1379     if (page_table[next_page].write_protected) {
1380     os_protect(page_address(next_page), 4096, OS_VM_PROT_ALL);
1381     page_table[next_page].write_protected = 0;
1382     }
1383     remaining_bytes -= 4096;
1384     next_page++;
1385     }
1386    
1387     /* Now only one page remains, but the object may have shrunk so
1388     there may be more unused pages which will be freed. */
1389    
1390     /* Object may have shrunk but shouldn't have grown - check. */
1391     gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
1392    
1393     page_table[next_page].gen = new_space;
1394     gc_assert(page_table[next_page].allocated = BOXED_PAGE);
1395    
1396     /* Adjust the bytes_used. */
1397     old_bytes_used = page_table[next_page].bytes_used;
1398     page_table[next_page].bytes_used = remaining_bytes;
1399    
1400     bytes_freed = old_bytes_used - remaining_bytes;
1401    
1402     /* Free any remaining pages; needs care. */
1403     next_page++;
1404     while ((old_bytes_used == 4096) &&
1405     (page_table[next_page].gen == from_space) &&
1406     (page_table[next_page].allocated == BOXED_PAGE) &&
1407     page_table[next_page].large_object &&
1408     (page_table[next_page].first_object_offset ==
1409     -(next_page - first_page)*4096)) {
1410     /* Checks out OK, free the page. Don't need to both zeroing
1411     pages as this should have been done before shrinking the
1412     object. These pages shouldn't be write protected as they
1413     should be zero filled. */
1414     gc_assert(page_table[next_page].write_protected == 0);
1415    
1416     old_bytes_used = page_table[next_page].bytes_used;
1417     page_table[next_page].allocated = FREE_PAGE;
1418     page_table[next_page].bytes_used = 0;
1419     bytes_freed += old_bytes_used;
1420     next_page++;
1421     }
1422    
1423 dtc 1.6 if ((bytes_freed > 0) && gencgc_verbose)
1424 dtc 1.1 fprintf(stderr,"* copy_large_boxed bytes_freed %d\n", bytes_freed);
1425    
1426     generations[from_space].bytes_allocated -= 4*nwords + bytes_freed;
1427     generations[new_space].bytes_allocated += 4*nwords;
1428     bytes_allocated -= bytes_freed;
1429    
1430     /* Add the region to the new_areas if requested. */
1431     add_new_area(first_page,0,nwords*4);
1432    
1433     return(object);
1434     }
1435     else {
1436     /* get tag of object */
1437     tag = LowtagOf(object);
1438    
1439     /* allocate space */
1440     new = gc_quick_alloc_large(nwords*4);
1441    
1442     dest = new;
1443     source = (lispobj *) PTR(object);
1444    
1445     /* copy the object */
1446     while (nwords > 0) {
1447     dest[0] = source[0];
1448     dest[1] = source[1];
1449     dest += 2;
1450     source += 2;
1451     nwords -= 2;
1452     }
1453    
1454     /* return lisp pointer of new object */
1455     return ((lispobj) new) | tag;
1456     }
1457     }
1458    
1459     /* Copying UnBoxed Objects. */
1460     static inline lispobj
1461     copy_unboxed_object(lispobj object, int nwords)
1462     {
1463     int tag;
1464     lispobj *new;
1465     lispobj *source, *dest;
1466    
1467     gc_assert(Pointerp(object));
1468     gc_assert(from_space_p(object));
1469     gc_assert((nwords & 0x01) == 0);
1470    
1471     /* get tag of object */
1472     tag = LowtagOf(object);
1473    
1474     /* allocate space */
1475     new = gc_quick_alloc_unboxed(nwords*4);
1476    
1477     dest = new;
1478     source = (lispobj *) PTR(object);
1479    
1480     /* copy the object */
1481     while (nwords > 0) {
1482     dest[0] = source[0];
1483     dest[1] = source[1];
1484     dest += 2;
1485     source += 2;
1486     nwords -= 2;
1487     }
1488    
1489     /* return lisp pointer of new object */
1490     return ((lispobj) new) | tag;
1491     }
1492    
1493    
1494     /* Copying Large Unboxed Objects. If the object is in a large object
1495     region then it is simply promoted, else it is copied. If it's large
1496     enough then it's copied to a large object region.
1497    
1498     Bignums and vectors may have shrunk. If the object is not copied
1499     the space needs to be reclaimed, and the page_tables corrected. */
1500     static lispobj
1501     copy_large_unboxed_object(lispobj object, int nwords)
1502     {
1503     int tag;
1504     lispobj *new;
1505     lispobj *source, *dest;
1506     int first_page;
1507    
1508     gc_assert(Pointerp(object));
1509     gc_assert(from_space_p(object));
1510     gc_assert((nwords & 0x01) == 0);
1511    
1512 dtc 1.6 if ((nwords > 1024*1024) && gencgc_verbose)
1513 dtc 1.1 fprintf(stderr,"** copy_large_unboxed_object: %d\n",nwords*4);
1514    
1515     /* Check if it's a large object. */
1516     first_page = find_page_index((void *)object);
1517     gc_assert(first_page >= 0);
1518    
1519     if (page_table[first_page].large_object) {
1520     /* Promote the object. Note: Unboxed objects may have been
1521     allocated to a BOXED region so it may be necessary to change
1522     the region to UNBOXED. */
1523     int remaining_bytes;
1524     int next_page;
1525     int bytes_freed;
1526     int old_bytes_used;
1527    
1528     gc_assert(page_table[first_page].first_object_offset == 0);
1529    
1530     next_page = first_page;
1531     remaining_bytes = nwords*4;
1532     while (remaining_bytes > 4096) {
1533     gc_assert(page_table[next_page].gen == from_space);
1534     gc_assert((page_table[next_page].allocated == UNBOXED_PAGE)
1535     || (page_table[next_page].allocated == BOXED_PAGE));
1536     gc_assert(page_table[next_page].large_object);
1537     gc_assert(page_table[next_page].first_object_offset==
1538     -4096*(next_page-first_page));
1539     gc_assert(page_table[next_page].bytes_used == 4096);
1540    
1541     page_table[next_page].gen = new_space;
1542     page_table[next_page].allocated = UNBOXED_PAGE;
1543     remaining_bytes -= 4096;
1544     next_page++;
1545     }
1546    
1547     /* Now only one page remains, but the object may have shrunk so
1548     there may be more unused pages which will be freed. */
1549    
1550     /* Object may have shrunk but shouldn't have grown - check. */
1551     gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
1552    
1553     page_table[next_page].gen = new_space;
1554     page_table[next_page].allocated = UNBOXED_PAGE;
1555    
1556     /* Adjust the bytes_used. */
1557     old_bytes_used = page_table[next_page].bytes_used;
1558     page_table[next_page].bytes_used = remaining_bytes;
1559    
1560     bytes_freed = old_bytes_used - remaining_bytes;
1561    
1562     /* Free any remaining pages; needs care. */
1563     next_page++;
1564     while ((old_bytes_used == 4096) &&
1565     (page_table[next_page].gen == from_space) &&
1566     ((page_table[next_page].allocated == UNBOXED_PAGE)
1567     || (page_table[next_page].allocated == BOXED_PAGE)) &&
1568     page_table[next_page].large_object &&
1569     (page_table[next_page].first_object_offset ==
1570     -(next_page - first_page)*4096)) {
1571     /* Checks out OK, free the page. Don't need to both zeroing
1572     pages as this should have been done before shrinking the
1573     object. These pages shouldn't be write protected, even if
1574     boxed they should be zero filled. */
1575     gc_assert(page_table[next_page].write_protected == 0);
1576    
1577     old_bytes_used = page_table[next_page].bytes_used;
1578     page_table[next_page].allocated = FREE_PAGE;
1579     page_table[next_page].bytes_used = 0;
1580     bytes_freed += old_bytes_used;
1581     next_page++;
1582     }
1583    
1584 dtc 1.6 if ((bytes_freed > 0) && gencgc_verbose)
1585 dtc 1.1 fprintf(stderr,"* copy_large_unboxed bytes_freed %d\n", bytes_freed);
1586    
1587     generations[from_space].bytes_allocated -= 4*nwords + bytes_freed;
1588     generations[new_space].bytes_allocated += 4*nwords;
1589     bytes_allocated -= bytes_freed;
1590    
1591     return(object);
1592     }
1593     else {
1594     /* get tag of object */
1595     tag = LowtagOf(object);
1596    
1597     /* allocate space */
1598     new = gc_quick_alloc_large_unboxed(nwords*4);
1599    
1600     dest = new;
1601     source = (lispobj *) PTR(object);
1602    
1603     /* copy the object */
1604     while (nwords > 0) {
1605     dest[0] = source[0];
1606     dest[1] = source[1];
1607     dest += 2;
1608     source += 2;
1609     nwords -= 2;
1610     }
1611    
1612     /* return lisp pointer of new object */
1613     return ((lispobj) new) | tag;
1614     }
1615     }
1616    
1617    
1618     /* Scavenging */
1619    
1620     #define DIRECT_SCAV 0
1621    
1622     static void
1623     scavenge(lispobj *start, long nwords)
1624     {
1625     while (nwords > 0) {
1626     lispobj object;
1627     int type, words_scavenged;
1628    
1629     object = *start;
1630    
1631     gc_assert(object != 0x01); /* Not a forwarding pointer. */
1632    
1633     #if DIRECT_SCAV
1634     type = TypeOf(object);
1635     words_scavenged = (scavtab[type])(start, object);
1636     #else
1637     if (Pointerp(object))
1638     /* It be a pointer. */
1639     if (from_space_p(object)) {
1640     /* It currently points to old space. Check for a forwarding
1641     pointer. */
1642     lispobj *ptr = (lispobj *)PTR(object);
1643     lispobj first_word = *ptr;
1644    
1645     if(first_word == 0x01) {
1646     /* Yep, there be a forwarding pointer. */
1647     *start = ptr[1];
1648     words_scavenged = 1;
1649     }
1650     else
1651     /* Scavenge that pointer. */
1652     words_scavenged = (scavtab[TypeOf(object)])(start, object);
1653     }
1654     else
1655     /* It points somewhere other than oldspace. Leave */
1656     /* it alone. */
1657     words_scavenged = 1;
1658     else
1659     if ((object & 3) == 0)
1660     /* It's a fixnum. Real easy. */
1661     words_scavenged = 1;
1662     else
1663     /* It's some random header object. */
1664     words_scavenged = (scavtab[TypeOf(object)])(start, object);
1665     #endif
1666    
1667     start += words_scavenged;
1668     nwords -= words_scavenged;
1669     }
1670     gc_assert(nwords == 0);
1671     }
1672    
1673    
1674     /* Code and Code-Related Objects */
1675    
1676     #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
1677    
1678     static lispobj trans_function_header(lispobj object);
1679     static lispobj trans_boxed(lispobj object);
1680    
1681     #if DIRECT_SCAV
1682     static int
1683     scav_function_pointer(lispobj *where, lispobj object)
1684     {
1685     gc_assert(Pointerp(object));
1686    
1687     if (from_space_p(object)) {
1688     lispobj first, *first_pointer;
1689    
1690     /* object is a pointer into from space. check to see */
1691     /* if it has been forwarded */
1692     first_pointer = (lispobj *) PTR(object);
1693     first = *first_pointer;
1694    
1695     if (first == 0x01) {
1696     /* Forwarded */
1697     *where = first_pointer[1];
1698     return 1;
1699     }
1700     else {
1701     int type;
1702     lispobj copy;
1703    
1704     /* must transport object -- object may point */
1705     /* to either a function header, a closure */
1706     /* function header, or to a closure header. */
1707    
1708     type = TypeOf(first);
1709     switch (type) {
1710     case type_FunctionHeader:
1711     case type_ClosureFunctionHeader:
1712     copy = trans_function_header(object);
1713     break;
1714     default:
1715     copy = trans_boxed(object);
1716     break;
1717     }
1718    
1719     if (copy != object) {
1720     /* Set forwarding pointer. */
1721     first_pointer[0] = 0x01;
1722     first_pointer[1] = copy;
1723     }
1724    
1725     first = copy;
1726     }
1727    
1728     gc_assert(Pointerp(first));
1729     gc_assert(!from_space_p(first));
1730    
1731     *where = first;
1732     }
1733     return 1;
1734     }
1735     #else
1736     static int
1737     scav_function_pointer(lispobj *where, lispobj object)
1738     {
1739     lispobj *first_pointer;
1740     lispobj copy;
1741    
1742     gc_assert(Pointerp(object));
1743    
1744     /* Object is a pointer into from space - no a FP. */
1745     first_pointer = (lispobj *) PTR(object);
1746    
1747     /* must transport object -- object may point to either a function
1748     header, a closure function header, or to a closure header. */
1749    
1750     switch (TypeOf(*first_pointer)) {
1751     case type_FunctionHeader:
1752     case type_ClosureFunctionHeader:
1753     copy = trans_function_header(object);
1754     break;
1755     default:
1756     copy = trans_boxed(object);
1757     break;
1758     }
1759    
1760     if (copy != object) {
1761     /* Set forwarding pointer */
1762     first_pointer[0] = 0x01;
1763     first_pointer[1] = copy;
1764     }
1765    
1766     gc_assert(Pointerp(copy));
1767     gc_assert(!from_space_p(copy));
1768    
1769     *where = copy;
1770    
1771     return 1;
1772     }
1773     #endif
1774    
1775     /* Scan a x86 compiled code objected, looking for possible fixups that
1776     have been missed after a move.
1777    
1778     Two types of fixups are needed:
1779     1. Absolution fixups to within the code object.
1780     2. Relative fixups to outside the code object.
1781    
1782     Currently only absolution fixups to the constant vector, or to the
1783     code area are checked. */
1784     void
1785     sniff_code_object(struct code *code, unsigned displacement)
1786     {
1787     int nheader_words, ncode_words, nwords;
1788     lispobj fheaderl;
1789     struct function *fheaderp;
1790     void *p;
1791     void *constants_start_addr, *constants_end_addr;
1792     void *code_start_addr, *code_end_addr;
1793     int fixup_found = 0;
1794    
1795 dtc 1.3 if (!check_code_fixups)
1796     return;
1797    
1798 dtc 1.6 /* It's ok if it's byte compiled code. The trace table offset will
1799     be a fixnum if it's x86 compiled code - check. */
1800 dtc 1.1 if (code->trace_table_offset & 0x3) {
1801     /* fprintf(stderr,"*** Sniffing byte compiled code object at %x.\n",code);*/
1802     return;
1803     }
1804    
1805     /* Else it's x86 machine code. */
1806    
1807     ncode_words = fixnum_value(code->code_size);
1808     nheader_words = HeaderValue(*(lispobj *)code);
1809     nwords = ncode_words + nheader_words;
1810    
1811     constants_start_addr = (void *)code + 5*4;
1812     constants_end_addr = (void *)code + nheader_words*4;
1813     code_start_addr = (void *)code + nheader_words*4;
1814     code_end_addr = (void *)code + nwords*4;
1815    
1816     /* Work through the unboxed code. */
1817     for (p = code_start_addr; p < code_end_addr; p++) {
1818     void *data = *(void **)p;
1819     unsigned d1 = *((unsigned char *)p - 1);
1820     unsigned d2 = *((unsigned char *)p - 2);
1821     unsigned d3 = *((unsigned char *)p - 3);
1822     unsigned d4 = *((unsigned char *)p - 4);
1823     unsigned d5 = *((unsigned char *)p - 5);
1824     unsigned d6 = *((unsigned char *)p - 6);
1825    
1826     /* Check for code references. */
1827     /* Check for a 32 bit word that looks like an absolute
1828     reference to within the code adea of the code object. */
1829     if ((data >= (code_start_addr-displacement))
1830     && (data < (code_end_addr-displacement))) {
1831     /* Function header */
1832     if ((d4 == 0x5e)
1833     && (((unsigned)p - 4 - 4*HeaderValue(*((unsigned *)p-1))) == (unsigned)code)) {
1834     /* Skip the function header */
1835     p += 6*4 - 4 - 1;
1836     continue;
1837     }
1838     /* Push imm32 */
1839     if (d1 == 0x68) {
1840     fixup_found = 1;
1841     fprintf(stderr,"Code ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1842     p, d6,d5,d4,d3,d2,d1, data);
1843     fprintf(stderr,"*** Push $0x%.8x\n", data);
1844     }
1845     /* Mov [reg-8],imm32 */
1846     if ((d3 == 0xc7)
1847     && ((d2 == 0x40) || (d2 == 0x41) || (d2 == 0x42) || (d2 == 0x43)
1848     || (d2 == 0x45) || (d2 == 0x46) || (d2 == 0x47))
1849     && (d1 == 0xf8)) {
1850     fixup_found = 1;
1851     fprintf(stderr,"Code ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1852     p, d6,d5,d4,d3,d2,d1, data);
1853     fprintf(stderr,"*** Mov [reg-8],$0x%.8x\n", data);
1854     }
1855     /* Lea reg, [disp32] */
1856     if ((d2 == 0x8d) && ((d1 & 0xc7) == 5)) {
1857     fixup_found = 1;
1858     fprintf(stderr,"Code ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1859     p, d6,d5,d4,d3,d2,d1, data);
1860     fprintf(stderr,"*** Lea reg,[$0x%.8x]\n", data);
1861     }
1862     }
1863    
1864     /* Check for constant references. */
1865     /* Check for a 32 bit word that looks like an absolution
1866     reference to within the constant vector. Constant references
1867     will be aligned. */
1868     if ((data >= (constants_start_addr-displacement))
1869     && (data < (constants_end_addr-displacement))
1870     && (((unsigned)data & 0x3) == 0)) {
1871     /* Mov eax,m32 */
1872     if (d1 == 0xa1) {
1873     fixup_found = 1;
1874     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1875     p, d6,d5,d4,d3,d2,d1, data);
1876     fprintf(stderr,"*** Mov eax,0x%.8x\n", data);
1877     }
1878    
1879     /* Mov m32,eax */
1880     if (d1 == 0xa3) {
1881     fixup_found = 1;
1882     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1883     p, d6,d5,d4,d3,d2,d1, data);
1884     fprintf(stderr,"*** Mov 0x%.8x,eax\n", data);
1885     }
1886    
1887     /* Cmp m32,imm32 */
1888     if ((d1 == 0x3d) && (d2 == 0x81)) {
1889     fixup_found = 1;
1890     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1891     p, d6,d5,d4,d3,d2,d1, data);
1892     /* XX Check this */
1893     fprintf(stderr,"*** Cmp 0x%.8x,immed32\n", data);
1894     }
1895    
1896     /* Check for a mod=00, r/m=101 byte. */
1897     if ((d1 & 0xc7) == 5) {
1898     /* Cmp m32,reg */
1899     if (d2 == 0x39) {
1900     fixup_found = 1;
1901     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1902     p, d6,d5,d4,d3,d2,d1, data);
1903     fprintf(stderr,"*** Cmp 0x%.8x,reg\n", data);
1904     }
1905     /* Cmp reg32,m32 */
1906     if (d2 == 0x3b) {
1907     fixup_found = 1;
1908     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1909     p, d6,d5,d4,d3,d2,d1, data);
1910     fprintf(stderr,"*** Cmp reg32,0x%.8x\n", data);
1911     }
1912     /* Mov m32,reg32 */
1913     if (d2 == 0x89) {
1914     fixup_found = 1;
1915     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1916     p, d6,d5,d4,d3,d2,d1, data);
1917     fprintf(stderr,"*** Mov 0x%.8x,reg32\n", data);
1918     }
1919     /* Mov reg32,m32 */
1920     if (d2 == 0x8b) {
1921     fixup_found = 1;
1922     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1923     p, d6,d5,d4,d3,d2,d1, data);
1924     fprintf(stderr,"*** Mov reg32,0x%.8x\n", data);
1925     }
1926     /* Lea reg32,m32 */
1927     if (d2 == 0x8d) {
1928     fixup_found = 1;
1929     fprintf(stderr,"Abs. const. ref. @ %x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
1930     p, d6,d5,d4,d3,d2,d1, data);
1931     fprintf(stderr,"*** Lea reg32,0x%.8x\n", data);
1932     }
1933     }
1934     }
1935     }
1936    
1937     /* If anything was found print out some info. on the code object. */
1938     if (fixup_found) {
1939     fprintf(stderr,"*** Compiled code object at %x: header_words=%d code_words=%d .\n",
1940     code, nheader_words, ncode_words);
1941     fprintf(stderr,"*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
1942     constants_start_addr,constants_end_addr,
1943     code_start_addr,code_end_addr);
1944     }
1945     }
1946    
1947     static void
1948     apply_code_fixups(struct code *old_code, struct code *new_code)
1949     {
1950     int nheader_words, ncode_words, nwords;
1951     void *constants_start_addr, *constants_end_addr;
1952     void *code_start_addr, *code_end_addr;
1953     lispobj p;
1954     lispobj fixups = NIL;
1955     unsigned displacement = (unsigned)new_code - (unsigned)old_code;
1956     struct vector *fixups_vector;
1957    
1958     /* It's ok if it's byte compiled code. The trace table offset will
1959     be a fixnum if it's x86 compiled code - check. */
1960     if (new_code->trace_table_offset & 0x3) {
1961     /* fprintf(stderr,"*** Byte compiled code object at %x.\n",new_code);*/
1962     return;
1963     }
1964    
1965     /* Else it's x86 machine code. */
1966     ncode_words = fixnum_value(new_code->code_size);
1967     nheader_words = HeaderValue(*(lispobj *)new_code);
1968     nwords = ncode_words + nheader_words;
1969     /* fprintf(stderr,"*** Compiled code object at %x: header_words=%d code_words=%d .\n",
1970     new_code, nheader_words, ncode_words);*/
1971     constants_start_addr = (void *)new_code + 5*4;
1972     constants_end_addr = (void *)new_code + nheader_words*4;
1973     code_start_addr = (void *)new_code + nheader_words*4;
1974     code_end_addr = (void *)new_code + nwords*4;
1975     /*fprintf(stderr,"*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
1976     constants_start_addr,constants_end_addr,
1977     code_start_addr,code_end_addr);*/
1978    
1979    
1980     /* The first constant should be a pointer to the fixups for this
1981     code objects. Check. */
1982     fixups = new_code->constants[0];
1983    
1984     /* It will be 0 or the unbound-marker if there are no fixups, and
1985     will be an other pointer if it is valid. */
1986     if ((fixups == 0) || (fixups == type_UnboundMarker) || !Pointerp(fixups)) {
1987     /* Check for possible errors. */
1988     if (check_code_fixups)
1989     sniff_code_object(new_code, displacement);
1990    
1991     /*fprintf(stderr,"Fixups for code object not found!?\n");
1992     fprintf(stderr,"*** Compiled code object at %x: header_words=%d code_words=%d .\n",
1993     new_code, nheader_words, ncode_words);
1994     fprintf(stderr,"*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
1995     constants_start_addr,constants_end_addr,
1996     code_start_addr,code_end_addr);*/
1997     return;
1998     }
1999    
2000     fixups_vector = (struct vector *)PTR(fixups);
2001    
2002     /* Could be pointing to a forwarding pointer. */
2003     if (Pointerp(fixups) && (find_page_index((void*)fixups_vector) != -1)
2004     && (fixups_vector->header == 0x01)) {
2005     fprintf(stderr,"* FF\n");
2006     /* If so then follow it. */
2007     fixups_vector = (struct vector *)PTR((lispobj)fixups_vector->length);
2008     }
2009    
2010     /* fprintf(stderr,"Got the fixups\n");*/
2011    
2012     if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
2013     /* Got the fixups for the code block. Now work through the vector,
2014     and apply a fixup at each address. */
2015     int length = fixnum_value(fixups_vector->length);
2016     int i;
2017     for (i = 0; i < length; i++) {
2018     unsigned offset = fixups_vector->data[i];
2019     /* Now check the current value of offset. */
2020     unsigned old_value = *(unsigned *)((unsigned)code_start_addr + offset);
2021    
2022     /* If it's within the old_code object then it must be an
2023     absolute fixup (relative ones are not saved) */
2024     if ((old_value >= (unsigned)old_code)
2025     && (old_value < ((unsigned)old_code + nwords*4)))
2026     /* So add the dispacement. */
2027     *(unsigned *)((unsigned)code_start_addr + offset) = old_value
2028     + displacement;
2029     else
2030     /* It is outside the old code object so it must be a relative
2031     fixup (absolute fixups are not saved). So subtract the
2032     displacement. */
2033     *(unsigned *)((unsigned)code_start_addr + offset) = old_value
2034     - displacement;
2035     }
2036     }
2037    
2038     /* Check for possible errors. */
2039     if (check_code_fixups)
2040     sniff_code_object(new_code,displacement);
2041     }
2042    
2043     static struct code *
2044     trans_code(struct code *code)
2045     {
2046     struct code *new_code;
2047     lispobj l_code, l_new_code;
2048     int nheader_words, ncode_words, nwords;
2049     unsigned long displacement;
2050     lispobj fheaderl, *prev_pointer;
2051    
2052     /*fprintf(stderr,"\nTransporting code object located at 0x%08x.\n",
2053     (unsigned long) code);*/
2054    
2055     /* if object has already been transported, just return pointer */
2056     if (*((lispobj *)code) == 0x01)
2057     return (struct code*)(((lispobj *)code)[1]);
2058    
2059     gc_assert(TypeOf(code->header) == type_CodeHeader);
2060    
2061     /* prepare to transport the code vector */
2062     l_code = (lispobj) code | type_OtherPointer;
2063    
2064     ncode_words = fixnum_value(code->code_size);
2065     nheader_words = HeaderValue(code->header);
2066     nwords = ncode_words + nheader_words;
2067     nwords = CEILING(nwords, 2);
2068    
2069     l_new_code = copy_large_object(l_code, nwords);
2070     new_code = (struct code *) PTR(l_new_code);
2071    
2072     /* May not have been moved. */
2073     if (new_code == code)
2074     return new_code;
2075    
2076     displacement = l_new_code - l_code;
2077    
2078     /*fprintf(stderr,"Old code object at 0x%08x, new code object at 0x%08x.\n",
2079     (unsigned long) code, (unsigned long) new_code);
2080     fprintf(stderr,"Code object is %d words long.\n", nwords);*/
2081    
2082     /* set forwarding pointer */
2083     ((lispobj *)code)[0] = 0x01;
2084     ((lispobj *)code)[1] = l_new_code;
2085    
2086     /* set forwarding pointers for all the function headers in the
2087     code object. also fix all self pointers */
2088    
2089     fheaderl = code->entry_points;
2090     prev_pointer = &new_code->entry_points;
2091    
2092     while (fheaderl != NIL) {
2093     struct function *fheaderp, *nfheaderp;
2094     lispobj nfheaderl;
2095    
2096     fheaderp = (struct function *) PTR(fheaderl);
2097     gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
2098    
2099     /* calcuate the new function pointer and the new */
2100     /* function header */
2101     nfheaderl = fheaderl + displacement;
2102     nfheaderp = (struct function *) PTR(nfheaderl);
2103    
2104     /* set forwarding pointer */
2105     ((lispobj *)fheaderp)[0] = 0x01;
2106     ((lispobj *)fheaderp)[1] = nfheaderl;
2107    
2108     /* fix self pointer */
2109     nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;
2110    
2111     *prev_pointer = nfheaderl;
2112    
2113     fheaderl = fheaderp->next;
2114     prev_pointer = &nfheaderp->next;
2115     }
2116    
2117     /* sniff_code_object(new_code,displacement);*/
2118     apply_code_fixups(code,new_code);
2119    
2120     return new_code;
2121     }
2122    
2123     static int
2124     scav_code_header(lispobj *where, lispobj object)
2125     {
2126     struct code *code;
2127     int nheader_words, ncode_words, nwords;
2128     lispobj fheaderl;
2129     struct function *fheaderp;
2130    
2131     code = (struct code *) where;
2132     ncode_words = fixnum_value(code->code_size);
2133     nheader_words = HeaderValue(object);
2134     nwords = ncode_words + nheader_words;
2135     nwords = CEILING(nwords, 2);
2136    
2137     /* Scavenge the boxed section of the code data block */
2138     scavenge(where + 1, nheader_words - 1);
2139    
2140     /* Scavenge the boxed section of each function object in the */
2141     /* code data block */
2142     fheaderl = code->entry_points;
2143     while (fheaderl != NIL) {
2144     fheaderp = (struct function *) PTR(fheaderl);
2145     gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
2146    
2147     scavenge(&fheaderp->name, 1);
2148     scavenge(&fheaderp->arglist, 1);
2149     scavenge(&fheaderp->type, 1);
2150    
2151     fheaderl = fheaderp->next;
2152     }
2153    
2154     return nwords;
2155     }
2156    
2157     static lispobj
2158     trans_code_header(lispobj object)
2159     {
2160     struct code *ncode;
2161    
2162     ncode = trans_code((struct code *) PTR(object));
2163     return (lispobj) ncode | type_OtherPointer;
2164     }
2165    
2166     static int
2167     size_code_header(lispobj *where)
2168     {
2169     struct code *code;
2170     int nheader_words, ncode_words, nwords;
2171    
2172     code = (struct code *) where;
2173    
2174     ncode_words = fixnum_value(code->code_size);
2175     nheader_words = HeaderValue(code->header);
2176     nwords = ncode_words + nheader_words;
2177     nwords = CEILING(nwords, 2);
2178    
2179     return nwords;
2180     }
2181    
2182    
2183     static int
2184     scav_return_pc_header(lispobj *where, lispobj object)
2185     {
2186     fprintf(stderr, "GC lossage. Should not be scavenging a ");
2187     fprintf(stderr, "Return PC Header.\n");
2188     fprintf(stderr, "where = 0x%08x, object = 0x%08x",
2189     (unsigned long) where, (unsigned long) object);
2190     lose(NULL);
2191     return 0;
2192     }
2193    
2194     static lispobj
2195     trans_return_pc_header(lispobj object)
2196     {
2197     struct function *return_pc;
2198     unsigned long offset;
2199     struct code *code, *ncode;
2200    
2201     fprintf(stderr,"*** trans_return_pc_header: will this work?\n");
2202    
2203     return_pc = (struct function *) PTR(object);
2204     offset = HeaderValue(return_pc->header) * 4;
2205    
2206     /* Transport the whole code object */
2207     code = (struct code *) ((unsigned long) return_pc - offset);
2208     ncode = trans_code(code);
2209    
2210     return ((lispobj) ncode + offset) | type_OtherPointer;
2211     }
2212    
2213     /* On the 386, closures hold a pointer to the raw address instead of the
2214     function object. */
2215     #ifdef i386
2216     static int
2217     scav_closure_header(lispobj *where, lispobj object)
2218     {
2219     struct closure *closure;
2220     lispobj fun;
2221    
2222     closure = (struct closure *)where;
2223     fun = closure->function - RAW_ADDR_OFFSET;
2224     scavenge(&fun, 1);
2225     /* The function may have moved so update the raw address. But don't
2226     write unnecessarily. */
2227     if (closure->function != fun + RAW_ADDR_OFFSET)
2228     closure->function = fun + RAW_ADDR_OFFSET;
2229    
2230     return 2;
2231     }
2232     #endif
2233    
2234     static int
2235     scav_function_header(lispobj *where, lispobj object)
2236     {
2237     fprintf(stderr, "GC lossage. Should not be scavenging a ");
2238     fprintf(stderr, "Function Header.\n");
2239     fprintf(stderr, "where = 0x%08x, object = 0x%08x",
2240     (unsigned long) where, (unsigned long) object);
2241     lose(NULL);
2242     return 0;
2243     }
2244    
2245     static lispobj
2246     trans_function_header(lispobj object)
2247     {
2248     struct function *fheader;
2249     unsigned long offset;
2250     struct code *code, *ncode;
2251    
2252     fheader = (struct function *) PTR(object);
2253     offset = HeaderValue(fheader->header) * 4;
2254    
2255     /* Transport the whole code object */
2256     code = (struct code *) ((unsigned long) fheader - offset);
2257     ncode = trans_code(code);
2258    
2259     return ((lispobj) ncode + offset) | type_FunctionPointer;
2260     }
2261    
2262    
2263     /* Instances */
2264    
2265     #if DIRECT_SCAV
2266     static int
2267     scav_instance_pointer(lispobj *where, lispobj object)
2268     {
2269     if (from_space_p(object)) {
2270     lispobj first, *first_pointer;
2271    
2272     /* object is a pointer into from space. check to see */
2273     /* if it has been forwarded */
2274     first_pointer = (lispobj *) PTR(object);
2275     first = *first_pointer;
2276    
2277     if (first == 0x01)
2278     /* Forwarded. */
2279     first = first_pointer[1];
2280     else {
2281     first = trans_boxed(object);
2282     gc_assert(first != object);
2283     /* Set forwarding pointer */
2284     first_pointer[0] = 0x01;
2285     first_pointer[1] = first;
2286     }
2287     *where = first;
2288     }
2289     return 1;
2290     }
2291     #else
2292     static int
2293     scav_instance_pointer(lispobj *where, lispobj object)
2294     {
2295     lispobj copy, *first_pointer;
2296    
2297     /* Object is a pointer into from space - not a FP */
2298     copy = trans_boxed(object);
2299    
2300     gc_assert(copy != object);
2301    
2302     first_pointer = (lispobj *) PTR(object);
2303    
2304     /* Set forwarding pointer. */
2305     first_pointer[0] = 0x01;
2306     first_pointer[1] = copy;
2307     *where = copy;
2308    
2309     return 1;
2310     }
2311     #endif
2312    
2313    
2314     /* Lists and Conses */
2315    
2316     static lispobj trans_list(lispobj object);
2317    
2318     #if DIRECT_SCAV
2319     static int
2320     scav_list_pointer(lispobj *where, lispobj object)
2321     {
2322     gc_assert(Pointerp(object));
2323    
2324     if (from_space_p(object)) {
2325     lispobj first, *first_pointer;
2326    
2327     /* object is a pointer into from space. check to see */
2328     /* if it has been forwarded */
2329     first_pointer = (lispobj *) PTR(object);
2330     first = *first_pointer;
2331    
2332     if (first == 0x01)
2333     /* Forwarded. */
2334     first = first_pointer[1];
2335     else {
2336     first = trans_list(object);
2337    
2338     /* Set forwarding pointer */
2339     first_pointer[0] = 0x01;
2340     first_pointer[1] = first;
2341     }
2342    
2343     gc_assert(Pointerp(first));
2344     gc_assert(!from_space_p(first));
2345     *where = first;
2346     }
2347     return 1;
2348     }
2349     #else
2350     static int
2351     scav_list_pointer(lispobj *where, lispobj object)
2352     {
2353     lispobj first, *first_pointer;
2354    
2355     gc_assert(Pointerp(object));
2356    
2357     /* Object is a pointer into from space - not FP */
2358    
2359     first = trans_list(object);
2360     gc_assert(first != object);
2361    
2362     first_pointer = (lispobj *) PTR(object);
2363    
2364     /* Set forwarding pointer */
2365     first_pointer[0] = 0x01;
2366     first_pointer[1] = first;
2367    
2368     gc_assert(Pointerp(first));
2369     gc_assert(!from_space_p(first));
2370     *where = first;
2371     return 1;
2372     }
2373     #endif
2374    
2375     static lispobj
2376     trans_list(lispobj object)
2377     {
2378     lispobj new_list_pointer;
2379     struct cons *cons, *new_cons;
2380     int n = 0;
2381     lispobj cdr;
2382    
2383     gc_assert(from_space_p(object));
2384    
2385     cons = (struct cons *) PTR(object);
2386    
2387     /* copy 'object' */
2388     new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
2389     new_cons->car = cons->car;
2390     new_cons->cdr = cons->cdr; /* updated later */
2391     new_list_pointer = (lispobj)new_cons | LowtagOf(object);
2392    
2393     /* Grab the cdr before it is clobbered */
2394     cdr = cons->cdr;
2395    
2396     /* Set forwarding pointer (clobbers start of list). */
2397     cons->car = 0x01;
2398     cons->cdr = new_list_pointer;
2399    
2400     /* Try to linearize the list in the cdr direction to help reduce paging. */
2401     while (1) {
2402     lispobj new_cdr;
2403     struct cons *cdr_cons, *new_cdr_cons;
2404    
2405     if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
2406     || (*((lispobj *)PTR(cdr)) == 0x01))
2407     break;
2408    
2409     cdr_cons = (struct cons *) PTR(cdr);
2410    
2411     /* copy 'cdr' */
2412     new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));
2413     new_cdr_cons->car = cdr_cons->car;
2414     new_cdr_cons->cdr = cdr_cons->cdr;
2415     new_cdr = (lispobj)new_cdr_cons | LowtagOf(cdr);
2416    
2417     /* Grab the cdr before it is clobbered */
2418     cdr = cdr_cons->cdr;
2419    
2420     /* Set forwarding pointer */
2421     cdr_cons->car = 0x01;
2422     cdr_cons->cdr = new_cdr;
2423    
2424     /* Update the cdr of the last cons copied into new
2425     * space to keep the newspace scavenge from having to do it.
2426     */
2427     new_cons->cdr = new_cdr;
2428    
2429     new_cons = new_cdr_cons;
2430     }
2431    
2432     return new_list_pointer;
2433     }
2434    
2435    
2436     /* Scavenging and Transporting Other Pointers */
2437    
2438     #if DIRECT_SCAV
2439     static int
2440     scav_other_pointer(lispobj *where, lispobj object)
2441     {
2442     gc_assert(Pointerp(object));
2443    
2444     if (from_space_p(object)) {
2445     lispobj first, *first_pointer;
2446    
2447     /* object is a pointer into from space. check to see */
2448     /* if it has been forwarded */
2449     first_pointer = (lispobj *) PTR(object);
2450     first = *first_pointer;
2451    
2452     if (first == 0x01) {
2453     /* Forwarded. */
2454     first = first_pointer[1];
2455     *where = first;
2456     } else {
2457     first = (transother[TypeOf(first)])(object);
2458    
2459     if (first != object) {
2460     /* Set forwarding pointer */
2461     first_pointer[0] = 0x01;
2462     first_pointer[1] = first;
2463     *where = first;
2464     }
2465     }
2466    
2467     gc_assert(Pointerp(first));
2468     gc_assert(!from_space_p(first));
2469     }
2470     return 1;
2471     }
2472     #else
2473     static int
2474     scav_other_pointer(lispobj *where, lispobj object)
2475     {
2476     lispobj first, *first_pointer;
2477    
2478     gc_assert(Pointerp(object));
2479    
2480     /* Object is a pointer into from space - not FP */
2481     first_pointer = (lispobj *) PTR(object);
2482    
2483     first = (transother[TypeOf(*first_pointer)])(object);
2484    
2485     if (first != object) {
2486     /* Set forwarding pointer */
2487     first_pointer[0] = 0x01;
2488     first_pointer[1] = first;
2489     *where = first;
2490     }
2491    
2492     gc_assert(Pointerp(first));
2493     gc_assert(!from_space_p(first));
2494    
2495     return 1;
2496     }
2497     #endif
2498    
2499    
2500     /* Immediate, Boxed, and Unboxed Objects */
2501    
2502     static int
2503     size_pointer(lispobj *where)
2504     {
2505     return 1;
2506     }
2507    
2508     static int
2509     scav_immediate(lispobj *where, lispobj object)
2510     {
2511     return 1;
2512     }
2513    
2514     static lispobj
2515     trans_immediate(lispobj object)
2516     {
2517     fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
2518     lose(NULL);
2519     return NIL;
2520     }
2521    
2522     static int
2523     size_immediate(lispobj *where)
2524     {
2525     return 1;
2526     }
2527    
2528    
2529     static int
2530     scav_boxed(lispobj *where, lispobj object)
2531     {
2532     return 1;
2533     }
2534    
2535     static lispobj
2536     trans_boxed(lispobj object)
2537     {
2538     lispobj header;
2539     unsigned long length;
2540    
2541     gc_assert(Pointerp(object));
2542    
2543     header = *((lispobj *) PTR(object));
2544     length = HeaderValue(header) + 1;
2545     length = CEILING(length, 2);
2546    
2547     return copy_object(object, length);
2548     }
2549    
2550     static lispobj
2551     trans_boxed_large(lispobj object)
2552     {
2553     lispobj header;
2554     unsigned long length;
2555    
2556     gc_assert(Pointerp(object));
2557    
2558     header = *((lispobj *) PTR(object));
2559     length = HeaderValue(header) + 1;
2560     length = CEILING(length, 2);
2561    
2562     return copy_large_object(object, length);
2563     }
2564    
2565     static int
2566     size_boxed(lispobj *where)
2567     {
2568     lispobj header;
2569     unsigned long length;
2570    
2571     header = *where;
2572     length = HeaderValue(header) + 1;
2573     length = CEILING(length, 2);
2574    
2575     return length;
2576     }
2577    
2578     static int
2579     scav_fdefn(lispobj *where, lispobj object)
2580     {
2581     struct fdefn *fdefn;
2582    
2583     fdefn = (struct fdefn *)where;
2584    
2585     if ((char *)(fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
2586     scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
2587    
2588     /* Don't write unnecessarily */
2589     if (fdefn->raw_addr != (char *)(fdefn->function + RAW_ADDR_OFFSET))
2590     fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
2591    
2592     return sizeof(struct fdefn) / sizeof(lispobj);
2593     }
2594     else
2595     return 1;
2596     }
2597    
2598     static int
2599     scav_unboxed(lispobj *where, lispobj object)
2600     {
2601     unsigned long length;
2602    
2603     length = HeaderValue(object) + 1;
2604     length = CEILING(length, 2);
2605    
2606     return length;
2607     }
2608    
2609     static lispobj
2610     trans_unboxed(lispobj object)
2611     {
2612     lispobj header;
2613     unsigned long length;
2614    
2615    
2616     gc_assert(Pointerp(object));
2617    
2618     header = *((lispobj *) PTR(object));
2619     length = HeaderValue(header) + 1;
2620     length = CEILING(length, 2);
2621    
2622     return copy_unboxed_object(object, length);
2623     }
2624    
2625     static lispobj
2626     trans_unboxed_large(lispobj object)
2627     {
2628     lispobj header;
2629     unsigned long length;
2630    
2631    
2632     gc_assert(Pointerp(object));
2633    
2634     header = *((lispobj *) PTR(object));
2635     length = HeaderValue(header) + 1;
2636     length = CEILING(length, 2);
2637    
2638     return copy_large_unboxed_object(object, length);
2639     }
2640    
2641     static int
2642     size_unboxed(lispobj *where)
2643     {
2644     lispobj header;
2645     unsigned long length;
2646    
2647     header = *where;
2648     length = HeaderValue(header) + 1;
2649     length = CEILING(length, 2);
2650    
2651     return length;
2652     }
2653    
2654    
2655    
2656     /* Vector-Like Objects */
2657    
2658     #define NWORDS(x,y) (CEILING((x),(y)) / (y))
2659    
2660     static int
2661     scav_string(lispobj *where, lispobj object)
2662     {
2663     struct vector *vector;
2664     int length, nwords;
2665    
2666     /* NOTE: Strings contain one more byte of data than the length */
2667     /* slot indicates. */
2668    
2669     vector = (struct vector *) where;
2670     length = fixnum_value(vector->length) + 1;
2671     nwords = CEILING(NWORDS(length, 4) + 2, 2);
2672    
2673     return nwords;
2674     }
2675    
2676     static lispobj
2677     trans_string(lispobj object)
2678     {
2679     struct vector *vector;
2680     int length, nwords;
2681    
2682     gc_assert(Pointerp(object));
2683    
2684     /* NOTE: Strings contain one more byte of data than the length */
2685     /* slot indicates. */
2686    
2687     vector = (struct vector *) PTR(object);
2688     length = fixnum_value(vector->length) + 1;
2689     nwords = CEILING(NWORDS(length, 4) + 2, 2);
2690    
2691     return copy_large_unboxed_object(object, nwords);
2692     }
2693    
2694     static int
2695     size_string(lispobj *where)
2696     {
2697     struct vector *vector;
2698     int length, nwords;
2699    
2700     /* NOTE: Strings contain one more byte of data than the length */
2701     /* slot indicates. */
2702    
2703     vector = (struct vector *) where;
2704     length = fixnum_value(vector->length) + 1;
2705     nwords = CEILING(NWORDS(length, 4) + 2, 2);
2706    
2707     return nwords;
2708     }
2709    
2710     /*static int
2711     scav_vector(lispobj *where, lispobj object)
2712     {
2713     if (HeaderValue(object) == subtype_VectorValidHashing)
2714     *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;
2715    
2716     return 1;
2717     }*/
2718    
2719     int gencgc_hash = 1;
2720    
2721     static int
2722     scav_vector(lispobj *where, lispobj object)
2723     {
2724     unsigned int kv_length;
2725     lispobj *kv_vector;
2726     unsigned int length;
2727     lispobj *hash_table;
2728     lispobj empty_symbol;
2729     unsigned int *index_vector, *next_vector, *hash_vector;
2730     lispobj weak_p_obj;
2731     unsigned next_vector_length;
2732    
2733     if (HeaderValue(object) != subtype_VectorValidHashing)
2734     return 1;
2735    
2736     if (!gencgc_hash) {
2737     /* Set for backward compatibility. */
2738     *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;
2739     return 1;
2740     }
2741    
2742     kv_length = fixnum_value(where[1]);
2743     kv_vector = where+2; /* Skip the header and length. */
2744     /* fprintf(stderr,"* kv_length = %d\n", kv_length);*/
2745    
2746     /* Scavenge element 0 which may be a hash-table structure. */
2747     scavenge(where+2,1);
2748     if (!Pointerp(where[2])) {
2749     fprintf(stderr,"* Not hash table pointer? %x\n",where[2]);
2750     return 3;
2751     }
2752 dtc 1.5 hash_table = (lispobj *)PTR(where[2]);
2753 dtc 1.1 /* fprintf(stderr,"* hash_table = %x\n", hash_table);*/
2754     if (!(TypeOf(hash_table[0]) == type_InstanceHeader)) {
2755     fprintf(stderr,"* Hash table not instance? %x\n",hash_table[0]);
2756     return 3;
2757     }
2758    
2759     /* Scavenge element 1 which should be an :empty symbol. */
2760     scavenge(where+3,1);
2761     if (!Pointerp(where[3])) {
2762     fprintf(stderr,"* Not :empty symbol pointer? %x\n",where[3]);
2763     return 4;
2764     }
2765     empty_symbol = where[3];
2766     /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
2767     if (!(TypeOf(*(lispobj *)PTR(empty_symbol)) == type_SymbolHeader)) {
2768     fprintf(stderr,"* empty symbol not symbol? %x\n",
2769     *(lispobj *)PTR(empty_symbol));
2770     return 4;
2771     }
2772    
2773     /* Scavenge hash table which will fix the positions of the other
2774     needed objects. */
2775     scavenge(hash_table,16);
2776    
2777     /* Cross check the kv_vector. */
2778 dtc 1.5 if (where != (lispobj *)PTR(hash_table[9])) {
2779 dtc 1.1 fprintf(stderr,"* hash_table table!=this table? %x\n",hash_table[9]);
2780     return 4;
2781     }
2782    
2783     /* Weak-p */
2784     weak_p_obj = hash_table[10];
2785     /* fprintf(stderr,"* weak-p = %x\n",weak_p_obj);*/
2786    
2787     /* Index vector */
2788     {
2789     lispobj index_vector_obj = hash_table[13];
2790    
2791     if (Pointerp(index_vector_obj) &&
2792     (TypeOf(*(lispobj *)PTR(index_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
2793     index_vector = ((unsigned int *)PTR(index_vector_obj)) + 2;
2794     /* fprintf(stderr,"* index_vector = %x\n",index_vector);*/
2795     length = fixnum_value(((unsigned int *)PTR(index_vector_obj))[1]);
2796     /* fprintf(stderr,"* length = %d\n", length);*/
2797     } else {
2798     fprintf(stderr,"* invalid index_vector? %x\n",index_vector_obj);
2799     return 4;
2800     }
2801     }
2802    
2803     /* Next vector */
2804     {
2805     lispobj next_vector_obj = hash_table[14];
2806    
2807     if (Pointerp(next_vector_obj) &&
2808     (TypeOf(*(lispobj *)PTR(next_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
2809     next_vector = ((unsigned int *)PTR(next_vector_obj)) + 2;
2810     /* fprintf(stderr,"* next_vector = %x\n",next_vector);*/
2811     next_vector_length = fixnum_value(((unsigned int *)PTR(next_vector_obj))[1]);
2812     /* fprintf(stderr,"* next_vector_length = %d\n", next_vector_length);*/
2813     } else {
2814     fprintf(stderr,"* invalid next_vector? %x\n",next_vector_obj);
2815     return 4;
2816     }
2817     }
2818    
2819     /* Maybe Hash vector */
2820     {
2821     lispobj hash_vector_obj = hash_table[15];
2822    
2823     if (Pointerp(hash_vector_obj) &&
2824     (TypeOf(*(lispobj *)PTR(hash_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
2825     hash_vector = ((unsigned int *)PTR(hash_vector_obj)) + 2;
2826     /* fprintf(stderr,"* hash_vector = %x\n",hash_vector);*/
2827     gc_assert(fixnum_value(((unsigned int *)PTR(hash_vector_obj))[1])
2828     == next_vector_length);
2829     } else {
2830     hash_vector = NULL;
2831     /* fprintf(stderr,"* No hash_vector: %x\n",hash_vector_obj);*/
2832     }
2833     }
2834    
2835     /* These lengths could be different as the index_vector can be a
2836     different length to the others, a larger index_vector could help
2837     reduce collisions. */
2838     gc_assert(next_vector_length*2 == kv_length);
2839    
2840     /* Now all setup */
2841    
2842     /* Work through the KV vector */
2843     {
2844     int i;
2845     for (i = 1; i < next_vector_length; i++) {
2846     lispobj old_key = kv_vector[2*i];
2847     unsigned int old_index = (old_key & 0x1fffffff)%length;
2848    
2849     /* Scavenge the Key and Value */
2850     scavenge(&kv_vector[2*i],2);
2851    
2852     /* Check if the Key has moved and is EQ based */
2853     {
2854     lispobj new_key = kv_vector[2*i];
2855     unsigned int new_index = (new_key & 0x1fffffff)%length;
2856    
2857     if ((old_index != new_index) &&
2858     ((!hash_vector) || (hash_vector[i] == 0x80000000)) &&
2859     ((new_key != empty_symbol) || (kv_vector[2*i] != empty_symbol))) {
2860    
2861     /*fprintf(stderr,"* EQ key %d moved from %x to %x; index %d to %d\n",
2862     i, old_key, new_key, old_index, new_index);*/
2863    
2864     if (index_vector[old_index] != 0) {
2865     /*fprintf(stderr,"*P1 %d\n",index_vector[old_index]);*/
2866    
2867     /* Unlink the key from the old_index chain. */
2868     if (index_vector[old_index] == i) {
2869     /*fprintf(stderr,"*P2a %d\n",next_vector[i]);*/
2870     index_vector[old_index] = next_vector[i];
2871     /* Link it into the needing rehash chain. */
2872     next_vector[i] = fixnum_value(hash_table[11]);
2873     hash_table[11] = make_fixnum(i);
2874     /*fprintf(stderr,"*P2\n");*/
2875     } else {
2876     unsigned prior = index_vector[old_index];
2877     unsigned next = next_vector[prior];
2878    
2879     /*fprintf(stderr,"*P3a %d %d\n",prior,next);*/
2880    
2881     while (next != 0) {
2882     /* fprintf(stderr,"*P3b %d %d\n",prior,next);*/
2883     if (next == i) {
2884     /* Unlink it */
2885     next_vector[prior] = next_vector[next];
2886     /* Link it into the needing rehash chain. */
2887     next_vector[next] = fixnum_value(hash_table[11]);
2888     hash_table[11] = make_fixnum(next);
2889     /*fprintf(stderr,"*P3\n");*/
2890     break;
2891     }
2892     prior = next;
2893     next = next_vector[next];
2894     };
2895     }
2896     }
2897     }
2898     }
2899     }
2900     }
2901     return (CEILING(kv_length + 2, 2));
2902     }
2903    
2904    
2905     static lispobj
2906     trans_vector(lispobj object)
2907     {
2908     struct vector *vector;
2909     int length, nwords;
2910    
2911     gc_assert(Pointerp(object));
2912    
2913     vector = (struct vector *) PTR(object);
2914    
2915     length = fixnum_value(vector->length);
2916     nwords = CEILING(length + 2, 2);
2917    
2918     return copy_large_object(object, nwords);
2919     }
2920    
2921     static int
2922     size_vector(lispobj *where)
2923     {
2924     struct vector *vector;
2925     int length, nwords;
2926    
2927     vector = (struct vector *) where;
2928     length = fixnum_value(vector->length);
2929     nwords = CEILING(length + 2, 2);
2930    
2931     return nwords;
2932     }
2933    
2934    
2935     static int
2936     scav_vector_bit(lispobj *where, lispobj object)
2937     {
2938     struct vector *vector;
2939     int length, nwords;
2940    
2941     vector = (struct vector *) where;
2942     length = fixnum_value(vector->length);
2943     nwords = CEILING(NWORDS(length, 32) + 2, 2);
2944    
2945     return nwords;
2946     }
2947    
2948     static lispobj
2949     trans_vector_bit(lispobj object)
2950     {
2951     struct vector *vector;
2952     int length, nwords;
2953    
2954     gc_assert(Pointerp(object));
2955    
2956     vector = (struct vector *) PTR(object);
2957     length = fixnum_value(vector->length);
2958     nwords = CEILING(NWORDS(length, 32) + 2, 2);
2959    
2960     return copy_large_unboxed_object(object, nwords);
2961     }
2962    
2963     static int
2964     size_vector_bit(lispobj *where)
2965     {
2966     struct vector *vector;
2967     int length, nwords;
2968    
2969     vector = (struct vector *) where;
2970     length = fixnum_value(vector->length);
2971     nwords = CEILING(NWORDS(length, 32) + 2, 2);
2972    
2973     return nwords;
2974     }
2975    
2976    
2977     static int
2978     scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
2979     {
2980     struct vector *vector;
2981     int length, nwords;
2982    
2983     vector = (struct vector *) where;
2984     length = fixnum_value(vector->length);
2985     nwords = CEILING(NWORDS(length, 16) + 2, 2);
2986    
2987     return nwords;
2988     }
2989    
2990     static lispobj
2991     trans_vector_unsigned_byte_2(lispobj object)
2992     {
2993     struct vector *vector;
2994     int length, nwords;
2995    
2996     gc_assert(Pointerp(object));
2997    
2998     vector = (struct vector *) PTR(object);
2999     length = fixnum_value(vector->length);
3000     nwords = CEILING(NWORDS(length, 16) + 2, 2);
3001    
3002     return copy_large_unboxed_object(object, nwords);
3003     }
3004    
3005     static int
3006     size_vector_unsigned_byte_2(lispobj *where)
3007     {
3008     struct vector *vector;
3009     int length, nwords;
3010    
3011     vector = (struct vector *) where;
3012     length = fixnum_value(vector->length);
3013     nwords = CEILING(NWORDS(length, 16) + 2, 2);
3014    
3015     return nwords;
3016     }
3017    
3018    
3019     static int
3020     scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
3021     {
3022     struct vector *vector;
3023     int length, nwords;
3024    
3025     vector = (struct vector *) where;
3026     length = fixnum_value(vector->length);
3027     nwords = CEILING(NWORDS(length, 8) + 2, 2);
3028    
3029     return nwords;
3030     }
3031    
3032     static lispobj
3033     trans_vector_unsigned_byte_4(lispobj object)
3034     {
3035     struct vector *vector;
3036     int length, nwords;
3037    
3038     gc_assert(Pointerp(object));
3039    
3040     vector = (struct vector *) PTR(object);
3041     length = fixnum_value(vector->length);
3042     nwords = CEILING(NWORDS(length, 8) + 2, 2);
3043    
3044     return copy_large_unboxed_object(object, nwords);
3045     }
3046    
3047     static int
3048     size_vector_unsigned_byte_4(lispobj *where)
3049     {
3050     struct vector *vector;
3051     int length, nwords;
3052    
3053     vector = (struct vector *) where;
3054     length = fixnum_value(vector->length);
3055     nwords = CEILING(NWORDS(length, 8) + 2, 2);
3056    
3057     return nwords;
3058     }
3059    
3060    
3061     static int
3062     scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
3063     {
3064     struct vector *vector;
3065     int length, nwords;
3066    
3067     vector = (struct vector *) where;
3068     length = fixnum_value(vector->length);
3069     nwords = CEILING(NWORDS(length, 4) + 2, 2);
3070    
3071     return nwords;
3072     }
3073    
3074     static lispobj
3075     trans_vector_unsigned_byte_8(lispobj object)
3076     {
3077     struct vector *vector;
3078     int length, nwords;
3079    
3080     gc_assert(Pointerp(object));
3081    
3082     vector = (struct vector *) PTR(object);
3083     length = fixnum_value(vector->length);
3084     nwords = CEILING(NWORDS(length, 4) + 2, 2);
3085    
3086     return copy_large_unboxed_object(object, nwords);
3087     }
3088    
3089     static int
3090     size_vector_unsigned_byte_8(lispobj *where)
3091     {
3092     struct vector *vector;
3093     int length, nwords;
3094    
3095     vector = (struct vector *) where;
3096     length = fixnum_value(vector->length);
3097     nwords = CEILING(NWORDS(length, 4) + 2, 2);
3098    
3099     return nwords;
3100     }
3101    
3102    
3103     static int
3104     scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
3105     {
3106     struct vector *vector;
3107     int length, nwords;
3108    
3109     vector = (struct vector *) where;
3110     length = fixnum_value(vector->length);
3111     nwords = CEILING(NWORDS(length, 2) + 2, 2);
3112    
3113     return nwords;
3114     }
3115    
3116     static lispobj
3117     trans_vector_unsigned_byte_16(lispobj object)
3118     {
3119     struct vector *vector;
3120     int length, nwords;
3121    
3122     gc_assert(Pointerp(object));
3123    
3124     vector = (struct vector *) PTR(object);
3125     length = fixnum_value(vector->length);
3126     nwords = CEILING(NWORDS(length, 2) + 2, 2);
3127    
3128     return copy_large_unboxed_object(object, nwords);
3129     }
3130    
3131     static int
3132     size_vector_unsigned_byte_16(lispobj *where)
3133     {
3134     struct vector *vector;
3135     int length, nwords;
3136    
3137     vector = (struct vector *) where;
3138     length = fixnum_value(vector->length);
3139     nwords = CEILING(NWORDS(length, 2) + 2, 2);
3140    
3141     return nwords;
3142     }
3143    
3144    
3145     static int
3146     scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
3147     {
3148     struct vector *vector;
3149     int length, nwords;
3150    
3151     vector = (struct vector *) where;
3152     length = fixnum_value(vector->length);
3153     nwords = CEILING(length + 2, 2);
3154    
3155     return nwords;
3156     }
3157    
3158     static lispobj
3159     trans_vector_unsigned_byte_32(lispobj object)
3160     {
3161     struct vector *vector;
3162     int length, nwords;
3163    
3164     gc_assert(Pointerp(object));
3165    
3166     vector = (struct vector *) PTR(object);
3167     length = fixnum_value(vector->length);
3168     nwords = CEILING(length + 2, 2);
3169    
3170     return copy_large_unboxed_object(object, nwords);
3171     }
3172    
3173     static int
3174     size_vector_unsigned_byte_32(lispobj *where)
3175     {
3176     struct vector *vector;
3177     int length, nwords;
3178    
3179     vector = (struct vector *) where;
3180     length = fixnum_value(vector->length);
3181     nwords = CEILING(length + 2, 2);
3182    
3183     return nwords;
3184     }
3185    
3186    
3187     static int
3188     scav_vector_single_float(lispobj *where, lispobj object)
3189     {
3190     struct vector *vector;
3191     int length, nwords;
3192    
3193     vector = (struct vector *) where;
3194     length = fixnum_value(vector->length);
3195     nwords = CEILING(length + 2, 2);
3196    
3197     return nwords;
3198     }
3199    
3200     static lispobj
3201     trans_vector_single_float(lispobj object)
3202     {
3203     struct vector *vector;
3204     int length, nwords;
3205    
3206     gc_assert(Pointerp(object));
3207    
3208     vector = (struct vector *) PTR(object);
3209     length = fixnum_value(vector->length);
3210     nwords = CEILING(length + 2, 2);
3211    
3212     return copy_large_unboxed_object(object, nwords);
3213     }
3214    
3215     static int
3216     size_vector_single_float(lispobj *where)
3217     {
3218     struct vector *vector;
3219     int length, nwords;
3220    
3221     vector = (struct vector *) where;
3222     length = fixnum_value(vector->length);
3223     nwords = CEILING(length + 2, 2);
3224    
3225     return nwords;
3226     }
3227    
3228    
3229     static int
3230     scav_vector_double_float(lispobj *where, lispobj object)
3231     {
3232     struct vector *vector;
3233     int length, nwords;
3234    
3235     vector = (struct vector *) where;
3236     length = fixnum_value(vector->length);
3237     nwords = CEILING(length * 2 + 2, 2);
3238    
3239     return nwords;
3240     }
3241    
3242     static lispobj
3243     trans_vector_double_float(lispobj object)
3244     {
3245     struct vector *vector;
3246     int length, nwords;
3247    
3248     gc_assert(Pointerp(object));
3249    
3250     vector = (struct vector *) PTR(object);
3251     length = fixnum_value(vector->length);
3252     nwords = CEILING(length * 2 + 2, 2);
3253    
3254     return copy_large_unboxed_object(object, nwords);
3255     }
3256    
3257     static int
3258     size_vector_double_float(lispobj *where)
3259     {
3260     struct vector *vector;
3261     int length, nwords;
3262    
3263     vector = (struct vector *) where;
3264     length = fixnum_value(vector->length);
3265     nwords = CEILING(length * 2 + 2, 2);
3266    
3267     return nwords;
3268     }
3269    
3270    
3271     #ifdef type_SimpleArrayComplexSingleFloat
3272     static int
3273     scav_vector_complex_single_float(lispobj *where, lispobj object)
3274     {
3275     struct vector *vector;
3276     int length, nwords;
3277    
3278     vector = (struct vector *) where;
3279     length = fixnum_value(vector->length);
3280     nwords = CEILING(length * 2 + 2, 2);
3281    
3282     return nwords;
3283     }
3284    
3285     static lispobj
3286     trans_vector_complex_single_float(lispobj object)
3287     {
3288     struct vector *vector;
3289     int length, nwords;
3290    
3291     gc_assert(Pointerp(object));
3292    
3293     vector = (struct vector *) PTR(object);
3294     length = fixnum_value(vector->length);
3295     nwords = CEILING(length * 2 + 2, 2);
3296    
3297     return copy_large_unboxed_object(object, nwords);
3298     }
3299    
3300     static int
3301     size_vector_complex_single_float(lispobj *where)
3302     {
3303     struct vector *vector;
3304     int length, nwords;
3305    
3306     vector = (struct vector *) where;
3307     length = fixnum_value(vector->length);
3308     nwords = CEILING(length * 2 + 2, 2);
3309    
3310     return nwords;
3311     }
3312     #endif
3313    
3314     #ifdef type_SimpleArrayComplexDoubleFloat
3315     static int
3316     scav_vector_complex_double_float(lispobj *where, lispobj object)
3317     {
3318     struct vector *vector;
3319     int length, nwords;
3320    
3321     vector = (struct vector *) where;
3322     length = fixnum_value(vector->length);
3323     nwords = CEILING(length * 4 + 2, 2);
3324    
3325     return nwords;
3326     }
3327    
3328     static lispobj
3329     trans_vector_complex_double_float(lispobj object)
3330     {
3331     struct vector *vector;
3332     int length, nwords;
3333    
3334     gc_assert(Pointerp(object));
3335    
3336     vector = (struct vector *) PTR(object);
3337     length = fixnum_value(vector->length);
3338     nwords = CEILING(length * 4 + 2, 2);
3339    
3340     return copy_large_unboxed_object(object, nwords);
3341     }
3342    
3343     static int
3344     size_vector_complex_double_float(lispobj *where)
3345     {
3346     struct vector *vector;
3347     int length, nwords;
3348    
3349     vector = (struct vector *) where;
3350     length = fixnum_value(vector->length);
3351     nwords = CEILING(length * 4 + 2, 2);
3352    
3353     return nwords;
3354     }
3355     #endif
3356    
3357    
3358     /* Weak Pointers */
3359    
3360     /* XX Hack adapted from cgc.c; These don't work too well with the
3361     gencgc as a list of the weak pointers is maintained within the
3362     objects which causes writes to the pages. A limited attempt is made
3363     to avoid unnecessary writes, but this needs a re-think. */
3364    
3365     #define WEAK_POINTER_NWORDS \
3366     CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
3367    
3368     static int
3369     scav_weak_pointer(lispobj *where, lispobj object)
3370     {
3371     struct weak_pointer *wp = weak_pointers;
3372     /* Push the weak pointer onto the list of weak pointers.
3373     * Do I have to watch for duplicates? Originally this was
3374     * part of trans_weak_pointer but that didn't work in the
3375     * case where the WP was in a promoted region.
3376     */
3377    
3378     /* Check if it's already in the list. */
3379     while(wp != NULL) {
3380     if(wp == (struct weak_pointer*)where)
3381     break;
3382     wp = wp->next;
3383     }
3384     if(wp == NULL) {
3385     /* Add it to the start of the list. */
3386     wp = (struct weak_pointer*)where;
3387     if (wp->next != weak_pointers)
3388     wp->next = weak_pointers;
3389     /* else
3390     fprintf(stderr,"Avoided write to weak pointer.\n");*/
3391     weak_pointers = wp;
3392     }
3393    
3394     /* Do not let GC scavenge the value slot of the weak pointer
3395     * (that is why it is a weak pointer).
3396     */
3397    
3398     return WEAK_POINTER_NWORDS;
3399     }
3400    
3401     static lispobj
3402     trans_weak_pointer(lispobj object)
3403     {
3404     lispobj copy;
3405     struct weak_pointer *wp;
3406    
3407     gc_assert(Pointerp(object));
3408    
3409     #if defined(DEBUG_WEAK)
3410     printf("Transporting weak pointer from 0x%08x\n", object);
3411     #endif
3412    
3413     /* Need to remember where all the weak pointers are that have */
3414     /* been transported so they can be fixed up in a post-GC pass. */
3415    
3416     copy = copy_object(object, WEAK_POINTER_NWORDS);
3417     /* wp = (struct weak_pointer *) PTR(copy);*/
3418    
3419    
3420     /* Push the weak pointer onto the list of weak pointers. */
3421     /* wp->next = weak_pointers;
3422     weak_pointers = wp;*/
3423    
3424     return copy;
3425     }
3426    
3427     static int
3428     size_weak_pointer(lispobj *where)
3429     {
3430     return WEAK_POINTER_NWORDS;
3431     }
3432    
3433     void scan_weak_pointers(void)
3434     {
3435     struct weak_pointer *wp;
3436     for (wp = weak_pointers; wp != NULL; wp = wp->next) {
3437     lispobj value = wp->value;
3438     lispobj first, *first_pointer;
3439    
3440     first_pointer = (lispobj *)PTR(value);
3441    
3442     /* fprintf(stderr,"Weak pointer at 0x%08x\n", (unsigned long) wp));
3443     fprintf(stderr,"Value: 0x%08x\n", (unsigned long) value));*/
3444    
3445     if (Pointerp(value) && from_space_p(value)) {
3446     /* Now, we need to check if the object has been forwarded. If
3447     * it has been, the weak pointer is still good and needs to be
3448     * updated. Otherwise, the weak pointer needs to be nil'ed
3449     * out. */
3450    
3451     if (first_pointer[0] == 0x01)
3452     wp->value = first_pointer[1];
3453     else {
3454     /* break it */
3455     /*fprintf(stderr,"Broken.\n"));*/
3456     wp->value = NIL;
3457     wp->broken = T;
3458     }
3459     }
3460     }
3461     }
3462    
3463    
3464     /* Scavenged Hooks */
3465    
3466     #define SCAVENGER_HOOK_NWORDS \
3467     CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
3468    
3469     static int
3470 dtc 1.5 scav_scavenger_hook(lispobj *where, lispobj object)
3471 dtc 1.1 {
3472 dtc 1.5 struct scavenger_hook *scav_hook = (struct scavenger_hook *)where;
3473     lispobj old_value = scav_hook->value;
3474 dtc 1.1
3475     /* fprintf(stderr,"scav scav_hook %x; value %x\n",where,old_value);*/
3476    
3477     /* Scavenge the value */
3478     scavenge(where+1, 1);
3479    
3480 dtc 1.5 if (scav_hook->value != old_value) {
3481     /* Value object has moved */
3482     /* fprintf(stderr," value object moved to %x\n",scav_hook->value);*/
3483    
3484     /* Check if this hook is already noted. */
3485     /* fprintf(stderr," next=%x sh hooks=%x\n",scav_hook->next,scavenger_hooks); */
3486     if (scav_hook->next == NULL) {
3487     /* fprintf(stderr," adding to scavenger_hooks\n");*/
3488     scav_hook->next = scavenger_hooks;
3489     scavenger_hooks = (int)where | type_OtherPointer;
3490 dtc 1.1 }
3491     }
3492    
3493     /* Scavenge the function and the tail scavenge_hook */
3494     return 2;
3495     }
3496    
3497     static lispobj
3498     trans_scavenger_hook(lispobj object)
3499     {
3500     lispobj copy;
3501     gc_assert(Pointerp(object));
3502     /* printf("Transporting scav pointer from 0x%08x\n", object);*/
3503     copy = copy_object(object, SCAVENGER_HOOK_NWORDS);
3504     return copy;
3505     }
3506    
3507     static int
3508     size_scavenger_hook(lispobj *where)
3509     {
3510     return SCAVENGER_HOOK_NWORDS;
3511     }
3512    
3513    
3514     /* Initialization */
3515    
3516     static int
3517     scav_lose(lispobj *where, lispobj object)
3518     {
3519     fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x\n",
3520     (unsigned long) object);
3521     lose(NULL);
3522     return 0;
3523     }
3524    
3525     static lispobj
3526     trans_lose(lispobj object)
3527     {
3528     fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n",
3529     (unsigned long) object);
3530     lose(NULL);
3531     return NIL;
3532     }
3533    
3534     static int
3535     size_lose(lispobj *where)
3536     {
3537     fprintf(stderr, "Size lossage. No size function for object at 0x%08x\n",
3538     (unsigned long) where);
3539     fprintf(stderr, "First word of object: 0x%08x\n",
3540     (unsigned long) *where);
3541     return 1;
3542     }
3543    
3544     static void
3545     gc_init_tables(void)
3546     {
3547     int i;
3548    
3549     /* Scavenge Table */
3550     for (i = 0; i < 256; i++)
3551     scavtab[i] = scav_lose;
3552    
3553     for (i = 0; i < 32; i++) {
3554     scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
3555     scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
3556     /* OtherImmediate0 */
3557     scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
3558     scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
3559     scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
3560     /* OtherImmediate1 */
3561     scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
3562     }
3563    
3564     scavtab[type_Bignum] = scav_unboxed;
3565     scavtab[type_Ratio] = scav_boxed;
3566     scavtab[type_SingleFloat] = scav_unboxed;
3567     scavtab[type_DoubleFloat] = scav_unboxed;
3568     scavtab[type_Complex] = scav_boxed;
3569     #ifdef type_ComplexSingleFloat
3570     scavtab[type_ComplexSingleFloat] = scav_unboxed;
3571     #endif
3572     #ifdef type_ComplexDoubleFloat
3573     scavtab[type_ComplexDoubleFloat] = scav_unboxed;
3574     #endif
3575     scavtab[type_SimpleArray] = scav_boxed;
3576     scavtab[type_SimpleString] = scav_string;
3577     scavtab[type_SimpleBitVector] = scav_vector_bit;
3578     scavtab[type_SimpleVector] = scav_vector;
3579     scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
3580     scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
3581     scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
3582     scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
3583     scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
3584     #ifdef type_SimpleArraySignedByte8
3585     scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
3586     #endif
3587     #ifdef type_SimpleArraySignedByte16
3588     scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
3589     #endif
3590     #ifdef type_SimpleArraySignedByte30
3591     scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
3592     #endif
3593     #ifdef type_SimpleArraySignedByte32
3594     scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
3595     #endif
3596     scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
3597     scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
3598     #ifdef type_SimpleArrayComplexSingleFloat
3599     scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
3600     #endif
3601     #ifdef type_SimpleArrayComplexDoubleFloat
3602     scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
3603     #endif
3604     scavtab[type_ComplexString] = scav_boxed;
3605     scavtab[type_ComplexBitVector] = scav_boxed;
3606     scavtab[type_ComplexVector] = scav_boxed;
3607     scavtab[type_ComplexArray] = scav_boxed;
3608     scavtab[type_CodeHeader] = scav_code_header;
3609     /*scavtab[type_FunctionHeader] = scav_function_header;*/
3610     /*scavtab[type_ClosureFunctionHeader] = scav_function_header;*/
3611     /*scavtab[type_ReturnPcHeader] = scav_return_pc_header;*/
3612     #ifdef i386
3613     scavtab[type_ClosureHeader] = scav_closure_header;
3614     scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
3615     scavtab[type_ByteCodeFunction] = scav_closure_header;
3616     scavtab[type_ByteCodeClosure] = scav_closure_header;
3617     scavtab[type_DylanFunctionHeader] = scav_closure_header;
3618     #else
3619     scavtab[type_ClosureHeader] = scav_boxed;
3620     scavtab[type_FuncallableInstanceHeader] = scav_boxed;
3621     scavtab[type_ByteCodeFunction] = scav_boxed;
3622     scavtab[type_ByteCodeClosure] = scav_boxed;
3623     scavtab[type_DylanFunctionHeader] = scav_boxed;
3624     #endif
3625     scavtab[type_ValueCellHeader] = scav_boxed;
3626     scavtab[type_SymbolHeader] = scav_boxed;
3627     scavtab[type_BaseChar] = scav_immediate;
3628     scavtab[type_Sap] = scav_unboxed;
3629     scavtab[type_UnboundMarker] = scav_immediate;
3630     scavtab[type_WeakPointer] = scav_weak_pointer;
3631     scavtab[type_InstanceHeader] = scav_boxed;
3632     scavtab[type_Fdefn] = scav_fdefn;
3633     scavtab[type_ScavengerHook] = scav_scavenger_hook;
3634    
3635     /* Transport Other Table */
3636     for (i = 0; i < 256; i++)
3637     transother[i] = trans_lose;
3638    
3639     transother[type_Bignum] = trans_unboxed;
3640     transother[type_Ratio] = trans_boxed;
3641     transother[type_SingleFloat] = trans_unboxed;
3642     transother[type_DoubleFloat] = trans_unboxed;
3643     transother[type_Complex] = trans_boxed;
3644     #ifdef type_ComplexSingleFloat
3645     transother[type_ComplexSingleFloat] = trans_unboxed;
3646     #endif
3647     #ifdef type_ComplexDoubleFloat
3648     transother[type_ComplexDoubleFloat] = trans_unboxed;
3649     #endif
3650     transother[type_SimpleArray] = trans_boxed_large;
3651     transother[type_SimpleString] = trans_string;
3652     transother[type_SimpleBitVector] = trans_vector_bit;
3653     transother[type_SimpleVector] = trans_vector;
3654     transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
3655     transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
3656     transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
3657     transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
3658     transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
3659     #ifdef type_SimpleArraySignedByte8
3660     transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
3661     #endif
3662     #ifdef type_SimpleArraySignedByte16
3663     transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
3664     #endif
3665     #ifdef type_SimpleArraySignedByte30
3666     transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
3667     #endif
3668     #ifdef type_SimpleArraySignedByte32
3669     transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
3670     #endif
3671     transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
3672     transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
3673     #ifdef type_SimpleArrayComplexSingleFloat
3674     transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
3675     #endif
3676     #ifdef type_SimpleArrayComplexDoubleFloat
3677     transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
3678     #endif
3679     transother[type_ComplexString] = trans_boxed;
3680     transother[type_ComplexBitVector] = trans_boxed;
3681     transother[type_ComplexVector] = trans_boxed;
3682     transother[type_ComplexArray] = trans_boxed;
3683     transother[type_CodeHeader] = trans_code_header;
3684     transother[type_FunctionHeader] = trans_function_header;
3685     transother[type_ClosureFunctionHeader] = trans_function_header;
3686     transother[type_ReturnPcHeader] = trans_return_pc_header;
3687     transother[type_ClosureHeader] = trans_boxed;
3688     transother[type_FuncallableInstanceHeader] = trans_boxed;
3689     transother[type_ByteCodeFunction] = trans_boxed;
3690     transother[type_ByteCodeClosure] = trans_boxed;
3691     transother[type_ValueCellHeader] = trans_boxed;
3692     transother[type_SymbolHeader] = trans_boxed;
3693     transother[type_BaseChar] = trans_immediate;
3694     transother[type_Sap] = trans_unboxed;
3695     transother[type_UnboundMarker] = trans_immediate;
3696     transother[type_WeakPointer] = trans_weak_pointer;
3697     transother[type_InstanceHeader] = trans_boxed;
3698     transother[type_Fdefn] = trans_boxed;
3699     transother[type_ScavengerHook] = trans_scavenger_hook;
3700    
3701     /* Size table */
3702    
3703     for (i = 0; i < 256; i++)
3704     sizetab[i] = size_lose;
3705    
3706     for (i = 0; i < 32; i++) {
3707     sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
3708     sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
3709     /* OtherImmediate0 */
3710     sizetab[type_ListPointer|(i<<3)] = size_pointer;
3711     sizetab[type_OddFixnum|(i<<3)] = size_immediate;
3712     sizetab[type_InstancePointer|(i<<3)] = size_pointer;
3713     /* OtherImmediate1 */
3714     sizetab[type_OtherPointer|(i<<3)] = size_pointer;
3715     }
3716    
3717     sizetab[type_Bignum] = size_unboxed;
3718     sizetab[type_Ratio] = size_boxed;
3719     sizetab[type_SingleFloat] = size_unboxed;
3720     sizetab[type_DoubleFloat] = size_unboxed;
3721     sizetab[type_Complex] = size_boxed;
3722     #ifdef type_ComplexSingleFloat
3723     sizetab[type_ComplexSingleFloat] = size_unboxed;
3724     #endif
3725     #ifdef type_ComplexDoubleFloat
3726     sizetab[type_ComplexDoubleFloat] = size_unboxed;
3727     #endif
3728     sizetab[type_SimpleArray] = size_boxed;
3729     sizetab[type_SimpleString] = size_string;
3730     sizetab[type_SimpleBitVector] = size_vector_bit;
3731     sizetab[type_SimpleVector] = size_vector;
3732     sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
3733     sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
3734     sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
3735     sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
3736     sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
3737     #ifdef type_SimpleArraySignedByte8
3738     sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
3739     #endif
3740     #ifdef type_SimpleArraySignedByte16
3741     sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
3742     #endif
3743     #ifdef type_SimpleArraySignedByte30
3744     sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
3745     #endif
3746     #ifdef type_SimpleArraySignedByte32
3747     sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
3748     #endif
3749     sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
3750     sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
3751     #ifdef type_SimpleArrayComplexSingleFloat
3752     sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
3753     #endif
3754     #ifdef type_SimpleArrayComplexDoubleFloat
3755     sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
3756     #endif
3757     sizetab[type_ComplexString] = size_boxed;
3758     sizetab[type_ComplexBitVector] = size_boxed;
3759     sizetab[type_ComplexVector] = size_boxed;
3760     sizetab[type_ComplexArray] = size_boxed;
3761     sizetab[type_CodeHeader] = size_code_header;
3762     #if 0
3763     /* Shouldn't see these so just lose if it happens */
3764     sizetab[type_FunctionHeader] = size_function_header;
3765     sizetab[type_ClosureFunctionHeader] = size_function_header;
3766     sizetab[type_ReturnPcHeader] = size_return_pc_header;
3767     #endif
3768     sizetab[type_ClosureHeader] = size_boxed;
3769     sizetab[type_FuncallableInstanceHeader] = size_boxed;
3770     sizetab[type_ValueCellHeader] = size_boxed;
3771     sizetab[type_SymbolHeader] = size_boxed;
3772     sizetab[type_BaseChar] = size_immediate;
3773     sizetab[type_Sap] = size_unboxed;
3774     sizetab[type_UnboundMarker] = size_immediate;
3775     sizetab[type_WeakPointer] = size_weak_pointer;
3776     sizetab[type_InstanceHeader] = size_boxed;
3777     sizetab[type_Fdefn] = size_boxed;
3778     sizetab[type_ScavengerHook] = size_scavenger_hook;
3779     }
3780    
3781    
3782    
3783    
3784    
3785     /* Scan an area looking for an object which encloses the given
3786     pointer. Returns the object start on success or NULL on failure. */
3787     static lispobj*
3788     search_space(lispobj *start, size_t words, lispobj *pointer)
3789     {
3790     while(words > 0) {
3791     size_t count = 1;
3792     lispobj thing = *start;
3793    
3794     /* If thing is an immediate then this is a cons */
3795     if (Pointerp(thing)
3796     || ((thing & 3) == 0) /* fixnum */
3797     || (TypeOf(thing) == type_BaseChar)
3798     || (TypeOf(thing) == type_UnboundMarker))
3799     count = 2;
3800     else
3801     count = (sizetab[TypeOf(thing)])(start);
3802    
3803     /* Check if the pointer is within this object? */
3804     if ((pointer >= start) && (pointer < (start+count))) {
3805     /* Found it. */
3806     /* fprintf(stderr,"* Found %x in %x %x\n",pointer, start, thing);*/
3807     return(start);
3808     }
3809    
3810     /* Round up the count */
3811     count = CEILING(count,2);
3812    
3813     start += count;
3814     words -= count;
3815     }
3816     return (NULL);
3817     }
3818    
3819     static lispobj*
3820     search_read_only_space(lispobj *pointer)
3821     {
3822     lispobj* start = (lispobj*)READ_ONLY_SPACE_START;
3823     lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
3824     if ((pointer < start) || (pointer >= end))
3825     return NULL;
3826     return (search_space(start, (pointer+2)-start, pointer));
3827     }
3828    
3829     static lispobj*
3830     search_static_space(lispobj *pointer)
3831     {
3832     lispobj* start = (lispobj*)static_space;
3833     lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER);
3834     if ((pointer < start) || (pointer >= end))
3835     return NULL;
3836     return (search_space(start, (pointer+2)-start, pointer));
3837     }
3838    
3839     /* Faster version for searching the dynamic space. This will work even
3840     if the object is in a current allocation region. */
3841     static lispobj*
3842     search_dynamic_space(lispobj *pointer)
3843     {
3844     int page_index = find_page_index(pointer);
3845     lispobj *start;
3846    
3847     /* Address may be invalid - do some checks. */
3848     if ((page_index == -1) || (page_table[page_index].allocated == FREE_PAGE))
3849     return NULL;
3850     start = (lispobj *)((void *)page_address(page_index)
3851     + page_table[page_index].first_object_offset);
3852     return (search_space(start, (pointer+2)-start, pointer));
3853     }
3854    
3855     int
3856     valid_dynamic_space_pointer(lispobj *pointer)
3857     {
3858     lispobj *start_addr;
3859    
3860     /* Find the object start address */
3861     if ((start_addr = search_dynamic_space(pointer)) == NULL)
3862     return FALSE;
3863    
3864     /* Need to allow raw pointers into Code objects for return
3865     addresses. This will also pickup pointers to functions in code
3866     objects. */
3867     if (TypeOf(*start_addr) == type_CodeHeader)
3868     /* X Could do some further checks here. */
3869     return TRUE;
3870    
3871     /* If it's not a return address then it needs to be a valid lisp
3872     pointer. */
3873     if (!Pointerp((lispobj)pointer))
3874     return FALSE;
3875    
3876     /* Check that the object pointed to is consistent with the pointer
3877     low tag. */
3878     switch (LowtagOf((lispobj)pointer)) {
3879     case type_FunctionPointer:
3880     /* Start_addr should be the enclosing code object, or a closure
3881     header. */
3882     switch (TypeOf(*start_addr)) {
3883     case type_CodeHeader:
3884     /* This case is probably caught above. */
3885     break;
3886     case type_ClosureHeader:
3887     case type_FuncallableInstanceHeader:
3888     case type_ByteCodeFunction:
3889     case type_ByteCodeClosure:
3890     case type_DylanFunctionHeader:
3891     if ((int)pointer != ((int)start_addr+type_FunctionPointer)) {
3892 dtc 1.6 if (gencgc_verbose)
3893     fprintf(stderr,"*Wf2: %x %x %x\n", pointer, start_addr, *start_addr);
3894 dtc 1.1 return FALSE;
3895     }
3896     break;
3897     default:
3898 dtc 1.6 if (gencgc_verbose)
3899     fprintf(stderr,"*Wf3: %x %x %x\n", pointer, start_addr, *start_addr);
3900 dtc 1.1 return FALSE;
3901     }
3902     break;