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

Diff of /src/lisp/gencgc.c

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

revision 1.11 by dtc, Sat Mar 21 07:45:51 1998 UTC revision 1.11.2.3 by dtc, Thu Jun 22 12:55:39 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");  #if 0
2212        fprintf(stderr, "* FF\n");
2213    #endif
2214      /* If so then follow it. */      /* If so then follow it. */
2215      fixups_vector = (struct vector *)PTR((lispobj)fixups_vector->length);      fixups_vector = (struct vector *) PTR((lispobj) fixups_vector->length);
2216    }    }
2217    
2218    /*  fprintf(stderr,"Got the fixups\n");*/  #if 0
2219      fprintf(stderr, "Got the fixups\n");
2220    #endif
2221    
2222    if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {    if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
2223      /* Got the fixups for the code block.  Now work through the vector,      /*
2224         and apply a fixup at each address. */       * Got the fixups for the code block.  Now work through the
2225         * vector, and apply a fixup at each address.
2226         */
2227      int length = fixnum_value(fixups_vector->length);      int length = fixnum_value(fixups_vector->length);
2228      int i;      int i;
2229      for (i = 0; i < length; i++) {      for (i = 0; i < length; i++) {
2230        unsigned offset = fixups_vector->data[i];        unsigned offset = fixups_vector->data[i];
2231        /* Now check the current value of offset. */        /* Now check the current value of offset. */
2232        unsigned old_value = *(unsigned *)((unsigned)code_start_addr + offset);        unsigned old_value = *(unsigned *) ((unsigned) code_start_addr + offset);
2233    
2234        /* If it's within the old_code object then it must be an        /*
2235           absolute fixup (relative ones are not saved) */         * If it's within the old_code object then it must be an
2236        if ((old_value >= (unsigned)old_code)         * absolute fixup (relative ones are not saved).
2237            && (old_value < ((unsigned)old_code + nwords*4)))         */
2238          if (old_value >= (unsigned) old_code
2239              && old_value < (unsigned) old_code + nwords * 4)
2240          /* So add the dispacement. */          /* So add the dispacement. */
2241          *(unsigned *)((unsigned)code_start_addr + offset) = old_value          *(unsigned *) ((unsigned) code_start_addr + offset) = old_value
2242            + displacement;            + displacement;
2243        else        else
2244          /* It is outside the old code object so it must be a relative          /*
2245             fixup (absolute fixups are not saved). So subtract the           * It is outside the old code object so it must be a relative
2246             displacement. */           * fixup (absolute fixups are not saved). So subtract the
2247          *(unsigned *)((unsigned)code_start_addr + offset) = old_value           * displacement.
2248             */
2249            *(unsigned *) ((unsigned) code_start_addr + offset) = old_value
2250            - displacement;            - displacement;
2251      }      }
2252    }    }
2253    
2254    /* Check for possible errors. */    /* Check for possible errors. */
2255    if (check_code_fixups)    if (check_code_fixups)
2256      sniff_code_object(new_code,displacement);      sniff_code_object(new_code, displacement);
2257  }  }
2258    
2259  static struct code *  static struct code * trans_code(struct code *code)
 trans_code(struct code *code)  
2260  {  {
2261    struct code *new_code;    struct code *new_code;
2262    lispobj l_code, l_new_code;    lispobj l_code, l_new_code;
2263    int nheader_words, ncode_words, nwords;    int nheader_words, ncode_words, nwords;
2264    unsigned long displacement;    unsigned long displacement;
2265    lispobj fheaderl, *prev_pointer;    lispobj fheaderl, *prev_pointer;
2266    
2267    /*fprintf(stderr,"\nTransporting code object located at 0x%08x.\n",  #if 0
2268            (unsigned long) code);*/    fprintf(stderr, "\nTransporting code object located at 0x%08x.\n",
2269              (unsigned long) code);
2270    /* if object has already been transported, just return pointer */  #endif
2271    if (*((lispobj *)code) == 0x01)  
2272      return (struct code*)(((lispobj *)code)[1]);    /* If object has already been transported, just return pointer */
2273      if (*(lispobj *) code == 0x01)
2274        return (struct code*) (((lispobj *) code)[1]);
2275    
2276    gc_assert(TypeOf(code->header) == type_CodeHeader);    gc_assert(TypeOf(code->header) == type_CodeHeader);
2277    
2278    /* prepare to transport the code vector */    /* prepare to transport the code vector */
2279    l_code = (lispobj) code | type_OtherPointer;    l_code = (lispobj) code | type_OtherPointer;
2280    
2281    ncode_words = fixnum_value(code->code_size);    ncode_words = fixnum_value(code->code_size);
2282    nheader_words = HeaderValue(code->header);    nheader_words = HeaderValue(code->header);
2283    nwords = ncode_words + nheader_words;    nwords = ncode_words + nheader_words;
2284    nwords = CEILING(nwords, 2);    nwords = CEILING(nwords, 2);
2285    
2286    l_new_code = copy_large_object(l_code, nwords);    l_new_code = copy_large_object(l_code, nwords);
2287    new_code = (struct code *) PTR(l_new_code);    new_code = (struct code *) PTR(l_new_code);
2288    
2289    /* May not have been moved. */    /* May not have been moved. */
2290    if (new_code == code)    if (new_code == code)
2291      return new_code;      return new_code;
2292    
2293    displacement = l_new_code - l_code;    displacement = l_new_code - l_code;
2294    
2295    /*fprintf(stderr,"Old code object at 0x%08x, new code object at 0x%08x.\n",  #if 0
2296           (unsigned long) code, (unsigned long) new_code);    fprintf(stderr, "Old code object at 0x%08x, new code object at 0x%08x.\n",
2297    fprintf(stderr,"Code object is %d words long.\n", nwords);*/            (unsigned long) code, (unsigned long) new_code);
2298      fprintf(stderr, "Code object is %d words long.\n", nwords);
2299    #endif
2300    
2301    /* set forwarding pointer */    /* set forwarding pointer */
2302    ((lispobj *)code)[0] = 0x01;    ((lispobj *) code)[0] = 0x01;
2303    ((lispobj *)code)[1] = l_new_code;    ((lispobj *) code)[1] = l_new_code;
2304    
2305    /* set forwarding pointers for all the function headers in the    /*
2306       code object.  also fix all self pointers */     * Set forwarding pointers for all the function headers in the code
2307       * object; also fix all self pointers.
2308       */
2309    
2310    fheaderl = code->entry_points;    fheaderl = code->entry_points;
2311    prev_pointer = &new_code->entry_points;    prev_pointer = &new_code->entry_points;
2312    
2313    while (fheaderl != NIL) {    while (fheaderl != NIL) {
2314      struct function *fheaderp, *nfheaderp;      struct function *fheaderp, *nfheaderp;
2315      lispobj nfheaderl;      lispobj nfheaderl;
2316    
2317      fheaderp = (struct function *) PTR(fheaderl);      fheaderp = (struct function *) PTR(fheaderl);
2318      gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);      gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
2319    
2320      /* calcuate the new function pointer and the new */      /*
2321      /* function header */       * Calcuate the new function pointer and the new function header.
2322         */
2323      nfheaderl = fheaderl + displacement;      nfheaderl = fheaderl + displacement;
2324      nfheaderp = (struct function *) PTR(nfheaderl);      nfheaderp = (struct function *) PTR(nfheaderl);
2325    
2326      /* set forwarding pointer */      /* set forwarding pointer */
2327      ((lispobj *)fheaderp)[0] = 0x01;      ((lispobj *) fheaderp)[0] = 0x01;
2328      ((lispobj *)fheaderp)[1] = nfheaderl;      ((lispobj *) fheaderp)[1] = nfheaderl;
2329    
2330      /* fix self pointer */      /* Fix self pointer */
2331      nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;      nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;
2332    
2333      *prev_pointer = nfheaderl;      *prev_pointer = nfheaderl;
2334    
2335      fheaderl = fheaderp->next;      fheaderl = fheaderp->next;
2336      prev_pointer = &nfheaderp->next;      prev_pointer = &nfheaderp->next;
2337    }    }
2338    
2339    /*  sniff_code_object(new_code,displacement);*/  #if 0
2340    apply_code_fixups(code,new_code);    sniff_code_object(new_code, displacement);
2341    #endif
2342      apply_code_fixups(code, new_code);
2343    
2344    return new_code;    return new_code;
2345  }  }
2346    
2347  static int  static int scav_code_header(lispobj *where, lispobj object)
 scav_code_header(lispobj *where, lispobj object)  
