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