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

Diff of /src/lisp/gencgc.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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