2348  {  {
2349    struct code *code;    struct code *code;
2350    int nheader_words, ncode_words, nwords;    int nheader_words, ncode_words, nwords;
2351    lispobj fheaderl;    lispobj fheaderl;
2352    struct function *fheaderp;    struct function *fheaderp;
2353    
2354    code = (struct code *) where;    code = (struct code *) where;
2355    ncode_words = fixnum_value(code->code_size);    ncode_words = fixnum_value(code->code_size);
2356    nheader_words = HeaderValue(object);    nheader_words = HeaderValue(object);
# Line 2146  scav_code_header(lispobj *where, lispobj Line 2360  scav_code_header(lispobj *where, lispobj
2360    /* Scavenge the boxed section of the code data block */    /* Scavenge the boxed section of the code data block */
2361    scavenge(where + 1, nheader_words - 1);    scavenge(where + 1, nheader_words - 1);
2362    
2363    /* Scavenge the boxed section of each function object in the */    /*
2364    /* code data block */     * Scavenge the boxed section of each function object in the code
2365       * data block
2366       */
2367    fheaderl = code->entry_points;    fheaderl = code->entry_points;
2368    while (fheaderl != NIL) {    while (fheaderl != NIL) {
2369      fheaderp = (struct function *) PTR(fheaderl);      fheaderp = (struct function *) PTR(fheaderl);
2370      gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);      gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
2371    
2372      scavenge(&fheaderp->name, 1);      scavenge(&fheaderp->name, 1);
2373      scavenge(&fheaderp->arglist, 1);      scavenge(&fheaderp->arglist, 1);
2374      scavenge(&fheaderp->type, 1);      scavenge(&fheaderp->type, 1);
2375    
2376      fheaderl = fheaderp->next;      fheaderl = fheaderp->next;
2377    }    }
2378    
2379    return nwords;    return nwords;
2380  }  }
2381    
2382  static lispobj  static lispobj trans_code_header(lispobj object)
 trans_code_header(lispobj object)  
2383  {  {
2384          struct code *ncode;          struct code *ncode;
2385    
# Line 2172  trans_code_header(lispobj object) Line 2387  trans_code_header(lispobj object)
2387          return (lispobj) ncode | type_OtherPointer;          return (lispobj) ncode | type_OtherPointer;
2388  }  }
2389    
2390  static int  static int size_code_header(lispobj *where)
 size_code_header(lispobj *where)  
2391  {  {
2392          struct code *code;          struct code *code;
2393          int nheader_words, ncode_words, nwords;          int nheader_words, ncode_words, nwords;
2394    
2395          code = (struct code *) where;          code = (struct code *) where;
2396    
2397          ncode_words = fixnum_value(code->code_size);          ncode_words = fixnum_value(code->code_size);
2398          nheader_words = HeaderValue(code->header);          nheader_words = HeaderValue(code->header);
2399          nwords = ncode_words + nheader_words;          nwords = ncode_words + nheader_words;
# Line 2189  size_code_header(lispobj *where) Line 2403  size_code_header(lispobj *where)
2403  }  }
2404    
2405    
2406  static int  static int scav_return_pc_header(lispobj *where, lispobj object)
 scav_return_pc_header(lispobj *where, lispobj object)  
2407  {  {
2408      fprintf(stderr, "GC lossage.  Should not be scavenging a ");      fprintf(stderr, "GC lossage.  Should not be scavenging a ");
2409      fprintf(stderr, "Return PC Header.\n");      fprintf(stderr, "Return PC Header.\n");
# Line 2200  scav_return_pc_header(lispobj *where, li Line 2413  scav_return_pc_header(lispobj *where, li
2413      return 0;      return 0;
2414  }  }
2415    
2416  static lispobj  static lispobj trans_return_pc_header(lispobj object)
 trans_return_pc_header(lispobj object)  
2417  {  {
2418    struct function *return_pc;    struct function *return_pc;
2419    unsigned long offset;    unsigned long offset;
2420    struct code *code, *ncode;    struct code *code, *ncode;
2421    
2422    fprintf(stderr,"*** trans_return_pc_header: will this work?\n");    fprintf(stderr, "*** trans_return_pc_header: will this work?\n");
2423    
2424    return_pc = (struct function *) PTR(object);    return_pc = (struct function *) PTR(object);
2425    offset = HeaderValue(return_pc->header) * 4;    offset = HeaderValue(return_pc->header) * 4;
2426    
2427    /* Transport the whole code object */    /* Transport the whole code object */
2428    code = (struct code *) ((unsigned long) return_pc - offset);    code = (struct code *) ((unsigned long) return_pc - offset);
2429    ncode = trans_code(code);    ncode = trans_code(code);
2430    
2431    return ((lispobj) ncode + offset) | type_OtherPointer;    return ((lispobj) ncode + offset) | type_OtherPointer;
2432  }  }
2433    
2434  /* On the 386, closures hold a pointer to the raw address instead of the  /*
2435     function object. */   * On the 386, closures hold a pointer to the raw address instead of
2436     * the function object.
2437     */
2438  #ifdef i386  #ifdef i386
2439  static int  static int scav_closure_header(lispobj *where, lispobj object)
 scav_closure_header(lispobj *where, lispobj object)  
2440  {  {
2441    struct closure *closure;    struct closure *closure;
2442    lispobj fun;    lispobj fun;
# Line 2235  scav_closure_header(lispobj *where, lisp Line 2448  scav_closure_header(lispobj *where, lisp
2448       write unnecessarily. */       write unnecessarily. */
2449    if (closure->function != fun + RAW_ADDR_OFFSET)    if (closure->function != fun + RAW_ADDR_OFFSET)
2450      closure->function = fun + RAW_ADDR_OFFSET;      closure->function = fun + RAW_ADDR_OFFSET;
2451    
2452    return 2;    return 2;
2453  }  }
2454  #endif  #endif
2455    
2456  static int  static int scav_function_header(lispobj *where, lispobj object)
 scav_function_header(lispobj *where, lispobj object)  
2457  {  {
2458      fprintf(stderr, "GC lossage.  Should not be scavenging a ");      fprintf(stderr, "GC lossage.  Should not be scavenging a ");
2459      fprintf(stderr, "Function Header.\n");      fprintf(stderr, "Function Header.\n");
# Line 2251  scav_function_header(lispobj *where, lis Line 2463  scav_function_header(lispobj *where, lis
2463      return 0;      return 0;
2464  }  }
2465    
2466  static lispobj  static lispobj trans_function_header(lispobj object)
 trans_function_header(lispobj object)  
2467  {  {
2468    struct function *fheader;    struct function *fheader;
2469    unsigned long offset;    unsigned long offset;
2470    struct code *code, *ncode;    struct code *code, *ncode;
2471    
2472    fheader = (struct function *) PTR(object);    fheader = (struct function *) PTR(object);
2473    offset = HeaderValue(fheader->header) * 4;    offset = HeaderValue(fheader->header) * 4;
2474    
2475    /* Transport the whole code object */    /* Transport the whole code object */
2476    code = (struct code *) ((unsigned long) fheader - offset);    code = (struct code *) ((unsigned long) fheader - offset);
2477    ncode = trans_code(code);    ncode = trans_code(code);
2478    
2479    return ((lispobj) ncode + offset) | type_FunctionPointer;    return ((lispobj) ncode + offset) | type_FunctionPointer;
2480  }  }
2481    
# Line 2272  trans_function_header(lispobj object) Line 2483  trans_function_header(lispobj object)
2483  /* Instances */  /* Instances */
2484    
2485  #if DIRECT_SCAV  #if DIRECT_SCAV
2486  static int  static int scav_instance_pointer(lispobj *where, lispobj object)
 scav_instance_pointer(lispobj *where, lispobj object)  
