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

Contents of /src/lisp/gencgc.c

Parent Directory Parent Directory | Revision Log Revision Log


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