2487  {  {
2488    if (from_space_p(object)) {    if (from_space_p(object)) {
2489      lispobj first, *first_pointer;      lispobj first, *first_pointer;
2490    
2491      /* object is a pointer into from space.  check to see */      /*
2492      /* if it has been forwarded */       * object is a pointer into from space.  check to see if it has
2493         * been forwarded
2494         */
2495      first_pointer = (lispobj *) PTR(object);      first_pointer = (lispobj *) PTR(object);
2496      first = *first_pointer;      first = *first_pointer;
2497    
2498      if (first == 0x01)      if (first == 0x01)
2499        /* Forwarded. */        /* Forwarded. */
2500        first = first_pointer[1];        first = first_pointer[1];
# Line 2298  scav_instance_pointer(lispobj *where, li Line 2510  scav_instance_pointer(lispobj *where, li
2510    return 1;    return 1;
2511  }  }
2512  #else  #else
2513  static int  static int scav_instance_pointer(lispobj *where, lispobj object)
 scav_instance_pointer(lispobj *where, lispobj object)  
2514  {  {
2515    lispobj copy, *first_pointer;    lispobj copy, *first_pointer;
2516    
2517    /* Object is a pointer into from space - not a FP */    /* Object is a pointer into from space - not a FP */
2518    copy = trans_boxed(object);    copy = trans_boxed(object);
2519    
2520    gc_assert(copy != object);    gc_assert(copy != object);
2521    
2522    first_pointer = (lispobj *) PTR(object);    first_pointer = (lispobj *) PTR(object);
2523    
2524    /* Set forwarding pointer. */    /* Set forwarding pointer. */
2525    first_pointer[0] = 0x01;    first_pointer[0] = 0x01;
2526    first_pointer[1] = copy;    first_pointer[1] = copy;
# Line 2325  scav_instance_pointer(lispobj *where, li Line 2536  scav_instance_pointer(lispobj *where, li
2536  static lispobj trans_list(lispobj object);  static lispobj trans_list(lispobj object);
2537    
2538  #if DIRECT_SCAV  #if DIRECT_SCAV
2539  static int  static int scav_list_pointer(lispobj *where, lispobj object)
 scav_list_pointer(lispobj *where, lispobj object)  
2540  {  {
2541    gc_assert(Pointerp(object));    gc_assert(Pointerp(object));
2542    
2543    if (from_space_p(object)) {    if (from_space_p(object)) {
2544      lispobj first, *first_pointer;      lispobj first, *first_pointer;
2545    
2546      /* object is a pointer into from space.  check to see */      /*
2547      /* if it has been forwarded */       * Object is a pointer into from space - check to see if it has
2548         * been forwarded.
2549         */
2550      first_pointer = (lispobj *) PTR(object);      first_pointer = (lispobj *) PTR(object);
2551      first = *first_pointer;      first = *first_pointer;
2552    
2553      if (first == 0x01)      if (first == 0x01)
2554        /* Forwarded. */        /* Forwarded. */
2555        first = first_pointer[1];        first = first_pointer[1];
2556      else {      else {
2557        first = trans_list(object);        first = trans_list(object);
2558    
2559        /* Set forwarding pointer */        /* Set forwarding pointer */
2560        first_pointer[0] = 0x01;        first_pointer[0] = 0x01;
2561        first_pointer[1] = first;        first_pointer[1] = first;
2562      }      }
2563    
2564      gc_assert(Pointerp(first));      gc_assert(Pointerp(first));
2565      gc_assert(!from_space_p(first));      gc_assert(!from_space_p(first));
2566      *where = first;      *where = first;
# Line 2356  scav_list_pointer(lispobj *where, lispob Line 2568  scav_list_pointer(lispobj *where, lispob
2568    return 1;    return 1;
2569  }  }
2570  #else  #else
2571  static int  static int scav_list_pointer(lispobj *where, lispobj object)
 scav_list_pointer(lispobj *where, lispobj object)  
2572  {  {
2573    lispobj first, *first_pointer;    lispobj first, *first_pointer;
2574    
2575    gc_assert(Pointerp(object));    gc_assert(Pointerp(object));
2576    
2577    /* Object is a pointer into from space - not FP */    /* Object is a pointer into from space - not FP */
2578    
2579    first = trans_list(object);    first = trans_list(object);
2580    gc_assert(first != object);    gc_assert(first != object);
2581    
# Line 2381  scav_list_pointer(lispobj *where, lispob Line 2592  scav_list_pointer(lispobj *where, lispob
2592  }  }
2593  #endif  #endif
2594    
2595  static lispobj  static lispobj trans_list(lispobj object)
 trans_list(lispobj object)  
2596  {  {
2597    lispobj new_list_pointer;    lispobj new_list_pointer;
2598    struct cons *cons, *new_cons;    struct cons *cons, *new_cons;
# Line 2392  trans_list(lispobj object) Line 2602  trans_list(lispobj object)
2602    gc_assert(from_space_p(object));    gc_assert(from_space_p(object));
2603    
2604    cons = (struct cons *) PTR(object);    cons = (struct cons *) PTR(object);
2605    
2606    /* copy 'object' */    /* copy 'object' */
2607    new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));    new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
2608    new_cons->car = cons->car;    new_cons->car = cons->car;
2609    new_cons->cdr = cons->cdr; /* updated later */    new_cons->cdr = cons->cdr; /* updated later */
2610    new_list_pointer = (lispobj)new_cons | LowtagOf(object);    new_list_pointer = (lispobj) new_cons | LowtagOf(object);
2611    
2612    /* Grab the cdr before it is clobbered */    /* Grab the cdr before it is clobbered */
2613    cdr = cons->cdr;    cdr = cons->cdr;
# Line 2410  trans_list(lispobj object) Line 2620  trans_list(lispobj object)
2620    while (1) {    while (1) {
2621      lispobj  new_cdr;      lispobj  new_cdr;
2622      struct cons *cdr_cons, *new_cdr_cons;      struct cons *cdr_cons, *new_cdr_cons;
2623    
2624      if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)      if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
2625          || (*((lispobj *)PTR(cdr)) == 0x01))          || *((lispobj *) PTR(cdr)) == 0x01)
2626        break;        break;
2627    
2628      cdr_cons = (struct cons *) PTR(cdr);      cdr_cons = (struct cons *) PTR(cdr);
2629    
2630      /* copy 'cdr' */      /* copy 'cdr' */
2631      new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));      new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));
2632      new_cdr_cons->car = cdr_cons->car;      new_cdr_cons->car = cdr_cons->car;
2633      new_cdr_cons->cdr = cdr_cons->cdr;      new_cdr_cons->cdr = cdr_cons->cdr;
2634      new_cdr = (lispobj)new_cdr_cons | LowtagOf(cdr);      new_cdr = (lispobj) new_cdr_cons | LowtagOf(cdr);
2635    
2636      /* Grab the cdr before it is clobbered */      /* Grab the cdr before it is clobbered */
2637      cdr = cdr_cons->cdr;      cdr = cdr_cons->cdr;
2638    
2639      /* Set forwarding pointer */      /* Set forwarding pointer */
2640      cdr_cons->car = 0x01;      cdr_cons->car = 0x01;
2641      cdr_cons->cdr = new_cdr;      cdr_cons->cdr = new_cdr;
2642    
2643      /* Update the cdr of the last cons copied into new      /*
2644       * space to keep the newspace scavenge from having to do it.       * Update the cdr of the last cons copied into new space to keep
2645         * the newspace scavenge from having to do it.
2646       */       */
2647      new_cons->cdr = new_cdr;      new_cons->cdr = new_cdr;
2648    
2649      new_cons = new_cdr_cons;      new_cons = new_cdr_cons;
2650    }    }
2651    
2652    return new_list_pointer;    return new_list_pointer;
2653  }  }
2654    
# Line 2445  trans_list(lispobj object) Line 2656  trans_list(lispobj object)
2656  /* Scavenging and Transporting Other Pointers */  /* Scavenging and Transporting Other Pointers */
2657    
2658  #if DIRECT_SCAV  #if DIRECT_SCAV
2659  static int  static int scav_other_pointer(lispobj *where, lispobj object)
 scav_other_pointer(lispobj *where, lispobj object)  
2660  {  {
2661    gc_assert(Pointerp(object));    gc_assert(Pointerp(object));
2662    
2663    if (from_space_p(object)) {    if (from_space_p(object)) {
2664      lispobj first, *first_pointer;      lispobj first, *first_pointer;
2665    
2666      /* object is a pointer into from space.  check to see */      /*
2667      /* if it has been forwarded */       * Object is a pointer into from space.  check to see if it has
2668         * been forwarded.
2669         */
2670      first_pointer = (lispobj *) PTR(object);      first_pointer = (lispobj *) PTR(object);
2671      first = *first_pointer;      first = *first_pointer;
2672    
2673      if (first == 0x01) {      if (first == 0x01) {
2674        /* Forwarded. */        /* Forwarded. */
2675        first = first_pointer[1];        first = first_pointer[1];
2676        *where = first;        *where = first;
2677      } else {      } else {
2678        first = (transother[TypeOf(first)])(object);        first = (transother[TypeOf(first)])(object);
2679    
2680        if (first != object) {        if (first != object) {
2681          /* Set forwarding pointer */          /* Set forwarding pointer */
2682          first_pointer[0] = 0x01;          first_pointer[0] = 0x01;
# Line 2472  scav_other_pointer(lispobj *where, lispo Line 2684  scav_other_pointer(lispobj *where, lispo
2684          *where = first;          *where = first;
2685        }        }
2686      }      }
2687    
2688      gc_assert(Pointerp(first));      gc_assert(Pointerp(first));
2689      gc_assert(!from_space_p(first));      gc_assert(!from_space_p(first));
2690    }    }
2691    return 1;    return 1;
2692  }  }
2693  #else  #else
2694  static int  static int scav_other_pointer(lispobj *where, lispobj object)
 scav_other_pointer(lispobj *where, lispobj object)  
2695  {  {
2696    lispobj first, *first_pointer;    lispobj first, *first_pointer;
2697    
# Line 2497  scav_other_pointer(lispobj *where, lispo Line 2708  scav_other_pointer(lispobj *where, lispo
2708      first_pointer[1] = first;      first_pointer[1] = first;
2709      *where = first;      *where = first;
2710    }    }
2711    
2712    gc_assert(Pointerp(first));    gc_assert(Pointerp(first));
2713    gc_assert(!from_space_p(first));    gc_assert(!from_space_p(first));
2714    
# Line 2508  scav_other_pointer(lispobj *where, lispo Line 2719  scav_other_pointer(lispobj *where, lispo
2719    
2720  /* Immediate, Boxed, and Unboxed Objects */  /* Immediate, Boxed, and Unboxed Objects */
2721    
2722  static int  static int size_pointer(lispobj *where)
 size_pointer(lispobj *where)  
2723  {  {
2724      return 1;      return 1;
2725  }  }
2726    
2727  static int  static int scav_immediate(lispobj *where, lispobj object)
 scav_immediate(lispobj *where, lispobj object)  
2728  {  {
2729      return 1;      return 1;
2730  }  }
2731    
2732  static lispobj  static lispobj trans_immediate(lispobj object)
 trans_immediate(lispobj object)  
2733  {  {
2734      fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");      fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
2735      lose(NULL);      lose(NULL);
2736      return NIL;      return NIL;
2737  }  }
2738    
2739  static int  static int size_immediate(lispobj *where)
 size_immediate(lispobj *where)  
2740  {  {
2741      return 1;      return 1;
2742  }  }
2743    
2744    
2745  static int  static int scav_boxed(lispobj *where, lispobj object)
 scav_boxed(lispobj *where, lispobj object)  
2746  {  {
2747      return 1;      return 1;
2748  }  }
2749    
2750  static lispobj  static lispobj trans_boxed(lispobj object)
 trans_boxed(lispobj object)  
2751  {  {
2752          lispobj header;          lispobj header;
2753          unsigned long length;          unsigned long length;
# Line 2556  trans_boxed(lispobj object) Line 2761  trans_boxed(lispobj object)
2761          return copy_object(object, length);          return copy_object(object, length);
2762  }  }
2763    
2764  static lispobj  static lispobj trans_boxed_large(lispobj object)
 trans_boxed_large(lispobj object)  
2765  {  {
2766          lispobj header;          lispobj header;
2767          unsigned long length;          unsigned long length;
# Line 2571  trans_boxed_large(lispobj object) Line 2775  trans_boxed_large(lispobj object)
2775          return copy_large_object(object, length);          return copy_large_object(object, length);
2776  }  }
2777    
2778  static int  static int size_boxed(lispobj *where)
 size_boxed(lispobj *where)  
2779  {  {
2780          lispobj header;          lispobj header;
2781          unsigned long length;          unsigned long length;
# Line 2584  size_boxed(lispobj *where) Line 2787  size_boxed(lispobj *where)
2787          return length;          return length;
2788  }  }
2789    
2790  static int  static int scav_fdefn(lispobj *where, lispobj object)
 scav_fdefn(lispobj *where, lispobj object)  
2791  {  {
2792    struct fdefn *fdefn;    struct fdefn *fdefn;
2793    
2794    fdefn = (struct fdefn *)where;    fdefn = (struct fdefn *)where;
2795    
2796    if ((char *)(fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {    if ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
2797      scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);      scavenge(where + 1, sizeof(struct fdefn) / sizeof(lispobj) - 1);
2798    
2799      /* Don't write unnecessarily */      /* Don't write unnecessarily */
2800      if (fdefn->raw_addr != (char *)(fdefn->function + RAW_ADDR_OFFSET))      if (fdefn->raw_addr != (char *)(fdefn->function + RAW_ADDR_OFFSET))
2801        fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);        fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
2802    
2803      return sizeof(struct fdefn) / sizeof(lispobj);      return sizeof(struct fdefn) / sizeof(lispobj);
2804    }    }
2805    else    else
2806      return 1;      return 1;
2807  }  }
2808    
2809  static int  static int scav_unboxed(lispobj *where, lispobj object)
 scav_unboxed(lispobj *where, lispobj object)  
2810  {  {
2811          unsigned long length;          unsigned long length;
2812    
# Line 2615  scav_unboxed(lispobj *where, lispobj obj Line 2816  scav_unboxed(lispobj *where, lispobj obj
2816          return length;          return length;
2817  }  }
2818    
2819  static lispobj  static lispobj trans_unboxed(lispobj object)
 trans_unboxed(lispobj object)  
2820  {  {
2821          lispobj header;          lispobj header;
2822          unsigned long length;          unsigned long length;
# Line 2631  trans_unboxed(lispobj object) Line 2831  trans_unboxed(lispobj object)
2831          return copy_unboxed_object(object, length);          return copy_unboxed_object(object, length);
2832  }  }
2833    
2834  static lispobj  static lispobj trans_unboxed_large(lispobj object)
 trans_unboxed_large(lispobj object)  
2835  {  {
2836          lispobj header;          lispobj header;
2837          unsigned long length;          unsigned long length;
# Line 2647  trans_unboxed_large(lispobj object) Line 2846  trans_unboxed_large(lispobj object)
2846          return copy_large_unboxed_object(object, length);          return copy_large_unboxed_object(object, length);
2847  }  }
2848    
2849  static int  static int size_unboxed(lispobj *where)
 size_unboxed(lispobj *where)  
2850  {  {
2851          lispobj header;          lispobj header;
2852          unsigned long length;          unsigned long length;
# Line 2661  size_unboxed(lispobj *where) Line 2859  size_unboxed(lispobj *where)
2859  }  }
2860    
2861    
   
2862  /* Vector-Like Objects */  /* Vector-Like Objects */
2863    
2864  #define NWORDS(x,y) (CEILING((x),(y)) / (y))  #define NWORDS(x,y) (CEILING((x),(y)) / (y))
2865    
2866  static int  static int scav_string(lispobj *where, lispobj object)
 scav_string(lispobj *where, lispobj object)  
2867  {  {
2868          struct vector *vector;          struct vector *vector;
2869          int length, nwords;          int length, nwords;
2870    
2871          /* NOTE: Strings contain one more byte of data than the length */          /*
2872          /* slot indicates. */           * NOTE: Strings contain one more byte of data than the length
2873             * slot indicates.
2874             */
2875    
2876          vector = (struct vector *) where;          vector = (struct vector *) where;
2877          length = fixnum_value(vector->length) + 1;          length = fixnum_value(vector->length) + 1;
# Line 2682  scav_string(lispobj *where, lispobj obje Line 2880  scav_string(lispobj *where, lispobj obje
2880          return nwords;          return nwords;
2881  }  }
2882    
2883  static lispobj  static lispobj trans_string(lispobj object)
 trans_string(lispobj object)  
2884  {  {
2885          struct vector *vector;          struct vector *vector;
2886          int length, nwords;          int length, nwords;
2887    
2888          gc_assert(Pointerp(object));          gc_assert(Pointerp(object));
2889    
2890          /* NOTE: Strings contain one more byte of data than the length */          /*
2891          /* slot indicates. */           * NOTE: Strings contain one more byte of data than the length
2892             * slot indicates.
2893             */
2894    
2895          vector = (struct vector *) PTR(object);          vector = (struct vector *) PTR(object);
2896          length = fixnum_value(vector->length) + 1;          length = fixnum_value(vector->length) + 1;
# Line 2700  trans_string(lispobj object) Line 2899  trans_string(lispobj object)
2899          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
2900  }  }
2901    
2902  static int  static int size_string(lispobj *where)
 size_string(lispobj *where)  
2903  {  {
2904          struct vector *vector;          struct vector *vector;
2905          int length, nwords;          int length, nwords;
2906    
2907          /* NOTE: Strings contain one more byte of data than the length */          /*
2908          /* slot indicates. */           * NOTE: Strings contain one more byte of data than the length
2909             * slot indicates.
2910             */
2911    
2912          vector = (struct vector *) where;          vector = (struct vector *) where;
2913          length = fixnum_value(vector->length) + 1;          length = fixnum_value(vector->length) + 1;
# Line 2716  size_string(lispobj *where) Line 2916  size_string(lispobj *where)
2916          return nwords;          return nwords;
2917  }  }
2918    
2919  /*static int  #if 0
2920  scav_vector(lispobj *where, lispobj object)  static int scav_vector(lispobj *where, lispobj object)
2921  {  {
2922      if (HeaderValue(object) == subtype_VectorValidHashing)      if (HeaderValue(object) == subtype_VectorValidHashing)
2923          *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;          *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;
2924    
2925      return 1;      return 1;
2926  }*/  }
2927    #endif
2928    
2929  int gencgc_hash = 1;  int gencgc_hash = 1;
2930    
2931  static int  static int scav_vector(lispobj *where, lispobj object)
 scav_vector(lispobj *where, lispobj object)  
2932  {  {
2933    unsigned int kv_length;    unsigned int kv_length;
2934    lispobj *kv_vector;    lispobj *kv_vector;
# Line 2750  scav_vector(lispobj *where, lispobj obje Line 2950  scav_vector(lispobj *where, lispobj obje
2950    
2951    kv_length = fixnum_value(where[1]);    kv_length = fixnum_value(where[1]);
2952    kv_vector = where+2;  /* Skip the header and length. */    kv_vector = where+2;  /* Skip the header and length. */
2953    /* fprintf(stderr,"* kv_length = %d\n", kv_length);*/  #if 0
2954      fprintf(stderr, "* kv_length = %d\n", kv_length);
2955    #endif
2956    
2957    /* Scavenge element 0 which may be a hash-table structure. */    /* Scavenge element 0 which may be a hash-table structure. */
2958    scavenge(where+2,1);    scavenge(where + 2, 1);
2959    if (!Pointerp(where[2])) {    if (!Pointerp(where[2])) {
2960      fprintf(stderr,"* Not hash table pointer? %x\n",where[2]);      fprintf(stderr, "* Not hash table pointer? %x\n", where[2]);
2961      return 3;      return 3;
2962    }    }
2963    hash_table = (lispobj *)PTR(where[2]);    hash_table = (lispobj *) PTR(where[2]);
2964    /* fprintf(stderr,"* hash_table = %x\n", hash_table);*/  #if 0
2965    if (!(TypeOf(hash_table[0]) == type_InstanceHeader)) {    fprintf(stderr, "* hash_table = %x\n", hash_table);
2966      fprintf(stderr,"* Hash table not instance? %x\n",hash_table[0]);  #endif
2967      if (TypeOf(hash_table[0]) != type_InstanceHeader) {
2968        fprintf(stderr, "* Hash table not instance? %x\n", hash_table[0]);
2969      return 3;      return 3;
2970    }    }
2971    
2972    /* Scavenge element 1 which should be an :empty symbol. */    /* Scavenge element 1 which should be an :empty symbol. */
2973    scavenge(where+3,1);    scavenge(where + 3, 1);
2974    if (!Pointerp(where[3])) {    if (!Pointerp(where[3])) {
2975      fprintf(stderr,"* Not :empty symbol pointer? %x\n",where[3]);      fprintf(stderr, "* Not :empty symbol pointer? %x\n", where[3]);
2976      return 4;      return 4;
2977    }    }
2978    empty_symbol = where[3];    empty_symbol = where[3];
2979    /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/  #if 0
2980    if (!(TypeOf(*(lispobj *)PTR(empty_symbol)) == type_SymbolHeader)) {    fprintf(stderr, "* empty_symbol = %x\n", empty_symbol);
2981      fprintf(stderr,"* empty symbol not symbol? %x\n",  #endif
2982              *(lispobj *)PTR(empty_symbol));    if (TypeOf(*(lispobj *) PTR(empty_symbol)) != type_SymbolHeader) {
2983        fprintf(stderr, "* empty symbol not symbol? %x\n",
2984                *(lispobj *) PTR(empty_symbol));
2985      return 4;      return 4;
2986    }    }
2987    
2988    /* Scavenge hash table which will fix the positions of the other    /*
2989       needed objects. */     * Scavenge hash table which will fix the positions of the other
2990       * needed objects.
2991       */
2992    scavenge(hash_table,16);    scavenge(hash_table,16);
2993    
2994    /* Cross check the kv_vector. */    /* Cross check the kv_vector. */
2995    if (where != (lispobj *)PTR(hash_table[9])) {    if (where != (lispobj *) PTR(hash_table[9])) {
2996      fprintf(stderr,"* hash_table table!=this table? %x\n",hash_table[9]);      fprintf(stderr, "* hash_table table!=this table? %x\n", hash_table[9]);
2997      return 4;      return 4;
2998    }    }
2999    
3000    /* Weak-p */    /* Weak-p */
3001    weak_p_obj = hash_table[10];    weak_p_obj = hash_table[10];
3002    /* fprintf(stderr,"* weak-p = %x\n",weak_p_obj);*/  #if 0
3003      fprintf(stderr, "* weak-p = %x\n", weak_p_obj);
3004    #endif
3005    
3006    /* Index vector */    /* Index vector */
3007    {    {
3008      lispobj index_vector_obj = hash_table[13];      lispobj index_vector_obj = hash_table[13];
3009    
3010      if (Pointerp(index_vector_obj) &&      if (Pointerp(index_vector_obj) &&
3011          (TypeOf(*(lispobj *)PTR(index_vector_obj)) == type_SimpleArrayUnsignedByte32)) {          TypeOf(*(lispobj *) PTR(index_vector_obj)) == type_SimpleArrayUnsignedByte32) {
3012        index_vector = ((unsigned int *)PTR(index_vector_obj)) + 2;        index_vector = (unsigned int *) PTR(index_vector_obj) + 2;
3013        /* fprintf(stderr,"* index_vector = %x\n",index_vector);*/  #if 0
3014        length = fixnum_value(((unsigned int *)PTR(index_vector_obj))[1]);        fprintf(stderr, "* index_vector = %x\n", index_vector);
3015        /* fprintf(stderr,"* length = %d\n", length);*/  #endif
3016          length = fixnum_value(((unsigned int *) PTR(index_vector_obj))[1]);
3017    #if 0
3018          fprintf(stderr, "* length = %d\n", length);
3019    #endif
3020      } else {      } else {
3021        fprintf(stderr,"* invalid index_vector? %x\n",index_vector_obj);        fprintf(stderr, "* invalid index_vector? %x\n", index_vector_obj);
3022        return 4;        return 4;
3023      }      }
3024    }    }
# Line 2814  scav_vector(lispobj *where, lispobj obje Line 3028  scav_vector(lispobj *where, lispobj obje
3028      lispobj next_vector_obj = hash_table[14];      lispobj next_vector_obj = hash_table[14];
3029    
3030      if (Pointerp(next_vector_obj) &&      if (Pointerp(next_vector_obj) &&
3031          (TypeOf(*(lispobj *)PTR(next_vector_obj)) == type_SimpleArrayUnsignedByte32)) {          TypeOf(*(lispobj *) PTR(next_vector_obj)) == type_SimpleArrayUnsignedByte32) {
3032        next_vector = ((unsigned int *)PTR(next_vector_obj)) + 2;        next_vector = (unsigned int *) PTR(next_vector_obj) + 2;
3033        /* fprintf(stderr,"* next_vector = %x\n",next_vector);*/  #if 0
3034        next_vector_length = fixnum_value(((unsigned int *)PTR(next_vector_obj))[1]);        fprintf(stderr, "* next_vector = %x\n", next_vector);
3035        /* fprintf(stderr,"* next_vector_length = %d\n", next_vector_length);*/  #endif
3036          next_vector_length = fixnum_value(((unsigned int *) PTR(next_vector_obj))[1]);
3037    #if 0
3038          fprintf(stderr, "* next_vector_length = %d\n", next_vector_length);
3039    #endif
3040      } else {      } else {
3041        fprintf(stderr,"* invalid next_vector? %x\n",next_vector_obj);        fprintf(stderr, "* invalid next_vector? %x\n", next_vector_obj);
3042        return 4;        return 4;
3043      }      }
3044    }    }
# Line 2830  scav_vector(lispobj *where, lispobj obje Line 3048  scav_vector(lispobj *where, lispobj obje
3048      lispobj hash_vector_obj = hash_table[15];      lispobj hash_vector_obj = hash_table[15];
3049    
3050      if (Pointerp(hash_vector_obj) &&      if (Pointerp(hash_vector_obj) &&
3051          (TypeOf(*(lispobj *)PTR(hash_vector_obj)) == type_SimpleArrayUnsignedByte32)) {          TypeOf(*(lispobj *) PTR(hash_vector_obj)) == type_SimpleArrayUnsignedByte32) {
3052        hash_vector = ((unsigned int *)PTR(hash_vector_obj)) + 2;        hash_vector = (unsigned int *) PTR(hash_vector_obj) + 2;
3053        /* fprintf(stderr,"* hash_vector = %x\n",hash_vector);*/  #if 0
3054        gc_assert(fixnum_value(((unsigned int *)PTR(hash_vector_obj))[1])        fprintf(stderr, "* hash_vector = %x\n", hash_vector);
3055    #endif
3056          gc_assert(fixnum_value(((unsigned int *) PTR(hash_vector_obj))[1])
3057                  == next_vector_length);                  == next_vector_length);
3058      } else {      } else {
3059        hash_vector = NULL;        hash_vector = NULL;
3060        /* fprintf(stderr,"* No hash_vector: %x\n",hash_vector_obj);*/  #if 0
3061          fprintf(stderr, "* No hash_vector: %x\n", hash_vector_obj);
3062    #endif
3063      }      }
3064    }    }
3065    
3066    /* These lengths could be different as the index_vector can be a    /*
3067       different length to the others, a larger index_vector could help     * These lengths could be different as the index_vector can be a
3068       reduce collisions. */     * different length to the others, a larger index_vector could help
3069    gc_assert(next_vector_length*2 == kv_length);     * reduce collisions.
3070       */
3071      gc_assert(next_vector_length * 2 == kv_length);
3072    
3073    /* Now all setup */    /* Now all setup */
3074    
3075    /* Work through the KV vector */    /* Work through the KV vector */
3076    {    {
3077      int i;      int i;
3078      for (i = 1; i < next_vector_length; i++) {      for (i = 1; i < next_vector_length; i++) {
3079        lispobj old_key = kv_vector[2*i];        lispobj old_key = kv_vector[2 * i];
3080        unsigned int  old_index = (old_key & 0x1fffffff)%length;        unsigned int  old_index = (old_key & 0x1fffffff) % length;
3081    
3082        /* Scavenge the Key and Value */        /* Scavenge the Key and Value */
3083        scavenge(&kv_vector[2*i],2);        scavenge(&kv_vector[2 * i], 2);
3084    
3085        /* Check if the Key has moved and is EQ based */        /* Check if the Key has moved and is EQ based */
3086        {        {
3087          lispobj new_key = kv_vector[2*i];          lispobj new_key = kv_vector[2 * i];
3088          unsigned int new_index = (new_key & 0x1fffffff)%length;          unsigned int new_index = (new_key & 0x1fffffff) % length;
3089    
3090            if (old_index != new_index &&
3091                (!hash_vector || hash_vector[i] == 0x80000000) &&
3092                (new_key != empty_symbol || kv_vector[2 * i] != empty_symbol)) {
3093    
3094    #if 0
3095              fprintf(stderr, "* EQ key %d moved from %x to %x; index %d to %d\n",
3096                      i, old_key, new_key, old_index, new_index);
3097    #endif
3098    
         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);*/  
   
3099            if (index_vector[old_index] != 0) {            if (index_vector[old_index] != 0) {
3100              /*fprintf(stderr,"*P1 %d\n",index_vector[old_index]);*/  #if 0
3101                fprintf(stderr, "*P1 %d\n", index_vector[old_index]);
3102    #endif
3103    
3104              /* Unlink the key from the old_index chain. */              /* Unlink the key from the old_index chain. */
3105              if (index_vector[old_index] == i) {              if (index_vector[old_index] == i) {
3106                /*fprintf(stderr,"*P2a %d\n",next_vector[i]);*/  #if 0
3107                  fprintf(stderr, "*P2a %d\n", next_vector[i]);
3108    #endif
3109                index_vector[old_index] = next_vector[i];                index_vector[old_index] = next_vector[i];
3110                /* Link it into the needing rehash chain. */                /* Link it into the needing rehash chain. */
3111                next_vector[i] = fixnum_value(hash_table[11]);                next_vector[i] = fixnum_value(hash_table[11]);
3112                hash_table[11] = make_fixnum(i);                hash_table[11] = make_fixnum(i);
3113                /*fprintf(stderr,"*P2\n");*/  #if 0
3114                  fprintf(stderr, "*P2\n");
3115    #endif
3116              } else {              } else {
3117                unsigned prior = index_vector[old_index];                unsigned prior = index_vector[old_index];
3118                unsigned next = next_vector[prior];                unsigned next = next_vector[prior];
3119    
3120                /*fprintf(stderr,"*P3a %d %d\n",prior,next);*/  #if 0
3121                  fprintf(stderr, "*P3a %d %d\n", prior, next);
3122    #endif
3123    
3124                while (next != 0) {                while (next != 0) {
3125                  /* fprintf(stderr,"*P3b %d %d\n",prior,next);*/  #if 0
3126                    fprintf(stderr, "*P3b %d %d\n", prior, next);
3127    #endif
3128                  if (next == i) {                  if (next == i) {
3129                    /* Unlink it */                    /* Unlink it */
3130                    next_vector[prior] = next_vector[next];                    next_vector[prior] = next_vector[next];
3131                    /* Link it into the needing rehash chain. */                    /* Link it into the needing rehash chain. */
3132                    next_vector[next] = fixnum_value(hash_table[11]);                    next_vector[next] = fixnum_value(hash_table[11]);
3133                    hash_table[11] = make_fixnum(next);                    hash_table[11] = make_fixnum(next);
3134                    /*fprintf(stderr,"*P3\n");*/  #if 0
3135                      fprintf(stderr, "*P3\n");
3136    #endif
3137                    break;                    break;
3138                  }                  }
3139                  prior = next;                  prior = next;
# Line 2907  scav_vector(lispobj *where, lispobj obje Line 3145  scav_vector(lispobj *where, lispobj obje
3145        }        }
3146      }      }
3147    }    }
3148    return (CEILING(kv_length + 2, 2));    return CEILING(kv_length + 2, 2);
3149  }  }
3150    
3151    
3152  static lispobj  static lispobj trans_vector(lispobj object)
 trans_vector(lispobj object)  
3153  {  {
3154          struct vector *vector;          struct vector *vector;
3155          int length, nwords;          int length, nwords;
# Line 2927  trans_vector(lispobj object) Line 3164  trans_vector(lispobj object)
3164          return copy_large_object(object, nwords);          return copy_large_object(object, nwords);
3165  }  }
3166    
3167  static int  static int size_vector(lispobj *where)
 size_vector(lispobj *where)  
3168  {  {
3169          struct vector *vector;          struct vector *vector;
3170          int length, nwords;          int length, nwords;
# Line 2941  size_vector(lispobj *where) Line 3177  size_vector(lispobj *where)
3177  }  }
3178    
3179    
3180  static int  static int scav_vector_bit(lispobj *where, lispobj object)
 scav_vector_bit(lispobj *where, lispobj object)  
3181  {  {
3182          struct vector *vector;          struct vector *vector;
3183          int length, nwords;          int length, nwords;
# Line 2954  scav_vector_bit(lispobj *where, lispobj Line 3189  scav_vector_bit(lispobj *where, lispobj
3189          return nwords;          return nwords;
3190  }  }
3191    
3192  static lispobj  static lispobj trans_vector_bit(lispobj object)
 trans_vector_bit(lispobj object)  
3193  {  {
3194          struct vector *vector;          struct vector *vector;
3195          int length, nwords;          int length, nwords;
# Line 2969  trans_vector_bit(lispobj object) Line 3203  trans_vector_bit(lispobj object)
3203          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3204  }  }
3205    
3206  static int  static int size_vector_bit(lispobj *where)
 size_vector_bit(lispobj *where)  
3207  {  {
3208          struct vector *vector;          struct vector *vector;
3209          int length, nwords;          int length, nwords;
# Line 2983  size_vector_bit(lispobj *where) Line 3216  size_vector_bit(lispobj *where)
3216  }  }
3217    
3218    
3219  static int  static int scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)  
3220  {  {
3221          struct vector *vector;          struct vector *vector;
3222          int length, nwords;          int length, nwords;
# Line 2996  scav_vector_unsigned_byte_2(lispobj *whe Line 3228  scav_vector_unsigned_byte_2(lispobj *whe
3228          return nwords;          return nwords;
3229  }  }
3230    
3231  static lispobj  static lispobj trans_vector_unsigned_byte_2(lispobj object)
 trans_vector_unsigned_byte_2(lispobj object)  
3232  {  {
3233          struct vector *vector;          struct vector *vector;
3234          int length, nwords;          int length, nwords;
# Line 3011  trans_vector_unsigned_byte_2(lispobj obj Line 3242  trans_vector_unsigned_byte_2(lispobj obj
3242          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3243  }  }
3244    
3245  static int  static int size_vector_unsigned_byte_2(lispobj *where)
 size_vector_unsigned_byte_2(lispobj *where)  
3246  {  {
3247          struct vector *vector;          struct vector *vector;
3248          int length, nwords;          int length, nwords;
# Line 3025  size_vector_unsigned_byte_2(lispobj *whe Line 3255  size_vector_unsigned_byte_2(lispobj *whe
3255  }  }
3256    
3257    
3258  static int  static int scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)  
3259  {  {
3260          struct vector *vector;          struct vector *vector;
3261          int length, nwords;          int length, nwords;
# Line 3038  scav_vector_unsigned_byte_4(lispobj *whe Line 3267  scav_vector_unsigned_byte_4(lispobj *whe
3267          return nwords;          return nwords;
3268  }  }
3269    
3270  static lispobj  static lispobj trans_vector_unsigned_byte_4(lispobj object)
 trans_vector_unsigned_byte_4(lispobj object)  
3271  {  {
3272          struct vector *vector;          struct vector *vector;
3273          int length, nwords;          int length, nwords;
# Line 3053  trans_vector_unsigned_byte_4(lispobj obj Line 3281  trans_vector_unsigned_byte_4(lispobj obj
3281          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3282  }  }
3283    
3284  static int  static int size_vector_unsigned_byte_4(lispobj *where)
 size_vector_unsigned_byte_4(lispobj *where)  
3285  {  {
3286          struct vector *vector;          struct vector *vector;
3287          int length, nwords;          int length, nwords;
# Line 3067  size_vector_unsigned_byte_4(lispobj *whe Line 3294  size_vector_unsigned_byte_4(lispobj *whe
3294  }  }
3295    
3296    
3297  static int  static int scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)  
3298  {  {
3299          struct vector *vector;          struct vector *vector;
3300          int length, nwords;          int length, nwords;
# Line 3080  scav_vector_unsigned_byte_8(lispobj *whe Line 3306  scav_vector_unsigned_byte_8(lispobj *whe
3306          return nwords;          return nwords;
3307  }  }
3308    
3309  static lispobj  static lispobj trans_vector_unsigned_byte_8(lispobj object)
 trans_vector_unsigned_byte_8(lispobj object)  
3310  {  {
3311          struct vector *vector;          struct vector *vector;
3312          int length, nwords;          int length, nwords;
# Line 3095  trans_vector_unsigned_byte_8(lispobj obj Line 3320  trans_vector_unsigned_byte_8(lispobj obj
3320          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3321  }  }
3322    
3323  static int  static int size_vector_unsigned_byte_8(lispobj *where)
 size_vector_unsigned_byte_8(lispobj *where)  
3324  {  {
3325          struct vector *vector;          struct vector *vector;
3326          int length, nwords;          int length, nwords;
# Line 3109  size_vector_unsigned_byte_8(lispobj *whe Line 3333  size_vector_unsigned_byte_8(lispobj *whe
3333  }  }
3334    
3335    
3336  static int  static int scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)  
3337  {  {
3338          struct vector *vector;          struct vector *vector;
3339          int length, nwords;          int length, nwords;
# Line 3122  scav_vector_unsigned_byte_16(lispobj *wh Line 3345  scav_vector_unsigned_byte_16(lispobj *wh
3345          return nwords;          return nwords;
3346  }  }
3347    
3348  static lispobj  static lispobj trans_vector_unsigned_byte_16(lispobj object)
 trans_vector_unsigned_byte_16(lispobj object)  
3349  {  {
3350          struct vector *vector;          struct vector *vector;
3351          int length, nwords;          int length, nwords;
# Line 3137  trans_vector_unsigned_byte_16(lispobj ob Line 3359  trans_vector_unsigned_byte_16(lispobj ob
3359          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3360  }  }
3361    
3362  static int  static int size_vector_unsigned_byte_16(lispobj *where)
 size_vector_unsigned_byte_16(lispobj *where)  
3363  {  {
3364          struct vector *vector;          struct vector *vector;
3365          int length, nwords;          int length, nwords;
# Line 3151  size_vector_unsigned_byte_16(lispobj *wh Line 3372  size_vector_unsigned_byte_16(lispobj *wh
3372  }  }
3373    
3374    
3375  static int  static int scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)  
3376  {  {
3377          struct vector *vector;          struct vector *vector;
3378          int length, nwords;          int length, nwords;
# Line 3164  scav_vector_unsigned_byte_32(lispobj *wh Line 3384  scav_vector_unsigned_byte_32(lispobj *wh
3384          return nwords;          return nwords;
3385  }  }
3386    
3387  static lispobj  static lispobj trans_vector_unsigned_byte_32(lispobj object)
 trans_vector_unsigned_byte_32(lispobj object)  
3388  {  {
3389          struct vector *vector;          struct vector *vector;
3390          int length, nwords;          int length, nwords;
# Line 3179  trans_vector_unsigned_byte_32(lispobj ob Line 3398  trans_vector_unsigned_byte_32(lispobj ob
3398          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3399  }  }
3400    
3401  static int  static int size_vector_unsigned_byte_32(lispobj *where)
 size_vector_unsigned_byte_32(lispobj *where)  
3402  {  {
3403          struct vector *vector;          struct vector *vector;
3404          int length, nwords;          int length, nwords;
# Line 3193  size_vector_unsigned_byte_32(lispobj *wh Line 3411  size_vector_unsigned_byte_32(lispobj *wh
3411  }  }
3412    
3413    
3414  static int  static int scav_vector_single_float(lispobj *where, lispobj object)
 scav_vector_single_float(lispobj *where, lispobj object)  
3415  {  {
3416          struct vector *vector;          struct vector *vector;
3417          int length, nwords;          int length, nwords;
# Line 3206  scav_vector_single_float(lispobj *where, Line 3423  scav_vector_single_float(lispobj *where,
3423          return nwords;          return nwords;
3424  }  }
3425    
3426  static lispobj  static lispobj trans_vector_single_float(lispobj object)
 trans_vector_single_float(lispobj object)  
3427  {  {
3428          struct vector *vector;          struct vector *vector;
3429          int length, nwords;          int length, nwords;
# Line 3221  trans_vector_single_float(lispobj object Line 3437  trans_vector_single_float(lispobj object
3437          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3438  }  }
3439    
3440  static int  static int size_vector_single_float(lispobj *where)
 size_vector_single_float(lispobj *where)  
3441  {  {
3442          struct vector *vector;          struct vector *vector;
3443          int length, nwords;          int length, nwords;
# Line 3235  size_vector_single_float(lispobj *where) Line 3450  size_vector_single_float(lispobj *where)
3450  }  }
3451    
3452    
3453  static int  static int scav_vector_double_float(lispobj *where, lispobj object)
 scav_vector_double_float(lispobj *where, lispobj object)  
3454  {  {
3455          struct vector *vector;          struct vector *vector;
3456          int length, nwords;          int length, nwords;
# Line 3248  scav_vector_double_float(lispobj *where, Line 3462  scav_vector_double_float(lispobj *where,
3462          return nwords;          return nwords;
3463  }  }
3464    
3465  static lispobj  static lispobj trans_vector_double_float(lispobj object)
 trans_vector_double_float(lispobj object)  
3466  {  {
3467          struct vector *vector;          struct vector *vector;
3468          int length, nwords;          int length, nwords;
# Line 3263  trans_vector_double_float(lispobj object Line 3476  trans_vector_double_float(lispobj object
3476          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3477  }  }
3478    
3479  static int  static int size_vector_double_float(lispobj *where)
 size_vector_double_float(lispobj *where)  
3480  {  {
3481          struct vector *vector;          struct vector *vector;
3482          int length, nwords;          int length, nwords;
# Line 3278  size_vector_double_float(lispobj *where) Line 3490  size_vector_double_float(lispobj *where)
3490    
3491    
3492  #ifdef type_SimpleArrayLongFloat  #ifdef type_SimpleArrayLongFloat
3493  static int  static int scav_vector_long_float(lispobj *where, lispobj object)
 scav_vector_long_float(lispobj *where, lispobj object)  
3494  {  {
3495          struct vector *vector;          struct vector *vector;
3496          int length, nwords;          int length, nwords;
# Line 3291  scav_vector_long_float(lispobj *where, l Line 3502  scav_vector_long_float(lispobj *where, l
3502          return nwords;          return nwords;
3503  }  }
3504    
3505  static lispobj  static lispobj trans_vector_long_float(lispobj object)
 trans_vector_long_float(lispobj object)  
3506  {  {
3507          struct vector *vector;          struct vector *vector;
3508          int length, nwords;          int length, nwords;
# Line 3306  trans_vector_long_float(lispobj object) Line 3516  trans_vector_long_float(lispobj object)
3516          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3517  }  }
3518    
3519  static int  static int size_vector_long_float(lispobj *where)
 size_vector_long_float(lispobj *where)  
3520  {  {
3521          struct vector *vector;          struct vector *vector;
3522          int length, nwords;          int length, nwords;
# Line 3322  size_vector_long_float(lispobj *where) Line 3531  size_vector_long_float(lispobj *where)
3531    
3532    
3533  #ifdef type_SimpleArrayComplexSingleFloat  #ifdef type_SimpleArrayComplexSingleFloat
3534  static int  static int scav_vector_complex_single_float(lispobj *where, lispobj object)
 scav_vector_complex_single_float(lispobj *where, lispobj object)  
3535  {  {
3536          struct vector *vector;          struct vector *vector;
3537          int length, nwords;          int length, nwords;
# Line 3335  scav_vector_complex_single_float(lispobj Line 3543  scav_vector_complex_single_float(lispobj
3543          return nwords;          return nwords;
3544  }  }
3545    
3546  static lispobj  static lispobj trans_vector_complex_single_float(lispobj object)
 trans_vector_complex_single_float(lispobj object)  
3547  {  {
3548          struct vector *vector;          struct vector *vector;
3549          int length, nwords;          int length, nwords;
# Line 3350  trans_vector_complex_single_float(lispob Line 3557  trans_vector_complex_single_float(lispob
3557          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3558  }  }
3559    
3560  static int  static int size_vector_complex_single_float(lispobj *where)
 size_vector_complex_single_float(lispobj *where)  
3561  {  {
3562          struct vector *vector;          struct vector *vector;
3563          int length, nwords;          int length, nwords;
# Line 3365  size_vector_complex_single_float(lispobj Line 3571  size_vector_complex_single_float(lispobj
3571  #endif  #endif
3572    
3573  #ifdef type_SimpleArrayComplexDoubleFloat  #ifdef type_SimpleArrayComplexDoubleFloat
3574  static int  static int scav_vector_complex_double_float(lispobj *where, lispobj object)
 scav_vector_complex_double_float(lispobj *where, lispobj object)  
3575  {  {
3576          struct vector *vector;          struct vector *vector;
3577          int length, nwords;          int length, nwords;
# Line 3378  scav_vector_complex_double_float(lispobj Line 3583  scav_vector_complex_double_float(lispobj
3583          return nwords;          return nwords;
3584  }  }
3585    
3586  static lispobj  static lispobj trans_vector_complex_double_float(lispobj object)
 trans_vector_complex_double_float(lispobj object)  
3587  {  {
3588          struct vector *vector;          struct vector *vector;
3589          int length, nwords;          int length, nwords;
# Line 3393  trans_vector_complex_double_float(lispob Line 3597  trans_vector_complex_double_float(lispob
3597          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3598  }  }
3599    
3600  static int  static int size_vector_complex_double_float(lispobj *where)
 size_vector_complex_double_float(lispobj *where)  
3601  {  {
3602          struct vector *vector;          struct vector *vector;
3603          int length, nwords;          int length, nwords;
# Line 3409  size_vector_complex_double_float(lispobj Line 3612  size_vector_complex_double_float(lispobj
3612    
3613    
3614  #ifdef type_SimpleArrayComplexLongFloat  #ifdef type_SimpleArrayComplexLongFloat
3615  static int  static int scav_vector_complex_long_float(lispobj *where, lispobj object)
 scav_vector_complex_long_float(lispobj *where, lispobj object)  
3616  {  {
3617          struct vector *vector;          struct vector *vector;
3618          int length, nwords;          int length, nwords;
# Line 3422  scav_vector_complex_long_float(lispobj * Line 3624  scav_vector_complex_long_float(lispobj *
3624          return nwords;          return nwords;
3625  }  }
3626    
3627  static lispobj  static lispobj trans_vector_complex_long_float(lispobj object)
 trans_vector_complex_long_float(lispobj object)  
3628  {  {
3629          struct vector *vector;          struct vector *vector;
3630          int length, nwords;          int length, nwords;
# Line 3437  trans_vector_complex_long_float(lispobj Line 3638  trans_vector_complex_long_float(lispobj
3638          return copy_large_unboxed_object(object, nwords);          return copy_large_unboxed_object(object, nwords);
3639  }  }
3640    
3641  static int  static int size_vector_complex_long_float(lispobj *where)
 size_vector_complex_long_float(lispobj *where)  
3642  {  {
3643          struct vector *vector;          struct vector *vector;
3644          int length, nwords;          int length, nwords;
# Line 3454  size_vector_complex_long_float(lispobj * Line 3654  size_vector_complex_long_float(lispobj *
3654    
3655  /* Weak Pointers */  /* Weak Pointers */
3656    
3657  /* XX Hack adapted from cgc.c; These don't work too well with the  /*
3658     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
3659     objects which causes writes to the pages. A limited attempt is made   * gencgc as a list of the weak pointers is maintained within the
3660     to avoid unnecessary writes, but this needs a re-think. */   * objects which causes writes to the pages. A limited attempt is made
3661     * to avoid unnecessary writes, but this needs a re-think.
3662     */
3663    
3664  #define WEAK_POINTER_NWORDS \  #define WEAK_POINTER_NWORDS \
3665          CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)          CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
3666    
3667  static int  static int scav_weak_pointer(lispobj *where, lispobj object)
 scav_weak_pointer(lispobj *where, lispobj object)  
3668  {  {
3669    struct weak_pointer *wp = weak_pointers;    struct weak_pointer *wp = weak_pointers;
3670    /* Push the weak pointer onto the list of weak pointers.    /*
3671     * Do I have to watch for duplicates? Originally this was     * Push the weak pointer onto the list of weak pointers.  Do I have
3672     * part of trans_weak_pointer but that didn't work in the     * to watch for duplicates? Originally this was part of trans_weak_pointer
3673     * 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.
3674     */     */
3675    
3676    /* Check if it's already in the list. */    /* Check if it's already in the list. */
3677    while(wp != NULL) {    while(wp != NULL) {
3678      if(wp == (struct weak_pointer*)where)      if(wp == (struct weak_pointer*) where)
3679        break;        break;
3680      wp = wp->next;      wp = wp->next;
3681    }    }
3682    if(wp == NULL) {    if(wp == NULL) {
3683      /* Add it to the start of the list. */      /* Add it to the start of the list. */
3684      wp = (struct weak_pointer*)where;      wp = (struct weak_pointer*) where;
3685      if (wp->next != weak_pointers)      if (wp->next != weak_pointers)
3686        wp->next = weak_pointers;        wp->next = weak_pointers;
3687      /*      else  #if 0
3688          fprintf(stderr,"Avoided write to weak pointer.\n");*/      else
3689          fprintf(stderr, "Avoided write to weak pointer.\n");
3690    #endif
3691      weak_pointers = wp;      weak_pointers = wp;
3692    }    }
3693    
3694    /* Do not let GC scavenge the value slot of the weak pointer    /*
3695     * (that is why it is a weak pointer).     * Do not let GC scavenge the value slot of the weak pointer (that
3696       * is why it is a weak pointer).
3697     */     */
3698    
3699    return WEAK_POINTER_NWORDS;    return WEAK_POINTER_NWORDS;
3700  }  }
3701    
3702  static lispobj  static lispobj trans_weak_pointer(lispobj object)
 trans_weak_pointer(lispobj object)  
3703  {  {
3704    lispobj copy;    lispobj copy;
3705    struct weak_pointer *wp;    struct weak_pointer *wp;
3706    
3707    gc_assert(Pointerp(object));    gc_assert(Pointerp(object));
3708    
3709  #if defined(DEBUG_WEAK)  #if defined(DEBUG_WEAK)
3710    printf("Transporting weak pointer from 0x%08x\n", object);    printf("Transporting weak pointer from 0x%08x\n", object);
3711  #endif  #endif
3712    
3713    /* Need to remember where all the weak pointers are that have */    /*
3714    /* 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
3715       * transported so they can be fixed up in a post-GC pass.
3716       */
3717    
3718    copy = copy_object(object, WEAK_POINTER_NWORDS);    copy = copy_object(object, WEAK_POINTER_NWORDS);
3719    /*  wp = (struct weak_pointer *) PTR(copy);*/  #if 0
3720      wp = (struct weak_pointer *) PTR(copy);
3721    #endif
3722    
3723    /* Push the weak pointer onto the list of weak pointers. */    /* Push the weak pointer onto the list of weak pointers. */
3724    /*  wp->next = weak_pointers;  #if 0
3725    weak_pointers = wp;*/    wp->next = weak_pointers;
3726      weak_pointers = wp;
3727    #endif
3728    
3729    return copy;    return copy;
3730  }  }
3731    
3732  static int  static int size_weak_pointer(lispobj *where)
 size_weak_pointer(lispobj *where)  
3733  {  {
3734          return WEAK_POINTER_NWORDS;    return WEAK_POINTER_NWORDS;
3735  }  }
3736    
3737  void scan_weak_pointers(void)  void scan_weak_pointers(void)
# Line 3533  void scan_weak_pointers(void) Line 3740  void scan_weak_pointers(void)
3740    for (wp = weak_pointers; wp != NULL; wp = wp->next) {    for (wp = weak_pointers; wp != NULL; wp = wp->next) {
3741      lispobj value = wp->value;      lispobj value = wp->value;
3742      lispobj first, *first_pointer;      lispobj first, *first_pointer;
3743    
3744      first_pointer = (lispobj *)PTR(value);      first_pointer = (lispobj *) PTR(value);
3745    
3746      /*      fprintf(stderr,"Weak pointer at 0x%08x\n", (unsigned long) wp));  #if 0
3747              fprintf(stderr,"Value: 0x%08x\n", (unsigned long) value));*/      fprintf(stderr, "Weak pointer at 0x%08x\n", (unsigned long) wp);
3748        fprintf(stderr, "Value: 0x%08x\n", (unsigned long) value);
3749    #endif
3750    
3751      if (Pointerp(value) && from_space_p(value)) {      if (Pointerp(value) && from_space_p(value)) {
3752        /* Now, we need to check if the object has been forwarded.  If        /*
3753           * Now, we need to check if the object has been forwarded.  If
3754         * 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
3755         * updated. Otherwise, the weak pointer needs to be nil'ed         * updated. Otherwise, the weak pointer needs to be nil'ed out.
3756         * out.  */         */
3757    
3758        if (first_pointer[0] == 0x01)        if (first_pointer[0] == 0x01)
3759          wp->value = first_pointer[1];          wp->value = first_pointer[1];
3760        else {        else {
3761          /* break it */          /* Break it */
3762          /*fprintf(stderr,"Broken.\n"));*/  #if 0
3763            fprintf(stderr, "Broken.\n");
3764    #endif
3765          wp->value = NIL;          wp->value = NIL;
3766          wp->broken = T;          wp->broken = T;
3767        }        }
# Line 3563  void scan_weak_pointers(void) Line 3775  void scan_weak_pointers(void)
3775  #define SCAVENGER_HOOK_NWORDS \  #define SCAVENGER_HOOK_NWORDS \
3776          CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)          CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
3777    
3778  static int  static int scav_scavenger_hook(lispobj *where, lispobj object)
 scav_scavenger_hook(lispobj *where, lispobj object)  
3779  {  {
3780    struct scavenger_hook *scav_hook = (struct scavenger_hook *)where;    struct scavenger_hook *scav_hook = (struct scavenger_hook *) where;
3781    lispobj old_value = scav_hook->value;    lispobj old_value = scav_hook->value;
3782    
3783    /*  fprintf(stderr,"scav scav_hook %x; value %x\n",where,old_value);*/  #if 0
3784      fprintf(stderr, "scav scav_hook %x; value %x\n", where, old_value);
3785    #endif
3786    
3787    /* Scavenge the value */    /* Scavenge the value */
3788    scavenge(where+1, 1);    scavenge(where + 1, 1);
3789    
3790    if (scav_hook->value != old_value) {    if (scav_hook->value != old_value) {
3791      /* Value object has moved */      /* Value object has moved */
3792      /* fprintf(stderr,"   value object moved to %x\n",scav_hook->value);*/  #if 0
3793        fprintf(stderr, "   value object moved to %x\n", scav_hook->value);
3794    #endif
3795    
3796      /* Check if this hook is already noted. */      /* Check if this hook is already noted. */
3797      /* fprintf(stderr,"   next=%x sh hooks=%x\n",scav_hook->next,scavenger_hooks); */  #if 0
3798        fprintf(stderr, "   next=%x sh hooks=%x\n",
3799                scav_hook->next, scavenger_hooks);
3800    #endif
3801      if (scav_hook->next == NULL) {      if (scav_hook->next == NULL) {
3802        /*  fprintf(stderr,"   adding to scavenger_hooks\n");*/  #if 0
3803          fprintf(stderr, "   adding to scavenger_hooks\n");
3804    #endif
3805        scav_hook->next = scavenger_hooks;        scav_hook->next = scavenger_hooks;
3806        scavenger_hooks = (int)where | type_OtherPointer;        scavenger_hooks = (struct scavenger_hook *) ((int) where |
3807                                                       type_OtherPointer);
3808      }      }
3809    }    }
3810    
3811    /* Scavenge the function and the tail scavenge_hook */    /* Scavenge the function and the tail scavenge_hook */
3812    return 2;    return 2;
3813  }  }
3814    
3815  static lispobj  static lispobj trans_scavenger_hook(lispobj object)
 trans_scavenger_hook(lispobj object)  
3816  {  {
3817    lispobj copy;    lispobj copy;
3818    gc_assert(Pointerp(object));    gc_assert(Pointerp(object));
3819    /*  printf("Transporting scav pointer from 0x%08x\n", object);*/  #if 0
3820      printf("Transporting scav pointer from 0x%08x\n", object);
3821    #endif
3822    copy = copy_object(object, SCAVENGER_HOOK_NWORDS);    copy = copy_object(object, SCAVENGER_HOOK_NWORDS);
3823    return copy;    return copy;
3824  }  }
# Line 3610  size_scavenger_hook(lispobj *where) Line 3832  size_scavenger_hook(lispobj *where)
3832    
3833  /* Initialization */  /* Initialization */
3834    
3835  static int  static int scav_lose(lispobj *where, lispobj object)
 scav_lose(lispobj *where, lispobj object)  
3836  {  {
3837      fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x\n",      fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x\n",
3838              (unsigned long) object);              (unsigned long) object);
# Line 3619  scav_lose(lispobj *where, lispobj object Line 3840  scav_lose(lispobj *where, lispobj object
3840      return 0;      return 0;
3841  }  }
3842    
3843  static lispobj  static lispobj trans_lose(lispobj object)
 trans_lose(lispobj object)  
3844  {  {
3845      fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",      fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",
3846              (unsigned long) object);              (unsigned long) object);
# Line 3628  trans_lose(lispobj object) Line 3848  trans_lose(lispobj object)
3848      return NIL;      return NIL;
3849  }  }
3850    
3851  static int  static int size_lose(lispobj *where)
 size_lose(lispobj *where)  
3852  {  {
3853          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",
3854                  (unsigned long) where);                  (unsigned long) where);
#