/[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.63 by cshapiro, Sun Feb 6 06:11:00 2005 UTC revision 1.63.2.3 by rtoy, Wed Dec 21 19:09:26 2005 UTC
# Line 26  Line 26 
26  #include "interr.h"  #include "interr.h"
27  #include "gencgc.h"  #include "gencgc.h"
28    
29    
30  #define gc_abort() lose("GC invariant lost!  File \"%s\", line %d\n", \  #define gc_abort() lose("GC invariant lost!  File \"%s\", line %d\n", \
31                          __FILE__, __LINE__)                          __FILE__, __LINE__)
32    
# Line 72  Line 73 
73   * the same as *current-region-free-pointer* and is stored in   * the same as *current-region-free-pointer* and is stored in
74   * alloc-tn.   * alloc-tn.
75   */   */
76    #define set_alloc_pointer(value)
77    #define get_alloc_pointer() \
78      ((unsigned long) current_dynamic_space_free_pointer & ~lowtag_Mask)
79    #define get_binding_stack_pointer() \
80      (current_binding_stack_pointer)
81    #define get_pseudo_atomic_atomic() \
82      ((unsigned long)current_dynamic_space_free_pointer & pseudo_atomic_Value)
83    #define set_pseudo_atomic_atomic() \
84      (current_dynamic_space_free_pointer \
85       = (lispobj*) ((unsigned long)current_dynamic_space_free_pointer | pseudo_atomic_Value))
86    #define clr_pseudo_atomic_atomic() \
87      (current_dynamic_space_free_pointer \
88       = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_Value))
89    #define get_pseudo_atomic_interrupted() \
90      ((unsigned long) current_dynamic_space_free_pointer & pseudo_atomic_InterruptedValue)
91    #define clr_pseudo_atomic_interrupted() \
92      (current_dynamic_space_free_pointer \
93       = (lispobj*) ((unsigned long) current_dynamic_space_free_pointer & ~pseudo_atomic_InterruptedValue))
94    
95    #define set_current_region_free(value) \
96      current_dynamic_space_free_pointer = (lispobj*)((value) | ((long)current_dynamic_space_free_pointer & lowtag_Mask))
97    
98    #define get_current_region_free() \
99      ((long)current_dynamic_space_free_pointer & (~(lowtag_Mask)))
100    
101    #define set_current_region_end(value) \
102      SetSymbolValue(CURRENT_REGION_END_ADDR, (value))
103    
104    #elif defined(DARWIN)
105    #ifndef pseudo_atomic_InterruptedValue
106    #define pseudo_atomic_InterruptedValue 1
107    #endif
108    #ifndef pseudo_atomic_Value
109    #define pseudo_atomic_Value 4
110    #endif
111    
112  #define set_alloc_pointer(value)  #define set_alloc_pointer(value)
113  #define get_alloc_pointer() \  #define get_alloc_pointer() \
114    ((unsigned long) current_dynamic_space_free_pointer & ~lowtag_Mask)    ((unsigned long) current_dynamic_space_free_pointer & ~lowtag_Mask)
# Line 106  Line 143 
143    
144  /* Define for activating assertions.  */  /* Define for activating assertions.  */
145    
146  #if 0  #if 1
147  #define GC_ASSERTIONS 1  #define GC_ASSERTIONS 1
148  #endif  #endif
149    
# Line 117  Line 154 
154  static void *invalid_stack_start, *invalid_stack_end;  static void *invalid_stack_start, *invalid_stack_end;
155    
156  static inline void  static inline void
157  check_escaped_stack_object (lispobj *where, lispobj obj)  check_escaped_stack_object(lispobj * where, lispobj obj)
158  {  {
159    void *p;  #ifndef DARWIN
160    if (Pointerp (obj)      void *p;
161        && (p = (void *) PTR (obj),  
162            (p >= (void *) CONTROL_STACK_START      if (Pointerp(obj)
163             && p < (void *) CONTROL_STACK_END)))          && (p = (void *) PTR(obj),
164      {              (p >= (void *) CONTROL_STACK_START
165        char *space;               && p < (void *) CONTROL_STACK_END))) {
166            char *space;
167        if (where >= (lispobj *) DYNAMIC_0_SPACE_START  
168            && where < (lispobj *) (DYNAMIC_0_SPACE_START + DYNAMIC_SPACE_SIZE))          if (where >= (lispobj *) DYNAMIC_0_SPACE_START
169          space = "dynamic space";              && where < (lispobj *) (DYNAMIC_0_SPACE_START + DYNAMIC_SPACE_SIZE))
170        else if (where >= (lispobj *) STATIC_SPACE_START              space = "dynamic space";
171                 && where < (lispobj *) (STATIC_SPACE_START + STATIC_SPACE_SIZE))          else if (where >= (lispobj *) STATIC_SPACE_START
172          space = "static space";                   && where <
173        else if (where >= (lispobj *) READ_ONLY_SPACE_START                   (lispobj *) (STATIC_SPACE_START + STATIC_SPACE_SIZE)) space =
174                 && where < (lispobj *) (READ_ONLY_SPACE_START + READ_ONLY_SPACE_SIZE))                  "static space";
175          space = "read-only space";          else if (where >= (lispobj *) READ_ONLY_SPACE_START
176        else                   && where <
177          space = NULL;                   (lispobj *) (READ_ONLY_SPACE_START +
178                                  READ_ONLY_SPACE_SIZE)) space = "read-only space";
179        /* GC itself uses some stack, so we can't tell exactly where the          else
180           invalid stack area starts.  Usually, it should be an error if a              space = NULL;
181           reference to a stack-allocated object is found, although it  
182           is valid to store a reference to a stack-allocated object          /* GC itself uses some stack, so we can't tell exactly where the
183           temporarily in another reachable object, as long as the             invalid stack area starts.  Usually, it should be an error if a
184           reference goes away at the end of a dynamic extent.  */             reference to a stack-allocated object is found, although it
185               is valid to store a reference to a stack-allocated object
186        if (p >= invalid_stack_start && p < invalid_stack_end)             temporarily in another reachable object, as long as the
187          lose ("Escaped stack-allocated object 0x%08lx at %p in %s\n",             reference goes away at the end of a dynamic extent.  */
188                (unsigned long) obj, where, space);  
189            if (p >= invalid_stack_start && p < invalid_stack_end)
190                lose("Escaped stack-allocated object 0x%08lx at %p in %s\n",
191                     (unsigned long) obj, where, space);
192  #ifndef i386  #ifndef i386
193        else if ((where >= (lispobj *) CONTROL_STACK_START          else if ((where >= (lispobj *) CONTROL_STACK_START
194                  && where < (lispobj *) (CONTROL_STACK_END))                    && where < (lispobj *) (CONTROL_STACK_END))
195                 || (space == NULL))                   || (space == NULL)) {
196          {              /* Do nothing if it the reference is from the control stack,
197            /* Do nothing if it the reference is from the control stack,                 because that will happen, and that's ok.  Or if it's from
198               because that will happen, and that's ok.  Or if it's from                 an unknown space (typically from scavenging an interrupt
199               an unknown space (typically from scavenging an interrupt                 context. */
200               context. */          }
         }  
201  #endif  #endif
202    
203        else          else
204          fprintf (stderr,              fprintf(stderr,
205                   "Reference to stack-allocated object 0x%08lx at %p in %s\n",                      "Reference to stack-allocated object 0x%08lx at %p in %s\n",
206                   (unsigned long) obj, where, space ? space : "Unknown space");                      (unsigned long) obj, where,
207                        space ? space : "Unknown space");
208      }      }
209    #endif
210  }  }
211    
212  #endif /* GC_ASSERTIONS */  #endif /* GC_ASSERTIONS */
# Line 179  check_escaped_stack_object (lispobj *whe Line 220  check_escaped_stack_object (lispobj *whe
220  #else  #else
221  #define gc_assert(ex)  (void) 0  #define gc_assert(ex)  (void) 0
222  #endif  #endif
   
223    
224    
225  /*  /*
226   * The number of generations, an extra is added to this for use as a temp.   * The number of generations, an extra is added to this for use as a temp.
227   */   */
# Line 199  unsigned counters_verbose = 0; Line 240  unsigned counters_verbose = 0;
240   * To enable the use of page protection to help avoid the scavenging   * To enable the use of page protection to help avoid the scavenging
241   * of pages that don't have pointers to younger generations.   * of pages that don't have pointers to younger generations.
242   */   */
243  boolean  enable_page_protection = TRUE;  boolean enable_page_protection = TRUE;
244    
245  /*  /*
246   * Hunt for pointers to old-space, when GCing generations >= verify_gen.   * Hunt for pointers to old-space, when GCing generations >= verify_gen.
# Line 217  boolean pre_verify_gen_0 = FALSE; Line 258  boolean pre_verify_gen_0 = FALSE;
258  /*  /*
259   * Enable checking for bad pointers after gc_free_heap called from purify.   * Enable checking for bad pointers after gc_free_heap called from purify.
260   */   */
261  boolean verify_after_free_heap = FALSE;  boolean verify_after_free_heap = TRUE;
262    
263  /*  /*
264   * Enable the printing of a note when code objects are found in the   * Enable the printing of a note when code objects are found in the
# Line 245  boolean gencgc_unmap_zero = TRUE; Line 286  boolean gencgc_unmap_zero = TRUE;
286  /*  /*
287   * Enable checking that newly allocated regions are zero filled.   * Enable checking that newly allocated regions are zero filled.
288   */   */
289  boolean gencgc_zero_check = FALSE;  boolean gencgc_zero_check = TRUE;
290    
291  boolean gencgc_enable_verify_zero_fill = FALSE;  boolean gencgc_enable_verify_zero_fill = TRUE;
292    
293  /*  /*
294   * Enable checking that free pages are zero filled during gc_free_heap   * Enable checking that free pages are zero filled during gc_free_heap
295   * called after purify.   * called after purify.
296   */   */
297  boolean gencgc_zero_check_during_free_heap = FALSE;  boolean gencgc_zero_check_during_free_heap = TRUE;
298    
299  /*  /*
300   * The minimum size for a large object.   * The minimum size for a large object.
# Line 266  unsigned large_object_size = 4 * PAGE_SI Line 307  unsigned large_object_size = 4 * PAGE_SI
307   * interrupt safety during object initialisation.   * interrupt safety during object initialisation.
308   */   */
309  boolean enable_pointer_filter = TRUE;  boolean enable_pointer_filter = TRUE;
   
310    
311    
312  /*  /*
313   * The total bytes allocated. Seen by (dynamic-usage)   * The total bytes allocated. Seen by (dynamic-usage)
314   */   */
# Line 299  unsigned long reserved_heap_pages = 256; Line 340  unsigned long reserved_heap_pages = 256;
340   */   */
341  static int from_space;  static int from_space;
342  static int new_space;  static int new_space;
   
343    
344    
345  /*  /*
346   * GC structures and variables.   * GC structures and variables.
347   */   */
# Line 325  static char *heap_base = NULL; Line 366  static char *heap_base = NULL;
366  /*  /*
367   * Calculate the start address for the given page number.   * Calculate the start address for the given page number.
368   */   */
369  inline char *page_address(int page_num)  inline char *
370    page_address(int page_num)
371  {  {
372    return heap_base + PAGE_SIZE * page_num;      return heap_base + PAGE_SIZE * page_num;
373  }  }
374    
375  /*  /*
376   * Find the page index within the page_table for the given address.   * Find the page index within the page_table for the given address.
377   * Returns -1 on failure.   * Returns -1 on failure.
378   */   */
379  inline int find_page_index(void *addr)  inline int
380    find_page_index(void *addr)
381  {  {
382    int index = (char*)addr - heap_base;      int index = (char *) addr - heap_base;
383    
384    if (index >= 0) {      if (index >= 0) {
385      index = (unsigned int) index / PAGE_SIZE;          index = (unsigned int) index / PAGE_SIZE;
386      if (index < dynamic_space_pages)          if (index < dynamic_space_pages)
387        return index;              return index;
388    }      }
389    
390    return -1;      return -1;
391  }  }
392    
393    
# Line 353  inline int find_page_index(void *addr) Line 396  inline int find_page_index(void *addr)
396   */   */
397  struct generation {  struct generation {
398    
399    /* The first page that gc_alloc checks on its next call. */      /* The first page that gc_alloc checks on its next call. */
400    int  alloc_start_page;      int alloc_start_page;
401    
402        /* The first page that gc_alloc_unboxed checks on its next call. */
403        int alloc_unboxed_start_page;
404    
405        /*
406         * The first page that gc_alloc_large (boxed) considers on its next call.
407         * Although it always allocates after the boxed_region.
408         */
409        int alloc_large_start_page;
410    
411        /*
412         * The first page that gc_alloc_large (unboxed) considers on its next call.
413         * Although it always allocates after the current_unboxed_region.
414         */
415        int alloc_large_unboxed_start_page;
416    
417        /* The bytes allocate to this generation. */
418        int bytes_allocated;
419    
420        /* The number of bytes at which to trigger a GC */
421        int gc_trigger;
422    
423        /* To calculate a new level for gc_trigger */
424        int bytes_consed_between_gc;
425    
426    /* The first page that gc_alloc_unboxed checks on its next call. */      /* The number of GCs since the last raise. */
427    int  alloc_unboxed_start_page;      int num_gc;
428    
429    /*      /*
430     * The first page that gc_alloc_large (boxed) considers on its next call.       * The average age at after which a GC will raise objects to the
431     * Although it always allocates after the boxed_region.       * next generation.
432     */       */
433    int  alloc_large_start_page;      int trigger_age;
434    
435    /*      /*
436     * The first page that gc_alloc_large (unboxed) considers on its next call.       * The cumulative sum of the bytes allocated to this generation. It
437     * Although it always allocates after the current_unboxed_region.       * is cleared after a GC on this generation, and update before new
438     */       * objects are added from a GC of a younger generation. Dividing by
439    int  alloc_large_unboxed_start_page;       * the bytes_allocated will give the average age of the memory in
440         * this generation since its last GC.
441    /* The bytes allocate to this generation. */       */
442    int  bytes_allocated;      int cum_sum_bytes_allocated;
443    
444    /* The number of bytes at which to trigger a GC */      /*
445    int  gc_trigger;       * A minimum average memory age before a GC will occur helps prevent
446         * a GC when a large number of new live objects have been added, in
447    /* To calculate a new level for gc_trigger */       * which case a GC could be a waste of time.
448    int  bytes_consed_between_gc;       */
449        double min_av_mem_age;
   /* The number of GCs since the last raise. */  
   int  num_gc;  
   
   /*  
    * The average age at after which a GC will raise objects to the  
    * next generation.  
    */  
   int  trigger_age;  
   
   /*  
    * The cumulative sum of the bytes allocated to this generation. It  
    * is cleared after a GC on this generation, and update before new  
    * objects are added from a GC of a younger generation. Dividing by  
    * the bytes_allocated will give the average age of the memory in  
    * this generation since its last GC.  
    */  
   int  cum_sum_bytes_allocated;  
   
   /*  
    * A minimum average memory age before a GC will occur helps prevent  
    * a GC when a large number of new live objects have been added, in  
    * which case a GC could be a waste of time.  
    */  
   double  min_av_mem_age;  
450  };  };
451    
452  /*  /*
# Line 418  static struct generation generations[NUM Line 461  static struct generation generations[NUM
461  */  */
462    
463  struct generation_stats {  struct generation_stats {
464    int  bytes_allocated;      int bytes_allocated;
465    int  gc_trigger;      int gc_trigger;
466    int  bytes_consed_between_gc;      int bytes_consed_between_gc;
467    int  num_gc;      int num_gc;
468    int  trigger_age;      int trigger_age;
469    int  cum_sum_bytes_allocated;      int cum_sum_bytes_allocated;
470    double  min_av_mem_age;      double min_av_mem_age;
471  };  };
472    
473    
474  /*  /*
475   * The oldest generation that will currently be GCed by default.   * The oldest generation that will currently be GCed by default.
# Line 442  struct generation_stats { Line 485  struct generation_stats {
485   * into an older generation so an unnecessary GC of this long-lived   * into an older generation so an unnecessary GC of this long-lived
486   * data can be avoided.   * data can be avoided.
487   */   */
488  unsigned int  gencgc_oldest_gen_to_gc = NUM_GENERATIONS - 1;  unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS - 1;
489    
490    
491  /*  /*
# Line 451  unsigned int  gencgc_oldest_gen_to_gc = Line 494  unsigned int  gencgc_oldest_gen_to_gc =
494   * search of the heap. XX Gencgc obviously needs to be better   * search of the heap. XX Gencgc obviously needs to be better
495   * integrated with the lisp code.   * integrated with the lisp code.
496   */   */
497  static int  last_free_page;  static int last_free_page;
498    
499    
500    
   
501  /*  /*
502   * Misc. heap functions.   * Misc. heap functions.
503   */   */
# Line 462  static int  last_free_page; Line 505  static int  last_free_page;
505  /*  /*
506   * Count the number of write protected pages within the given generation.   * Count the number of write protected pages within the given generation.
507   */   */
508  static int count_write_protect_generation_pages(int generation)  static int
509    count_write_protect_generation_pages(int generation)
510  {  {
511    int i;      int i;
512    int cnt = 0;      int cnt = 0;
513    int mmask, mflags;      int mmask, mflags;
514    
515    mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK      mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
516      | PAGE_GENERATION_MASK;          | PAGE_GENERATION_MASK;
517    mflags = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK | generation;      mflags = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK | generation;
518    
519    for (i = 0; i < last_free_page; i++)      for (i = 0; i < last_free_page; i++)
520      if (PAGE_FLAGS(i, mmask) == mflags)          if (PAGE_FLAGS(i, mmask) == mflags)
521        cnt++;              cnt++;
522    return cnt;      return cnt;
523  }  }
524    
525  /*  /*
526   * Count the number of pages within the given generation.   * Count the number of pages within the given generation.
527   */   */
528  static int count_generation_pages(int generation)  static int
529    count_generation_pages(int generation)
530  {  {
531    int i;      int i;
532    int cnt = 0;      int cnt = 0;
533    int mmask, mflags;      int mmask, mflags;
534    
535    mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;      mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;
536    mflags = PAGE_ALLOCATED_MASK | generation;      mflags = PAGE_ALLOCATED_MASK | generation;
537    
538    for (i = 0; i < last_free_page; i++)      for (i = 0; i < last_free_page; i++)
539      if (PAGE_FLAGS(i, mmask) == mflags)          if (PAGE_FLAGS(i, mmask) == mflags)
540        cnt++;              cnt++;
541    return cnt;      return cnt;
542  }  }
543    
544  /*  /*
545   * Count the number of dont_move pages.   * Count the number of dont_move pages.
546   */   */
547  static int count_dont_move_pages(void)  static int
548    count_dont_move_pages(void)
549  {  {
550    int i;      int i;
551    int cnt = 0;      int cnt = 0;
552    int mmask;      int mmask;
553    
554    mmask = PAGE_ALLOCATED_MASK | PAGE_DONT_MOVE_MASK;      mmask = PAGE_ALLOCATED_MASK | PAGE_DONT_MOVE_MASK;
555    
556    for (i = 0; i < last_free_page; i++)      for (i = 0; i < last_free_page; i++)
557      if (PAGE_FLAGS(i, mmask) == mmask)          if (PAGE_FLAGS(i, mmask) == mmask)
558        cnt++;              cnt++;
559    return cnt;      return cnt;
560  }  }
561    
562  /*  /*
# Line 518  static int count_dont_move_pages(void) Line 564  static int count_dont_move_pages(void)
564   * given generation.   * given generation.
565   */   */
566  #ifdef GC_ASSERTIONS  #ifdef GC_ASSERTIONS
567  static int generation_bytes_allocated (int generation)  static int
568    generation_bytes_allocated(int generation)
569  {  {
570    int i;      int i;
571    int bytes_allocated = 0;      int bytes_allocated = 0;
572    int mmask, mflags;      int mmask, mflags;
573    
574    mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;      mmask = PAGE_ALLOCATED_MASK | PAGE_GENERATION_MASK;
575    mflags = PAGE_ALLOCATED_MASK | generation;      mflags = PAGE_ALLOCATED_MASK | generation;
576    
577    for (i = 0; i < last_free_page; i++) {      for (i = 0; i < last_free_page; i++) {
578      if (PAGE_FLAGS(i, mmask) == mflags)          if (PAGE_FLAGS(i, mmask) == mflags)
579        bytes_allocated += page_table[i].bytes_used;              bytes_allocated += page_table[i].bytes_used;
580    }      }
581    return bytes_allocated;      return bytes_allocated;
582  }  }
583  #endif  #endif
584    
585  /*  /*
586   * Return the average age of the memory in a generation.   * Return the average age of the memory in a generation.
587   */   */
588  static double gen_av_mem_age(int gen)  static double
589    gen_av_mem_age(int gen)
590  {  {
591    if (generations[gen].bytes_allocated == 0)      if (generations[gen].bytes_allocated == 0)
592      return 0.0;          return 0.0;
593    
594    return (double) generations[gen].cum_sum_bytes_allocated /      return (double) generations[gen].cum_sum_bytes_allocated /
595                  (double) generations[gen].bytes_allocated;          (double) generations[gen].bytes_allocated;
596  }  }
597    
598  /*  /*
599   * The verbose argument controls how much to print out:   * The verbose argument controls how much to print out:
600   * 0 for normal level of detail; 1 for debugging.   * 0 for normal level of detail; 1 for debugging.
601   */   */
602  void print_generation_stats(int  verbose)  void
603    print_generation_stats(int verbose)
604  {  {
605    int i, gens;      int i, gens;
606    
607  #if defined(i386) || defined(__x86_64)  #if defined(i386) || defined(__x86_64)
608  #define FPU_STATE_SIZE 27  #define FPU_STATE_SIZE 27
609    int fpu_state[FPU_STATE_SIZE];      int fpu_state[FPU_STATE_SIZE];
610  #elif defined(sparc)  #elif defined(sparc)
611    /*      /*
612     * 32 (single-precision) FP registers, and the FP state register.       * 32 (single-precision) FP registers, and the FP state register.
613     * But Sparc V9 has 32 double-precision registers (equivalent to 64       * But Sparc V9 has 32 double-precision registers (equivalent to 64
614     * single-precision, but can't be accessed), so we leave enough room       * single-precision, but can't be accessed), so we leave enough room
615     * for that.       * for that.
616     */       */
617  #define FPU_STATE_SIZE (((32 + 32 + 1) + 1)/2)  #define FPU_STATE_SIZE (((32 + 32 + 1) + 1)/2)
618    long long fpu_state[FPU_STATE_SIZE];      long long fpu_state[FPU_STATE_SIZE];
619    #elif defined(DARWIN)
620    #define FPU_STATE_SIZE 32
621        long long fpu_state[FPU_STATE_SIZE];
622  #endif  #endif
623    
624    /*      /*
625     * This code uses the FP instructions which may be setup for Lisp so       * This code uses the FP instructions which may be setup for Lisp so
626     * they need to the saved and reset for C.       * they need to the saved and reset for C.
627     */       */
628    fpu_save(fpu_state);  
629        fpu_save(fpu_state);
630    /* Number of generations to print out. */  
631    if (verbose)  
632      gens = NUM_GENERATIONS + 1;      /* Number of generations to print out. */
633    else      if (verbose)
634      gens = NUM_GENERATIONS;          gens = NUM_GENERATIONS + 1;
635        else
636    /* Print the heap stats */          gens = NUM_GENERATIONS;
637    fprintf(stderr, "          Page count (%d KB)\n", PAGE_SIZE / 1024);  
638    fprintf(stderr, "   Gen  Boxed Unboxed  LB   LUB    Alloc    Waste    Trigger   WP  GCs Mem-age\n");      /* Print the heap stats */
639        fprintf(stderr, "          Page count (%d KB)\n", PAGE_SIZE / 1024);
640    for (i = 0; i < gens; i++) {      fprintf(stderr,
641      int j;              "   Gen  Boxed Unboxed  LB   LUB    Alloc    Waste    Trigger   WP  GCs Mem-age\n");
642      int boxed_cnt = 0;  
643      int unboxed_cnt = 0;      for (i = 0; i < gens; i++) {
644      int large_boxed_cnt = 0;          int j;
645      int large_unboxed_cnt = 0;          int boxed_cnt = 0;
646            int unboxed_cnt = 0;
647      for (j = 0; j < last_free_page; j++) {          int large_boxed_cnt = 0;
648        int flags = page_table[j].flags;          int large_unboxed_cnt = 0;
649        if ((flags & PAGE_GENERATION_MASK) == i) {  
650          if (flags & PAGE_ALLOCATED_MASK) {          for (j = 0; j < last_free_page; j++) {
651            /*              int flags = page_table[j].flags;
652             * Count the number of boxed and unboxed pages within the  
653             * given generation.              if ((flags & PAGE_GENERATION_MASK) == i) {
654             */                  if (flags & PAGE_ALLOCATED_MASK) {
655            if (flags & PAGE_UNBOXED_MASK)                      /*
656              if (flags & PAGE_LARGE_OBJECT_MASK)                       * Count the number of boxed and unboxed pages within the
657                large_unboxed_cnt++;                       * given generation.
658              else                       */
659                unboxed_cnt++;                      if (flags & PAGE_UNBOXED_MASK)
660            else                          if (flags & PAGE_LARGE_OBJECT_MASK)
661              if (flags & PAGE_LARGE_OBJECT_MASK)                              large_unboxed_cnt++;
662                large_boxed_cnt++;                          else
663              else                              unboxed_cnt++;
664                boxed_cnt++;                      else if (flags & PAGE_LARGE_OBJECT_MASK)
665                            large_boxed_cnt++;
666                        else
667                            boxed_cnt++;
668                    }
669                }
670          }          }
       }  
     }  
671    
672      gc_assert(generations[i].bytes_allocated == generation_bytes_allocated(i));          gc_assert(generations[i].bytes_allocated ==
673      fprintf(stderr, " %5d: %5d %5d %5d %5d %10d %6d %10d %4d %3d %7.4f\n",                    generation_bytes_allocated(i));
674              i, boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt,          fprintf(stderr, " %5d: %5d %5d %5d %5d %10d %6d %10d %4d %3d %7.4f\n",
675              generations[i].bytes_allocated,                  i, boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt,
676              PAGE_SIZE * count_generation_pages(i) -                  generations[i].bytes_allocated,
677              generations[i].bytes_allocated,                  PAGE_SIZE * count_generation_pages(i) -
678              generations[i].gc_trigger,                  generations[i].bytes_allocated, generations[i].gc_trigger,
679              count_write_protect_generation_pages(i),                  count_write_protect_generation_pages(i), generations[i].num_gc,
680              generations[i].num_gc,                  gen_av_mem_age(i));
681              gen_av_mem_age(i));      }
682    }      fprintf(stderr, "   Total bytes alloc=%ld\n", bytes_allocated);
   fprintf(stderr, "   Total bytes alloc=%ld\n", bytes_allocated);  
683    
684    fpu_restore(fpu_state);      fpu_restore(fpu_state);
685  }  }
686    
687  /* Get statistics that are kept "on the fly" out of the generation  /* Get statistics that are kept "on the fly" out of the generation
688     array.     array.
689  */  */
690  void get_generation_stats(int gen, struct generation_stats *stats)  void
691    get_generation_stats(int gen, struct generation_stats *stats)
692  {  {
693    if (gen <= NUM_GENERATIONS) {      if (gen <= NUM_GENERATIONS) {
694      stats->bytes_allocated = generations[gen].bytes_allocated;          stats->bytes_allocated = generations[gen].bytes_allocated;
695      stats->gc_trigger = generations[gen].gc_trigger;          stats->gc_trigger = generations[gen].gc_trigger;
696      stats->bytes_consed_between_gc = generations[gen].bytes_consed_between_gc;          stats->bytes_consed_between_gc =
697      stats->num_gc = generations[gen].num_gc;              generations[gen].bytes_consed_between_gc;
698      stats->trigger_age = generations[gen].trigger_age;          stats->num_gc = generations[gen].num_gc;
699      stats->cum_sum_bytes_allocated = generations[gen].cum_sum_bytes_allocated;          stats->trigger_age = generations[gen].trigger_age;
700      stats->min_av_mem_age = generations[gen].min_av_mem_age;          stats->cum_sum_bytes_allocated =
701    }              generations[gen].cum_sum_bytes_allocated;
702            stats->min_av_mem_age = generations[gen].min_av_mem_age;
703        }
704  }  }
705    
706  void set_gc_trigger(int gen, int trigger)  void
707    set_gc_trigger(int gen, int trigger)
708  {  {
709    if (gen <= NUM_GENERATIONS) {      if (gen <= NUM_GENERATIONS) {
710      generations[gen].gc_trigger = trigger;          generations[gen].gc_trigger = trigger;
711    }      }
712  }  }
713    
714  void set_trigger_age(int gen, int trigger_age)  void
715    set_trigger_age(int gen, int trigger_age)
716  {  {
717    if (gen <= NUM_GENERATIONS) {      if (gen <= NUM_GENERATIONS) {
718      generations[gen].trigger_age = trigger_age;          generations[gen].trigger_age = trigger_age;
719    }      }
720  }  }
721    
722  void set_min_mem_age(int gen, double min_mem_age)  void
723    set_min_mem_age(int gen, double min_mem_age)
724  {  {
725    if (gen <= NUM_GENERATIONS) {      if (gen <= NUM_GENERATIONS) {
726      generations[gen].min_av_mem_age = min_mem_age;          generations[gen].min_av_mem_age = min_mem_age;
727    }      }
728  }  }
729    
730  /*  /*
# Line 719  void set_min_mem_age(int gen, double min Line 780  void set_min_mem_age(int gen, double min
780   * Only using two regions at present, both are for the current   * Only using two regions at present, both are for the current
781   * newspace generation.   * newspace generation.
782   */   */
783  struct alloc_region  boxed_region;  struct alloc_region boxed_region;
784  struct alloc_region  unboxed_region;  struct alloc_region unboxed_region;
785    
786  #if 0  #if 0
787  /*  /*
# Line 731  void *current_region_end_addr; Line 792  void *current_region_end_addr;
792  #endif  #endif
793    
794  /* The generation currently being allocated to. X */  /* The generation currently being allocated to. X */
795  static int  gc_alloc_generation;  static int gc_alloc_generation;
796    
797  extern void do_dynamic_space_overflow_warning(void);  extern void do_dynamic_space_overflow_warning(void);
798  extern void do_dynamic_space_overflow_error(void);  extern void do_dynamic_space_overflow_error(void);
799    
800  /* Handle heap overflow here, maybe. */  /* Handle heap overflow here, maybe. */
801  static void  static void
802  handle_heap_overflow(const char* msg, int size)  handle_heap_overflow(const char *msg, int size)
803  {  {
804    unsigned long heap_size_mb;      unsigned long heap_size_mb;
805    
806    if (msg)      if (msg) {
807      {          fprintf(stderr, msg, size);
       fprintf(stderr, msg, size);  
808      }      }
809  #ifndef SPARSE_BLOCK_SIZE  #ifndef SPARSE_BLOCK_SIZE
810  #define SPARSE_BLOCK_SIZE (0)  #define SPARSE_BLOCK_SIZE (0)
811  #endif  #endif
812    
813        /* Figure out how many MB of heap we have */
814        heap_size_mb = (dynamic_space_size + SPARSE_BLOCK_SIZE) >> 20;
815    
816    /* Figure out how many MB of heap we have */      fprintf(stderr, " CMUCL has run out of dynamic heap space (%lu MB).\n",
817    heap_size_mb = (dynamic_space_size + SPARSE_BLOCK_SIZE) >> 20;              heap_size_mb);
818        /* Try to handle heap overflow somewhat gracefully if we can. */
   fprintf(stderr, " CMUCL has run out of dynamic heap space (%lu MB).\n", heap_size_mb);  
   /* Try to handle heap overflow somewhat gracefully if we can. */  
819  #if defined(trap_DynamicSpaceOverflow) || defined(FEATURE_HEAP_OVERFLOW_CHECK)  #if defined(trap_DynamicSpaceOverflow) || defined(FEATURE_HEAP_OVERFLOW_CHECK)
820    if (reserved_heap_pages == 0)      if (reserved_heap_pages == 0) {
821      {          fprintf(stderr, "\n Returning to top-level.\n");
822        fprintf(stderr, "\n Returning to top-level.\n");          do_dynamic_space_overflow_error();
823        do_dynamic_space_overflow_error();      } else {
824      }          fprintf(stderr,
825    else                  "  You can control heap size with the -dynamic-space-size commandline option.\n");
826      {          do_dynamic_space_overflow_warning();
       fprintf(stderr, "  You can control heap size with the -dynamic-space-size commandline option.\n");  
       do_dynamic_space_overflow_warning();  
827      }      }
828  #else  #else
829    print_generation_stats(1);      print_generation_stats(1);
830    
831    exit(1);      exit(1);
832  #endif  #endif
833  }  }
834    
# Line 797  handle_heap_overflow(const char* msg, in Line 856  handle_heap_overflow(const char* msg, in
856   * allocation call using the same pages, all the pages in the region   * allocation call using the same pages, all the pages in the region
857   * are allocated, although they will initially be empty.   * are allocated, although they will initially be empty.
858   */   */
859  static void gc_alloc_new_region(int nbytes, int unboxed,  static void
860                                  struct alloc_region *alloc_region)  gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
861  {  {
862    int first_page;      int first_page;
863    int last_page;      int last_page;
864    int region_size;      int region_size;
865    int restart_page;      int restart_page;
866    int bytes_found;      int bytes_found;
867    int num_pages;      int num_pages;
868    int i;      int i;
869    int mmask, mflags;      int mmask, mflags;
870    
871    /* Shut up some compiler warnings */      /* Shut up some compiler warnings */
872    last_page = bytes_found = 0;      last_page = bytes_found = 0;
   
 #if 0  
   fprintf(stderr, "alloc_new_region for %d bytes from gen %d\n",  
           nbytes, gc_alloc_generation);  
 #endif  
   
   /* Check that the region is in a reset state. */  
   gc_assert(alloc_region->first_page == 0  
             && alloc_region->last_page == -1  
             && alloc_region->free_pointer == alloc_region->end_addr);  
   
   if (unboxed)  
     restart_page = generations[gc_alloc_generation].alloc_unboxed_start_page;  
   else  
     restart_page = generations[gc_alloc_generation].alloc_start_page;  
   
   /*  
    * Search for a contiguous free region of at least nbytes with the  
    * given properties: boxed/unboxed, generation. First setting up the  
    * mask and matching flags.  
    */  
   
   mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK  
     | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK  
     | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;  
   mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)  
     | gc_alloc_generation;  
   
   do {  
     first_page = restart_page;  
   
     /*  
      * First search for a page with at least 32 bytes free, that is  
      * not write protected, or marked dont_move.  
      */  
   
     while (first_page < dynamic_space_pages) {  
       int flags = page_table[first_page].flags;  
       if (!(flags & PAGE_ALLOCATED_MASK)  
           || ((flags & mmask) == mflags &&  
               page_table[first_page].bytes_used < PAGE_SIZE - 32))  
         break;  
       first_page++;  
     }  
873    
     /* Check for a failure */  
     if (first_page >= dynamic_space_pages - reserved_heap_pages) {  
874  #if 0  #if 0
875        handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n", nbytes);      fprintf(stderr, "alloc_new_region for %d bytes from gen %d\n",
876  #else              nbytes, gc_alloc_generation);
       break;  
877  #endif  #endif
     }  
878    
879      gc_assert(!PAGE_WRITE_PROTECTED(first_page));      /* Check that the region is in a reset state. */
880        gc_assert(alloc_region->first_page == 0
881                  && alloc_region->last_page == -1
882                  && alloc_region->free_pointer == alloc_region->end_addr);
883    
884  #if 0      if (unboxed)
885      fprintf(stderr, "  first_page=%d bytes_used=%d\n",          restart_page =
886              first_page, page_table[first_page].bytes_used);              generations[gc_alloc_generation].alloc_unboxed_start_page;
887  #endif      else
888            restart_page = generations[gc_alloc_generation].alloc_start_page;
889    
890      /*      /*
891       * Now search forward to calculate the available region size.  It       * Search for a contiguous free region of at least nbytes with the
892       * tries to keeps going until nbytes are found and the number of       * given properties: boxed/unboxed, generation. First setting up the
893       * pages is greater than some level. This helps keep down the       * mask and matching flags.
      * number of pages in a region.  
894       */       */
     last_page = first_page;  
     bytes_found = PAGE_SIZE - page_table[first_page].bytes_used;  
     num_pages = 1;  
     while ((bytes_found < nbytes || num_pages < 2)  
            && last_page < dynamic_space_pages - 1  
            && !PAGE_ALLOCATED(last_page + 1)) {  
       last_page++;  
       num_pages++;  
       bytes_found += PAGE_SIZE;  
       gc_assert(!PAGE_WRITE_PROTECTED(last_page));  
     }  
895    
896      region_size = (PAGE_SIZE - page_table[first_page].bytes_used)      mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
897        + PAGE_SIZE * (last_page - first_page);          | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK
898            | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;
899        mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
900            | gc_alloc_generation;
901    
902        do {
903            first_page = restart_page;
904    
905            /*
906             * First search for a page with at least 32 bytes free, that is
907             * not write protected, or marked dont_move.
908             */
909    
910            while (first_page < dynamic_space_pages) {
911                int flags = page_table[first_page].flags;
912    
913                if (!(flags & PAGE_ALLOCATED_MASK)
914                    || ((flags & mmask) == mflags &&
915                        page_table[first_page].bytes_used < PAGE_SIZE - 32))
916                    break;
917                first_page++;
918            }
919    
920            /* Check for a failure */
921            if (first_page >= dynamic_space_pages - reserved_heap_pages) {
922    #if 0
923                handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n",
924                                     nbytes);
925    #else
926                break;
927    #endif
928            }
929    
930      gc_assert(bytes_found == region_size);          gc_assert(!PAGE_WRITE_PROTECTED(first_page));
931    
932  #if 0  #if 0
933      fprintf(stderr, "  last_page=%d bytes_found=%d num_pages=%d\n",          fprintf(stderr, "  first_page=%d bytes_used=%d\n",
934              last_page, bytes_found, num_pages);                  first_page, page_table[first_page].bytes_used);
935  #endif  #endif
936    
937      restart_page = last_page + 1;          /*
938    }           * Now search forward to calculate the available region size.  It
939    while (restart_page < dynamic_space_pages && bytes_found < nbytes);           * tries to keeps going until nbytes are found and the number of
940             * pages is greater than some level. This helps keep down the
941             * number of pages in a region.
942             */
943            last_page = first_page;
944            bytes_found = PAGE_SIZE - page_table[first_page].bytes_used;
945            num_pages = 1;
946            while ((bytes_found < nbytes || num_pages < 2)
947                   && last_page < dynamic_space_pages - 1
948                   && !PAGE_ALLOCATED(last_page + 1)) {
949                last_page++;
950                num_pages++;
951                bytes_found += PAGE_SIZE;
952                gc_assert(!PAGE_WRITE_PROTECTED(last_page));
953            }
954    
955            region_size = (PAGE_SIZE - page_table[first_page].bytes_used)
956                + PAGE_SIZE * (last_page - first_page);
957    
958    if (first_page >= dynamic_space_pages - reserved_heap_pages) {          gc_assert(bytes_found == region_size);
     handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n", nbytes);  
   }  
   
   /* Check for a failure */  
   if (restart_page >= (dynamic_space_pages - reserved_heap_pages) && bytes_found < nbytes) {  
     handle_heap_overflow("*A1 gc_alloc_new_region failed, nbytes=%d.\n", nbytes);  
   }  
959    
960  #if 0  #if 0
961    fprintf(stderr, "gc_alloc_new_region gen %d: %d bytes: from pages %d to %d: addr=%x\n",          fprintf(stderr, "  last_page=%d bytes_found=%d num_pages=%d\n",
962            gc_alloc_generation, bytes_found, first_page, last_page,                  last_page, bytes_found, num_pages);
           page_address(first_page));  
963  #endif  #endif
964    
965    /* Setup the alloc_region. */          restart_page = last_page + 1;
966    alloc_region->first_page = first_page;      }
967    alloc_region->last_page = last_page;      while (restart_page < dynamic_space_pages && bytes_found < nbytes);
   alloc_region->start_addr = page_table[first_page].bytes_used  
     + page_address(first_page);  
   alloc_region->free_pointer = alloc_region->start_addr;  
   alloc_region->end_addr = alloc_region->start_addr + bytes_found;  
968    
969    if (gencgc_zero_check) {      if (first_page >= dynamic_space_pages - reserved_heap_pages) {
970      int *p;          handle_heap_overflow("*A2 gc_alloc_new_region failed, nbytes=%d.\n",
971      for(p = (int *)alloc_region->start_addr;                               nbytes);
972          p < (int *)alloc_region->end_addr; p++)      }
       if (*p != 0)  
         fprintf(stderr, "** new region not zero @ %lx\n", (unsigned long) p);  
   }  
973    
974    /* Setup the pages. */      /* Check for a failure */
975        if (restart_page >= (dynamic_space_pages - reserved_heap_pages)
976            && bytes_found < nbytes) {
977            handle_heap_overflow("*A1 gc_alloc_new_region failed, nbytes=%d.\n",
978                                 nbytes);
979        }
980    #if 0
981        fprintf(stderr,
982                "gc_alloc_new_region gen %d: %d bytes: from pages %d to %d: addr=%x\n",
983                gc_alloc_generation, bytes_found, first_page, last_page,
984                page_address(first_page));
985    #endif
986    
987        /* Setup the alloc_region. */
988        alloc_region->first_page = first_page;
989        alloc_region->last_page = last_page;
990        alloc_region->start_addr = page_table[first_page].bytes_used
991            + page_address(first_page);
992        alloc_region->free_pointer = alloc_region->start_addr;
993        alloc_region->end_addr = alloc_region->start_addr + bytes_found;
994    
995        if (gencgc_zero_check) {
996            int *p;
997    
998            for (p = (int *) alloc_region->start_addr;
999                 p < (int *) alloc_region->end_addr; p++)
1000                if (*p != 0)
1001                    fprintf(stderr, "** new region not zero @ %lx\n",
1002                            (unsigned long) p);
1003        }
1004    
1005        /* Setup the pages. */
1006    
1007        /* The first page may have already been in use. */
1008        if (page_table[first_page].bytes_used == 0) {
1009            PAGE_FLAGS_UPDATE(first_page, mmask, mflags);
1010            page_table[first_page].first_object_offset = 0;
1011        }
1012    
1013    /* The first page may have already been in use. */      gc_assert(PAGE_ALLOCATED(first_page));
1014    if (page_table[first_page].bytes_used == 0) {      gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
1015      PAGE_FLAGS_UPDATE(first_page, mmask, mflags);      gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
1016      page_table[first_page].first_object_offset = 0;      gc_assert(!PAGE_LARGE_OBJECT(first_page));
   }  
1017    
1018    gc_assert(PAGE_ALLOCATED(first_page));      for (i = first_page + 1; i <= last_page; i++) {
1019    gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);          PAGE_FLAGS_UPDATE(i, PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK
1020    gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);                            | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,
1021    gc_assert(!PAGE_LARGE_OBJECT(first_page));                            PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
1022                              | gc_alloc_generation);
1023            /*
1024             * This may not be necessary for unboxed regions (think it was
1025             * broken before!)
1026             */
1027            page_table[i].first_object_offset =
1028                alloc_region->start_addr - page_address(i);
1029        }
1030    
1031    for (i = first_page + 1; i <= last_page; i++) {      /* Bump up the last_free_page */
1032      PAGE_FLAGS_UPDATE(i, PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK      if (last_page + 1 > last_free_page) {
1033                        | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,          last_free_page = last_page + 1;
1034                        PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)          set_alloc_pointer((lispobj) ((char *) heap_base +
1035                        | gc_alloc_generation);                                       PAGE_SIZE * last_free_page));
     /*  
      * This may not be necessary for unboxed regions (think it was  
      * broken before!)  
      */  
     page_table[i].first_object_offset =  
       alloc_region->start_addr - page_address(i);  
   }  
1036    
1037    /* Bump up the last_free_page */      }
   if (last_page + 1 > last_free_page) {  
     last_free_page = last_page + 1;  
     set_alloc_pointer((lispobj) ((char *) heap_base +  
                                PAGE_SIZE * last_free_page));  
   
   }  
1038  }  }
1039    
1040    
# Line 994  static void gc_alloc_new_region(int nbyt Line 1061  static void gc_alloc_new_region(int nbyt
1061  static int record_new_objects = 0;  static int record_new_objects = 0;
1062  static int new_areas_ignore_page;  static int new_areas_ignore_page;
1063  struct new_area {  struct new_area {
1064    int  page;      int page;
1065    int  offset;      int offset;
1066    int  size;      int size;
1067  };  };
1068  static struct new_area (*new_areas)[];  static struct new_area (*new_areas)[];
1069  static int new_areas_index;  static int new_areas_index;
1070  int max_new_areas;  int max_new_areas;
1071    
1072  /* Add a new area to new_areas. */  /* Add a new area to new_areas. */
1073  static void add_new_area(int first_page, int offset, int size)  static void
1074    add_new_area(int first_page, int offset, int size)
1075  {  {
1076    unsigned new_area_start,c;      unsigned new_area_start, c;
1077    int i;      int i;
1078    
1079    /* Ignore if full */      /* Ignore if full */
1080    if (new_areas_index >= NUM_NEW_AREAS)      if (new_areas_index >= NUM_NEW_AREAS)
1081      return;          return;
1082    
1083    switch (record_new_objects) {      switch (record_new_objects) {
1084    case 0:        case 0:
1085      return;            return;
1086    case 1:        case 1:
1087      if (first_page > new_areas_ignore_page)            if (first_page > new_areas_ignore_page)
1088        return;                return;
1089      break;            break;
1090    case 2:        case 2:
1091      break;            break;
1092    default:        default:
1093      gc_abort();            gc_abort();
1094    }      }
1095    
1096    new_area_start = PAGE_SIZE * first_page + offset;      new_area_start = PAGE_SIZE * first_page + offset;
1097    
1098        /*
1099         * Search backwards for a prior area that this follows from.  If
1100         * found this will save adding a new area.
1101         */
1102        for (i = new_areas_index - 1, c = 0; i >= 0 && c < 8; i--, c++) {
1103            unsigned area_end = PAGE_SIZE * (*new_areas)[i].page
1104                + (*new_areas)[i].offset + (*new_areas)[i].size;
1105    
   /*  
    * Search backwards for a prior area that this follows from.  If  
    * found this will save adding a new area.  
    */  
   for (i = new_areas_index - 1, c = 0; i >= 0 && c < 8; i--, c++) {  
     unsigned area_end = PAGE_SIZE * (*new_areas)[i].page  
       + (*new_areas)[i].offset + (*new_areas)[i].size;  
1106  #if 0  #if 0
1107      fprintf(stderr, "*S1 %d %d %d %d\n", i, c, new_area_start, area_end);          fprintf(stderr, "*S1 %d %d %d %d\n", i, c, new_area_start, area_end);
1108  #endif  #endif
1109      if (new_area_start == area_end) {          if (new_area_start == area_end) {
1110  #if 0  #if 0
1111        fprintf(stderr, "-> Adding to [%d] %d %d %d with %d %d %d:\n",              fprintf(stderr, "-> Adding to [%d] %d %d %d with %d %d %d:\n",
1112                i, (*new_areas)[i].page, (*new_areas)[i].offset ,                      i, (*new_areas)[i].page, (*new_areas)[i].offset,
1113                (*new_areas)[i].size, first_page, offset, size);                      (*new_areas)[i].size, first_page, offset, size);
1114  #endif  #endif
1115        (*new_areas)[i].size += size;              (*new_areas)[i].size += size;
1116        return;              return;
1117            }
1118      }      }
   }  
1119  #if 0  #if 0
1120    fprintf(stderr, "*S1 %d %d %d\n",i,c,new_area_start);      fprintf(stderr, "*S1 %d %d %d\n", i, c, new_area_start);
1121  #endif  #endif
1122    
1123    (*new_areas)[new_areas_index].page = first_page;      (*new_areas)[new_areas_index].page = first_page;
1124    (*new_areas)[new_areas_index].offset = offset;      (*new_areas)[new_areas_index].offset = offset;
1125    (*new_areas)[new_areas_index].size = size;      (*new_areas)[new_areas_index].size = size;
1126  #if 0  #if 0
1127    fprintf(stderr, "  new_area %d page %d offset %d size %d\n",      fprintf(stderr, "  new_area %d page %d offset %d size %d\n",
1128            new_areas_index, first_page, offset, size);              new_areas_index, first_page, offset, size);
1129  #endif  #endif
1130    new_areas_index++;      new_areas_index++;
1131    
1132    /* Note the max new_areas used. */      /* Note the max new_areas used. */
1133    if (new_areas_index > max_new_areas)      if (new_areas_index > max_new_areas)
1134      max_new_areas = new_areas_index;          max_new_areas = new_areas_index;
1135  }  }
1136    
1137    
# Line 1075  static void add_new_area(int first_page, Line 1144  static void add_new_area(int first_page,
1144   * it is safe to try and re-update the page table of this reset   * it is safe to try and re-update the page table of this reset
1145   * alloc_region.   * alloc_region.
1146   */   */
1147  void gc_alloc_update_page_tables(int unboxed,  void
1148                                   struct alloc_region *alloc_region)  gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
1149  {  {
1150    int more;      int more;
1151    int first_page;      int first_page;
1152    int next_page;      int next_page;
1153    int bytes_used;      int bytes_used;
1154    int orig_first_page_bytes_used;      int orig_first_page_bytes_used;
1155    int region_size;      int region_size;
1156    int byte_cnt;      int byte_cnt;
1157    
1158  #if 0  #if 0
1159    fprintf(stderr, "gc_alloc_update_page_tables to gen %d: ",      fprintf(stderr, "gc_alloc_update_page_tables to gen %d: ",
1160            gc_alloc_generation);              gc_alloc_generation);
1161  #endif  #endif
1162    
1163    first_page = alloc_region->first_page;      first_page = alloc_region->first_page;
1164    
1165    /* Catch an unused alloc_region. */      /* Catch an unused alloc_region. */
1166    if (first_page == 0 && alloc_region->last_page == -1)      if (first_page == 0 && alloc_region->last_page == -1)
1167      return;          return;
1168    
1169    next_page = first_page + 1;      next_page = first_page + 1;
1170    
1171    /* Skip if no bytes were allocated */      /* Skip if no bytes were allocated */
1172    if (alloc_region->free_pointer != alloc_region->start_addr) {      if (alloc_region->free_pointer != alloc_region->start_addr) {
1173      orig_first_page_bytes_used = page_table[first_page].bytes_used;          orig_first_page_bytes_used = page_table[first_page].bytes_used;
1174    
1175      gc_assert(alloc_region->start_addr == page_address(first_page) +          gc_assert(alloc_region->start_addr == page_address(first_page) +
1176                page_table[first_page].bytes_used);                    page_table[first_page].bytes_used);
1177    
1178      /* All the pages used need to be updated */          /* All the pages used need to be updated */
1179    
1180      /* Update the first page. */          /* Update the first page. */
1181    
1182  #if 0  #if 0
1183      fprintf(stderr, "0");          fprintf(stderr, "0");
1184  #endif  #endif
1185    
1186      /* If the page was free then setup the gen, and first_object_offset. */          /* If the page was free then setup the gen, and first_object_offset. */
1187      if (page_table[first_page].bytes_used == 0)          if (page_table[first_page].bytes_used == 0)
1188        gc_assert(page_table[first_page].first_object_offset == 0);              gc_assert(page_table[first_page].first_object_offset == 0);
1189    
1190      gc_assert(PAGE_ALLOCATED(first_page));          gc_assert(PAGE_ALLOCATED(first_page));
1191      gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);          gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
1192      gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);          gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
1193      gc_assert(!PAGE_LARGE_OBJECT(first_page));          gc_assert(!PAGE_LARGE_OBJECT(first_page));
1194    
1195      byte_cnt = 0;          byte_cnt = 0;
1196    
1197      /*          /*
1198       * Calc. the number of bytes used in this page. This is not always           * Calc. the number of bytes used in this page. This is not always
1199       * the number of new bytes, unless it was free.           * the number of new bytes, unless it was free.
1200       */           */
1201      more = 0;          more = 0;
1202      bytes_used = alloc_region->free_pointer - page_address(first_page);          bytes_used = alloc_region->free_pointer - page_address(first_page);
1203      if (bytes_used > PAGE_SIZE) {          if (bytes_used > PAGE_SIZE) {
1204        bytes_used = PAGE_SIZE;              bytes_used = PAGE_SIZE;
1205        more = 1;              more = 1;
1206      }          }
1207      page_table[first_page].bytes_used = bytes_used;          page_table[first_page].bytes_used = bytes_used;
1208      byte_cnt += bytes_used;          byte_cnt += bytes_used;
1209    
1210      /*          /*
1211       * 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
1212       * first_object_offset pointer to the start of the region, and set           * first_object_offset pointer to the start of the region, and set
1213       * the bytes_used.           * the bytes_used.
1214       */           */
1215      while (more) {          while (more) {
1216  #if 0  #if 0
1217        fprintf(stderr, "+");              fprintf(stderr, "+");
1218  #endif  #endif
1219        gc_assert(PAGE_ALLOCATED(next_page));              gc_assert(PAGE_ALLOCATED(next_page));
1220        gc_assert(PAGE_UNBOXED_VAL(next_page) == unboxed);              gc_assert(PAGE_UNBOXED_VAL(next_page) == unboxed);
1221        gc_assert(page_table[next_page].bytes_used == 0);              gc_assert(page_table[next_page].bytes_used == 0);
1222        gc_assert(PAGE_GENERATION(next_page) == gc_alloc_generation);              gc_assert(PAGE_GENERATION(next_page) == gc_alloc_generation);
1223        gc_assert(!PAGE_LARGE_OBJECT(next_page));              gc_assert(!PAGE_LARGE_OBJECT(next_page));
1224    
1225        gc_assert(page_table[next_page].first_object_offset ==              gc_assert(page_table[next_page].first_object_offset ==
1226                  alloc_region->start_addr - page_address(next_page));                        alloc_region->start_addr - page_address(next_page));
1227    
1228        /* Calc. the number of bytes used in this page. */              /* Calc. the number of bytes used in this page. */
1229        more = 0;              more = 0;
1230        bytes_used = alloc_region->free_pointer - page_address(next_page);              bytes_used = alloc_region->free_pointer - page_address(next_page);
1231        if (bytes_used > PAGE_SIZE) {              if (bytes_used > PAGE_SIZE) {
1232          bytes_used = PAGE_SIZE;                  bytes_used = PAGE_SIZE;
1233          more = 1;                  more = 1;
1234        }              }
1235        page_table[next_page].bytes_used = bytes_used;              page_table[next_page].bytes_used = bytes_used;
1236        byte_cnt += bytes_used;              byte_cnt += bytes_used;
1237    
1238        next_page++;              next_page++;
1239      }          }
1240    
1241      region_size = alloc_region->free_pointer - alloc_region->start_addr;          region_size = alloc_region->free_pointer - alloc_region->start_addr;
1242      bytes_allocated += region_size;          bytes_allocated += region_size;
1243      generations[gc_alloc_generation].bytes_allocated += region_size;          generations[gc_alloc_generation].bytes_allocated += region_size;
1244    
1245      gc_assert(byte_cnt - orig_first_page_bytes_used == region_size);          gc_assert(byte_cnt - orig_first_page_bytes_used == region_size);
1246    
1247      /*          /*
1248       * Set the generations alloc restart page to the last page of           * Set the generations alloc restart page to the last page of
1249       * the region.           * the region.
1250       */           */
1251      if (unboxed)          if (unboxed)
1252        generations[gc_alloc_generation].alloc_unboxed_start_page = next_page-1;              generations[gc_alloc_generation].alloc_unboxed_start_page =
1253      else                  next_page - 1;
1254        generations[gc_alloc_generation].alloc_start_page = next_page - 1;          else
1255                generations[gc_alloc_generation].alloc_start_page = next_page - 1;
1256    
1257      /* Add the region to the new_areas if requested. */          /* Add the region to the new_areas if requested. */
1258      if (!unboxed)          if (!unboxed)
1259        add_new_area(first_page, orig_first_page_bytes_used, region_size);              add_new_area(first_page, orig_first_page_bytes_used, region_size);
1260    
1261  #if 0  #if 0
1262      fprintf(stderr, "  gc_alloc_update_page_tables update %d bytes to gen %d\n",          fprintf(stderr,
1263              region_size, gc_alloc_generation);                  "  gc_alloc_update_page_tables update %d bytes to gen %d\n",
1264                    region_size, gc_alloc_generation);
1265  #endif  #endif
1266    }      } else
1267    else          /*
1268      /*           * No bytes allocated. Unallocate the first_page if there are 0 bytes_used.
1269       * No bytes allocated. Unallocate the first_page if there are 0 bytes_used.           */
      */  
1270      if (page_table[first_page].bytes_used == 0)      if (page_table[first_page].bytes_used == 0)
1271        page_table[first_page].flags &= ~PAGE_ALLOCATED_MASK;          page_table[first_page].flags &= ~PAGE_ALLOCATED_MASK;
1272    
1273    /* Unallocate any unused pages. */      /* Unallocate any unused pages. */
1274    while (next_page <= alloc_region->last_page) {      while (next_page <= alloc_region->last_page) {
1275      gc_assert(page_table[next_page].bytes_used == 0);          gc_assert(page_table[next_page].bytes_used == 0);
1276      page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;          page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
1277      next_page++;          next_page++;
1278    }      }
1279    
1280    /* Reset the alloc_region. */      /* Reset the alloc_region. */
1281    alloc_region->first_page = 0;      alloc_region->first_page = 0;
1282    alloc_region->last_page = -1;      alloc_region->last_page = -1;
1283    alloc_region->start_addr = page_address(0);      alloc_region->start_addr = page_address(0);
1284    alloc_region->free_pointer = page_address(0);      alloc_region->free_pointer = page_address(0);
1285    alloc_region->end_addr = page_address(0);      alloc_region->end_addr = page_address(0);
1286    
1287  #if 0  #if 0
1288    fprintf(stderr, "\n");      fprintf(stderr, "\n");
1289  #endif  #endif
1290  }  }
1291    
# Line 1226  static inline void *gc_quick_alloc(int n Line 1296  static inline void *gc_quick_alloc(int n
1296  /*  /*
1297   * Allocate a possibly large object.   * Allocate a possibly large object.
1298   */   */
1299  static void *gc_alloc_large(int  nbytes, int unboxed,  static void *
1300                              struct alloc_region *alloc_region)  gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
1301  {  {
1302    int first_page;      int first_page;
1303    int last_page;      int last_page;
1304    int region_size;      int region_size;
1305    int restart_page;      int restart_page;
1306    int bytes_found;      int bytes_found;
1307    int num_pages;      int num_pages;
1308    int orig_first_page_bytes_used;      int orig_first_page_bytes_used;
1309    int byte_cnt;      int byte_cnt;
1310    int more;      int more;
1311    int bytes_used;      int bytes_used;
1312    int next_page;      int next_page;
1313    int large = (nbytes >= large_object_size);      int large = (nbytes >= large_object_size);
1314    int mmask, mflags;      int mmask, mflags;
   
   
   /* Shut up some compiler warnings */  
   last_page = bytes_found = 0;  
   
 #if 0  
   if (nbytes > 200000)  
     fprintf(stderr, "*** alloc_large %d\n", nbytes);  
 #endif  
   
 #if 0  
   fprintf(stderr, "gc_alloc_large for %d bytes from gen %d\n",  
           nbytes, gc_alloc_generation);  
 #endif  
   
   /*  
    * If the object is small, and there is room in the current region  
    * then allocation it in the current region.  
    */  
   if (!large && alloc_region->end_addr - alloc_region->free_pointer >= nbytes)  
     return gc_quick_alloc(nbytes);  
   
   /*  
    * Search for a contiguous free region of at least nbytes. If it's a  
    * large object then align it on a page boundary by searching for a  
    * free page.  
    */  
   
   /*  
    * To allow the allocation of small objects without the danger of  
    * using a page in the current boxed region, the search starts after  
    * the current boxed free region. XX could probably keep a page  
    * index ahead of the current region and bumped up here to save a  
    * lot of re-scanning.  
    */  
   if (unboxed)  
     restart_page = generations[gc_alloc_generation].alloc_large_unboxed_start_page;  
   else  
     restart_page = generations[gc_alloc_generation].alloc_large_start_page;  
   if (restart_page <= alloc_region->last_page)  
     restart_page = alloc_region->last_page + 1;  
   
   /* Setup the mask and matching flags. */  
   
   mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK  
     | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK  
     | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;  
   mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)  
     | gc_alloc_generation;  
1315    
   do {  
     first_page = restart_page;  
1316    
1317      if (large)      /* Shut up some compiler warnings */
1318        while (first_page < dynamic_space_pages && PAGE_ALLOCATED(first_page))      last_page = bytes_found = 0;
         first_page++;  
     else  
       while (first_page < dynamic_space_pages) {  
         int flags = page_table[first_page].flags;  
         if (!(flags & PAGE_ALLOCATED_MASK)  
             || ((flags & mmask) == mflags &&  
                 page_table[first_page].bytes_used < PAGE_SIZE - 32))  
           break;  
         first_page++;  
       }  
1319    
     /* Check for a failure */  
     if (first_page >= dynamic_space_pages - reserved_heap_pages) {  
1320  #if 0  #if 0
1321        handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes);      if (nbytes > 200000)
1322  #else          fprintf(stderr, "*** alloc_large %d\n", nbytes);
       break;  
1323  #endif  #endif
     }  
     gc_assert(!PAGE_WRITE_PROTECTED(first_page));  
1324    
1325  #if 0  #if 0
1326      fprintf(stderr, "  first_page=%d bytes_used=%d\n",      fprintf(stderr, "gc_alloc_large for %d bytes from gen %d\n",
1327              first_page, page_table[first_page].bytes_used);              nbytes, gc_alloc_generation);
1328  #endif  #endif
1329    
1330      last_page = first_page;      /*
1331      bytes_found = PAGE_SIZE - page_table[first_page].bytes_used;       * If the object is small, and there is room in the current region
1332      num_pages = 1;       * then allocation it in the current region.
1333      while (bytes_found < nbytes       */
1334             && last_page < dynamic_space_pages - 1      if (!large && alloc_region->end_addr - alloc_region->free_pointer >= nbytes)
1335             && !PAGE_ALLOCATED(last_page + 1)) {          return gc_quick_alloc(nbytes);
       last_page++;  
       num_pages++;  
       bytes_found += PAGE_SIZE;  
       gc_assert(!PAGE_WRITE_PROTECTED(last_page));  
     }  
1336    
1337      region_size = (PAGE_SIZE - page_table[first_page].bytes_used)      /*
1338        + PAGE_SIZE * (last_page - first_page);       * Search for a contiguous free region of at least nbytes. If it's a
1339         * large object then align it on a page boundary by searching for a
1340         * free page.
1341         */
1342    
1343      gc_assert(bytes_found == region_size);      /*
1344         * To allow the allocation of small objects without the danger of
1345         * using a page in the current boxed region, the search starts after
1346         * the current boxed free region. XX could probably keep a page
1347         * index ahead of the current region and bumped up here to save a
1348         * lot of re-scanning.
1349         */
1350        if (unboxed)
1351            restart_page =
1352                generations[gc_alloc_generation].alloc_large_unboxed_start_page;
1353        else
1354            restart_page = generations[gc_alloc_generation].alloc_large_start_page;
1355        if (restart_page <= alloc_region->last_page)
1356            restart_page = alloc_region->last_page + 1;
1357    
1358        /* Setup the mask and matching flags. */
1359    
1360        mmask = PAGE_ALLOCATED_MASK | PAGE_WRITE_PROTECTED_MASK
1361            | PAGE_LARGE_OBJECT_MASK | PAGE_DONT_MOVE_MASK
1362            | PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK;
1363        mflags = PAGE_ALLOCATED_MASK | (unboxed << PAGE_UNBOXED_SHIFT)
1364            | gc_alloc_generation;
1365    
1366  #if 0      do {
1367      fprintf(stderr, "  last_page=%d bytes_found=%d num_pages=%d\n",          first_page = restart_page;
             last_page, bytes_found, num_pages);  
 #endif  
1368    
1369      restart_page = last_page + 1;          if (large)
1370    }              while (first_page < dynamic_space_pages
1371    while ((restart_page < dynamic_space_pages) && (bytes_found < nbytes));                     && PAGE_ALLOCATED(first_page)) first_page++;
1372            else
1373                while (first_page < dynamic_space_pages) {
1374                    int flags = page_table[first_page].flags;
1375    
1376    if (first_page >= dynamic_space_pages - reserved_heap_pages) {                  if (!(flags & PAGE_ALLOCATED_MASK)
1377      handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes);                      || ((flags & mmask) == mflags &&
1378    }                          page_table[first_page].bytes_used < PAGE_SIZE - 32))
1379                        break;
1380    /* Check for a failure */                  first_page++;
1381    if (restart_page >= (dynamic_space_pages - reserved_heap_pages) && bytes_found < nbytes) {              }
     handle_heap_overflow("*A1 gc_alloc_large failed, nbytes=%d.\n", nbytes);  
   }  
1382    
1383  #if 0          /* Check for a failure */
1384    if (large)          if (first_page >= dynamic_space_pages - reserved_heap_pages) {
1385      fprintf(stderr, "gc_alloc_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",  #if 0
1386              gc_alloc_generation, nbytes, bytes_found,              handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n",
1387              first_page, last_page, page_address(first_page));                                   nbytes);
1388    #else
1389                break;
1390  #endif  #endif
1391            }
1392            gc_assert(!PAGE_WRITE_PROTECTED(first_page));
1393    
1394    gc_assert(first_page > alloc_region->last_page);  #if 0
1395    if (unboxed)          fprintf(stderr, "  first_page=%d bytes_used=%d\n",
1396      generations[gc_alloc_generation].alloc_large_unboxed_start_page =                  first_page, page_table[first_page].bytes_used);
1397        last_page;  #endif
   else  
     generations[gc_alloc_generation].alloc_large_start_page = last_page;  
   
   /* Setup the pages. */  
   orig_first_page_bytes_used = page_table[first_page].bytes_used;  
1398    
1399    /*          last_page = first_page;
1400     * If the first page was free then setup the gen, and          bytes_found = PAGE_SIZE - page_table[first_page].bytes_used;
1401     * first_object_offset.          num_pages = 1;
1402     */          while (bytes_found < nbytes
1403                   && last_page < dynamic_space_pages - 1
1404                   && !PAGE_ALLOCATED(last_page + 1)) {
1405                last_page++;
1406                num_pages++;
1407                bytes_found += PAGE_SIZE;
1408                gc_assert(!PAGE_WRITE_PROTECTED(last_page));
1409            }
1410    
1411    if (large)          region_size = (PAGE_SIZE - page_table[first_page].bytes_used)
1412      mflags |= PAGE_LARGE_OBJECT_MASK;              + PAGE_SIZE * (last_page - first_page);
   if (page_table[first_page].bytes_used == 0) {  
     PAGE_FLAGS_UPDATE(first_page, mmask, mflags);  
     page_table[first_page].first_object_offset = 0;  
   }  
1413    
1414    gc_assert(PAGE_ALLOCATED(first_page));          gc_assert(bytes_found == region_size);
   gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);  
   gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);  
   gc_assert(PAGE_LARGE_OBJECT_VAL(first_page) == large);  
1415    
1416    byte_cnt = 0;  #if 0
1417            fprintf(stderr, "  last_page=%d bytes_found=%d num_pages=%d\n",
1418                    last_page, bytes_found, num_pages);
1419    #endif
1420    
1421    /*          restart_page = last_page + 1;
1422     * Calc. the number of bytes used in this page. This is not      }
1423     * always the number of new bytes, unless it was free.      while ((restart_page < dynamic_space_pages) && (bytes_found < nbytes));
    */  
   more = 0;  
   bytes_used = nbytes + orig_first_page_bytes_used;  
   if (bytes_used > PAGE_SIZE) {  
     bytes_used = PAGE_SIZE;  
     more = 1;  
   }  
   page_table[first_page].bytes_used = bytes_used;  
   byte_cnt += bytes_used;  
1424    
1425    next_page = first_page + 1;      if (first_page >= dynamic_space_pages - reserved_heap_pages) {
1426            handle_heap_overflow("*A2 gc_alloc_large failed, nbytes=%d.\n", nbytes);
1427        }
1428    
1429    /*      /* Check for a failure */
1430     * All the rest of the pages should be free. Need to set their      if (restart_page >= (dynamic_space_pages - reserved_heap_pages)
1431     * first_object_offset pointer to the start of the region, and set          && bytes_found < nbytes) {
1432     * the bytes_used.          handle_heap_overflow("*A1 gc_alloc_large failed, nbytes=%d.\n", nbytes);
1433     */      }
   while (more) {  
1434  #if 0  #if 0
1435      fprintf(stderr, "+");      if (large)
1436            fprintf(stderr,
1437                    "gc_alloc_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
1438                    gc_alloc_generation, nbytes, bytes_found, first_page, last_page,
1439                    page_address(first_page));
1440  #endif  #endif
1441    
1442      gc_assert(!PAGE_ALLOCATED(next_page));      gc_assert(first_page > alloc_region->last_page);
1443      gc_assert(page_table[next_page].bytes_used == 0);      if (unboxed)
1444      PAGE_FLAGS_UPDATE(next_page, mmask, mflags);          generations[gc_alloc_generation].alloc_large_unboxed_start_page =
1445                last_page;
1446        else
1447            generations[gc_alloc_generation].alloc_large_start_page = last_page;
1448    
1449        /* Setup the pages. */
1450        orig_first_page_bytes_used = page_table[first_page].bytes_used;
1451    
1452        /*
1453         * If the first page was free then setup the gen, and
1454         * first_object_offset.
1455         */
1456    
1457        if (large)
1458            mflags |= PAGE_LARGE_OBJECT_MASK;
1459        if (page_table[first_page].bytes_used == 0) {
1460            PAGE_FLAGS_UPDATE(first_page, mmask, mflags);
1461            page_table[first_page].first_object_offset = 0;
1462        }
1463    
1464      page_table[next_page].first_object_offset =      gc_assert(PAGE_ALLOCATED(first_page));
1465        orig_first_page_bytes_used - PAGE_SIZE * (next_page - first_page);      gc_assert(PAGE_UNBOXED_VAL(first_page) == unboxed);
1466        gc_assert(PAGE_GENERATION(first_page) == gc_alloc_generation);
1467        gc_assert(PAGE_LARGE_OBJECT_VAL(first_page) == large);
1468    
1469        byte_cnt = 0;
1470    
1471      /* Calc. the number of bytes used in this page. */      /*
1472         * Calc. the number of bytes used in this page. This is not
1473         * always the number of new bytes, unless it was free.
1474         */
1475      more = 0;      more = 0;
1476      bytes_used = nbytes + orig_first_page_bytes_used - byte_cnt;      bytes_used = nbytes + orig_first_page_bytes_used;
1477      if (bytes_used > PAGE_SIZE) {      if (bytes_used > PAGE_SIZE) {
1478        bytes_used = PAGE_SIZE;          bytes_used = PAGE_SIZE;
1479        more = 1;          more = 1;
1480      }      }
1481      page_table[next_page].bytes_used = bytes_used;      page_table[first_page].bytes_used = bytes_used;
1482      byte_cnt += bytes_used;      byte_cnt += bytes_used;
1483    
1484      next_page++;      next_page = first_page + 1;
1485    }  
1486        /*
1487         * All the rest of the pages should be free. Need to set their
1488         * first_object_offset pointer to the start of the region, and set
1489         * the bytes_used.
1490         */
1491        while (more) {
1492    #if 0
1493            fprintf(stderr, "+");
1494    #endif
1495    
1496    gc_assert(byte_cnt - orig_first_page_bytes_used == nbytes);          gc_assert(!PAGE_ALLOCATED(next_page));
1497            gc_assert(page_table[next_page].bytes_used == 0);
1498            PAGE_FLAGS_UPDATE(next_page, mmask, mflags);
1499    
1500            page_table[next_page].first_object_offset =
1501                orig_first_page_bytes_used - PAGE_SIZE * (next_page - first_page);
1502    
1503            /* Calc. the number of bytes used in this page. */
1504            more = 0;
1505            bytes_used = nbytes + orig_first_page_bytes_used - byte_cnt;
1506            if (bytes_used > PAGE_SIZE) {
1507                bytes_used = PAGE_SIZE;
1508                more = 1;
1509            }
1510            page_table[next_page].bytes_used = bytes_used;
1511            byte_cnt += bytes_used;
1512    
1513    bytes_allocated += nbytes;          next_page++;
1514    generations[gc_alloc_generation].bytes_allocated += nbytes;      }
1515    
1516    /* Add the region to the new_areas if requested. */      gc_assert(byte_cnt - orig_first_page_bytes_used == nbytes);
   if (!unboxed)  
     add_new_area(first_page, orig_first_page_bytes_used, nbytes);  
1517    
1518    /* Bump up the last_free_page */      bytes_allocated += nbytes;
1519    if (last_page + 1 > last_free_page) {      generations[gc_alloc_generation].bytes_allocated += nbytes;
1520      last_free_page = last_page + 1;  
1521      set_alloc_pointer((lispobj) ((char *) heap_base +      /* Add the region to the new_areas if requested. */
1522                                 PAGE_SIZE * last_free_page));      if (!unboxed)
1523    }          add_new_area(first_page, orig_first_page_bytes_used, nbytes);
1524    
1525    return (void *) (page_address(first_page) + orig_first_page_bytes_used);      /* Bump up the last_free_page */
1526        if (last_page + 1 > last_free_page) {
1527            last_free_page = last_page + 1;
1528            set_alloc_pointer((lispobj) ((char *) heap_base +
1529                                         PAGE_SIZE * last_free_page));
1530        }
1531    
1532        return (void *) (page_address(first_page) + orig_first_page_bytes_used);
1533  }  }
1534    
1535  /*  /*
# Line 1463  static void *gc_alloc_large(int  nbytes, Line 1537  static void *gc_alloc_large(int  nbytes,
1537   * room, if not then it calls gc_alloc_new_region to find a new region   * room, if not then it calls gc_alloc_new_region to find a new region
1538   * with enough space. A pointer to the start of the region is returned.   * with enough space. A pointer to the start of the region is returned.
1539   */   */
1540  static void *gc_alloc(int nbytes)  static void *
1541    gc_alloc(int nbytes)
1542  {  {
1543    char *new_free_pointer;      char *new_free_pointer;
1544    
1545  #if 0  #if 0
1546    fprintf(stderr, "gc_alloc %d\n",nbytes);      fprintf(stderr, "gc_alloc %d\n", nbytes);
1547  #endif  #endif
1548    
1549    /* Check if there is room in the current alloc region. */      /* Check if there is room in the current alloc region. */
1550    new_free_pointer = boxed_region.free_pointer + nbytes;      new_free_pointer = boxed_region.free_pointer + nbytes;
1551    
1552    if (new_free_pointer <= boxed_region.end_addr) {      if (new_free_pointer <= boxed_region.end_addr) {
1553      /* If so then allocate from the current alloc region. */          /* If so then allocate from the current alloc region. */
1554      char *new_obj = boxed_region.free_pointer;          char *new_obj = boxed_region.free_pointer;
     boxed_region.free_pointer = new_free_pointer;  
1555    
1556      /* Check if the alloc region is almost empty. */          boxed_region.free_pointer = new_free_pointer;
1557      if (boxed_region.end_addr - boxed_region.free_pointer <= 32) {  
1558        /* If so finished with the current region. */          /* Check if the alloc region is almost empty. */
1559        gc_alloc_update_page_tables(0, &boxed_region);          if (boxed_region.end_addr - boxed_region.free_pointer <= 32) {
1560        /* Setup a new region. */              /* If so finished with the current region. */
1561        gc_alloc_new_region(32, 0, &boxed_region);              gc_alloc_update_page_tables(0, &boxed_region);
1562                /* Setup a new region. */
1563                gc_alloc_new_region(32, 0, &boxed_region);
1564            }
1565            return (void *) new_obj;
1566      }      }
     return (void *) new_obj;  
   }  
1567    
1568    /* Else not enough free space in the current region. */      /* Else not enough free space in the current region. */
1569    
1570        /*
1571         * If there is a bit of room left in the current region then
1572         * allocate a large object.
1573         */
1574        if (boxed_region.end_addr - boxed_region.free_pointer > 32)
1575            return gc_alloc_large(nbytes, 0, &boxed_region);
1576    
1577        /* Else find a new region. */
1578    
1579    /*      /* Finished with the current region. */
1580     * If there is a bit of room left in the current region then      gc_alloc_update_page_tables(0, &boxed_region);
    * allocate a large object.  
    */  
   if (boxed_region.end_addr - boxed_region.free_pointer > 32)  
     return gc_alloc_large(nbytes, 0, &boxed_region);  
1581    
1582    /* Else find a new region. */      /* Setup a new region. */
1583        gc_alloc_new_region(nbytes, 0, &boxed_region);
1584    
1585    /* Finished with the current region. */      /* Should now be enough room. */
   gc_alloc_update_page_tables(0, &boxed_region);  
1586    
1587    /* Setup a new region. */      /* Check if there is room in the current region. */
1588    gc_alloc_new_region(nbytes, 0, &boxed_region);      new_free_pointer = boxed_region.free_pointer + nbytes;
1589    
1590    /* Should now be enough room. */      if (new_free_pointer <= boxed_region.end_addr) {
1591            /* If so then allocate from the current region. */
1592            void *new_obj = boxed_region.free_pointer;
1593    
1594    /* Check if there is room in the current region. */          boxed_region.free_pointer = new_free_pointer;
   new_free_pointer = boxed_region.free_pointer + nbytes;  
1595    
1596    if (new_free_pointer <= boxed_region.end_addr) {          /* Check if the current region is almost empty. */
1597      /* If so then allocate from the current region. */          if (boxed_region.end_addr - boxed_region.free_pointer <= 32) {
1598      void *new_obj = boxed_region.free_pointer;              /* If so find, finished with the current region. */
1599      boxed_region.free_pointer = new_free_pointer;              gc_alloc_update_page_tables(0, &boxed_region);
1600    
1601      /* Check if the current region is almost empty. */              /* Setup a new region. */
1602      if (boxed_region.end_addr - boxed_region.free_pointer <= 32) {              gc_alloc_new_region(32, 0, &boxed_region);
1603        /* If so find, finished with the current region. */          }
       gc_alloc_update_page_tables(0, &boxed_region);  
1604    
1605        /* Setup a new region. */          return (void *) new_obj;
       gc_alloc_new_region(32, 0, &boxed_region);  
1606      }      }
1607    
1608      return (void *) new_obj;      /* Shouldn't happen? */
1609    }      gc_assert(0);
1610        return 0;
   /* Shouldn't happen? */  
   gc_assert(0);  
   return 0;  
1611  }  }
1612    
1613  /*  /*
# Line 1538  static void *gc_alloc(int nbytes) Line 1615  static void *gc_alloc(int nbytes)
1615   * space then call gc_alloc to do the job. A pointer to the start of   * space then call gc_alloc to do the job. A pointer to the start of
1616   * the region is returned.   * the region is returned.
1617   */   */
1618  static inline void *gc_quick_alloc(int nbytes)  static inline void *
1619    gc_quick_alloc(int nbytes)
1620  {  {
1621    char *new_free_pointer;      char *new_free_pointer;
1622    
1623        /* Check if there is room in the current region. */
1624        new_free_pointer = boxed_region.free_pointer + nbytes;
1625    
1626    /* Check if there is room in the current region. */      if (new_free_pointer <= boxed_region.end_addr) {
1627    new_free_pointer = boxed_region.free_pointer + nbytes;          /* If so then allocate from the current region. */
1628            void *new_obj = boxed_region.free_pointer;
1629    
1630    if (new_free_pointer <= boxed_region.end_addr) {          boxed_region.free_pointer = new_free_pointer;
1631      /* If so then allocate from the current region. */          return (void *) new_obj;
1632      void  *new_obj = boxed_region.free_pointer;      }
     boxed_region.free_pointer = new_free_pointer;  
     return (void *) new_obj;  
   }  
1633    
1634    /* Else call gc_alloc */      /* Else call gc_alloc */
1635    return gc_alloc(nbytes);      return gc_alloc(nbytes);
1636  }  }
1637    
1638  /*  /*
# Line 1562  static inline void *gc_quick_alloc(int n Line 1641  static inline void *gc_quick_alloc(int n
1641   * not enough free space then call gc_alloc to do the job. A pointer   * not enough free space then call gc_alloc to do the job. A pointer
1642   * to the start of the region is returned.   * to the start of the region is returned.
1643   */   */
1644  static inline void *gc_quick_alloc_large(int nbytes)  static inline void *
1645    gc_quick_alloc_large(int nbytes)
1646  {  {
1647    char *new_free_pointer;      char *new_free_pointer;
1648    
1649    if (nbytes >= large_object_size)      if (nbytes >= large_object_size)
1650      return gc_alloc_large(nbytes,0,&boxed_region);          return gc_alloc_large(nbytes, 0, &boxed_region);
1651    
1652    /* Check if there is room in the current region. */      /* Check if there is room in the current region. */
1653    new_free_pointer = boxed_region.free_pointer + nbytes;      new_free_pointer = boxed_region.free_pointer + nbytes;
1654    
1655    if (new_free_pointer <= boxed_region.end_addr) {      if (new_free_pointer <= boxed_region.end_addr) {
1656      /* If so then allocate from the current region. */          /* If so then allocate from the current region. */
1657      void *new_obj = boxed_region.free_pointer;          void *new_obj = boxed_region.free_pointer;
     boxed_region.free_pointer = new_free_pointer;  
     return (void *) new_obj;  
   }  
1658    
1659    /* Else call gc_alloc */          boxed_region.free_pointer = new_free_pointer;
1660    return gc_alloc(nbytes);          return (void *) new_obj;
1661        }
1662    
1663        /* Else call gc_alloc */
1664        return gc_alloc(nbytes);
1665  }  }
1666    
1667    
1668    
1669    
1670  static void *gc_alloc_unboxed(int nbytes)  static void *
1671    gc_alloc_unboxed(int nbytes)
1672  {  {
1673    char *new_free_pointer;      char *new_free_pointer;
1674    
1675  #if 0  #if 0
1676    fprintf(stderr, "gc_alloc_unboxed %d\n",nbytes);      fprintf(stderr, "gc_alloc_unboxed %d\n", nbytes);
1677  #endif  #endif
1678    
1679    /* Check if there is room in the current region. */      /* Check if there is room in the current region. */
1680    new_free_pointer = unboxed_region.free_pointer + nbytes;      new_free_pointer = unboxed_region.free_pointer + nbytes;
1681    
1682    if (new_free_pointer <= unboxed_region.end_addr) {      if (new_free_pointer <= unboxed_region.end_addr) {
1683      /* If so then allocate from the current region. */          /* If so then allocate from the current region. */
1684      void *new_obj = unboxed_region.free_pointer;          void *new_obj = unboxed_region.free_pointer;
     unboxed_region.free_pointer = new_free_pointer;  
1685    
1686      /* Check if the current region is almost empty. */          unboxed_region.free_pointer = new_free_pointer;
     if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {  
       /* If so finished with the current region. */  
       gc_alloc_update_page_tables(1, &unboxed_region);  
1687    
1688        /* Setup a new region. */          /* Check if the current region is almost empty. */
1689        gc_alloc_new_region(32, 1, &unboxed_region);          if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {
1690                /* If so finished with the current region. */
1691                gc_alloc_update_page_tables(1, &unboxed_region);
1692    
1693                /* Setup a new region. */
1694                gc_alloc_new_region(32, 1, &unboxed_region);
1695            }
1696    
1697            return (void *) new_obj;
1698      }      }
1699    
1700      return (void *) new_obj;      /* Else not enough free space in the current region. */
1701    }  
1702        /*
1703         * If there is a bit of room left in the current region then
1704         * allocate a large object.
1705         */
1706        if (unboxed_region.end_addr - unboxed_region.free_pointer > 32)
1707            return gc_alloc_large(nbytes, 1, &unboxed_region);
1708    
1709    /* Else not enough free space in the current region. */      /* Else find a new region. */
1710    
1711    /*      /* Finished with the current region. */
1712     * If there is a bit of room left in the current region then      gc_alloc_update_page_tables(1, &unboxed_region);
    * allocate a large object.  
    */  
   if (unboxed_region.end_addr - unboxed_region.free_pointer > 32)  
     return gc_alloc_large(nbytes, 1, &unboxed_region);  
1713    
1714    /* Else find a new region. */      /* Setup a new region. */
1715        gc_alloc_new_region(nbytes, 1, &unboxed_region);
1716    
1717    /* Finished with the current region. */      /* Should now be enough room. */
   gc_alloc_update_page_tables(1,&unboxed_region);  
1718    
1719    /* Setup a new region. */      /* Check if there is room in the current region. */
1720    gc_alloc_new_region(nbytes,1,&unboxed_region);      new_free_pointer = unboxed_region.free_pointer + nbytes;
1721    
1722    /* Should now be enough room. */      if (new_free_pointer <= unboxed_region.end_addr) {
1723            /* If so then allocate from the current region. */
1724            void *new_obj = unboxed_region.free_pointer;
1725    
1726    /* Check if there is room in the current region. */          unboxed_region.free_pointer = new_free_pointer;
   new_free_pointer = unboxed_region.free_pointer + nbytes;  
1727    
1728    if (new_free_pointer <= unboxed_region.end_addr) {          /* Check if the current region is almost empty. */
1729      /* If so then allocate from the current region. */          if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {
1730      void *new_obj = unboxed_region.free_pointer;              /* If so find, finished with the current region. */
1731      unboxed_region.free_pointer = new_free_pointer;              gc_alloc_update_page_tables(1, &unboxed_region);
1732    
1733      /* Check if the current region is almost empty. */              /* Setup a new region. */
1734      if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {              gc_alloc_new_region(32, 1, &unboxed_region);
1735        /* If so find, finished with the current region. */          }
       gc_alloc_update_page_tables(1, &unboxed_region);  
1736    
1737        /* Setup a new region. */          return (void *) new_obj;
       gc_alloc_new_region(32, 1, &unboxed_region);  
1738      }      }
1739    
1740      return (void *) new_obj;      /* Shouldn't happen? */
1741    }      gc_assert(0);
1742        return 0;
   /* Shouldn't happen? */  
   gc_assert(0);  
   return 0;  
1743  }  }
1744    
1745  static inline void *gc_quick_alloc_unboxed(int nbytes)  static inline void *
1746    gc_quick_alloc_unboxed(int nbytes)
1747  {  {
1748    char *new_free_pointer;      char *new_free_pointer;
1749    
1750        /* Check if there is room in the current region. */
1751        new_free_pointer = unboxed_region.free_pointer + nbytes;
1752    
1753    /* Check if there is room in the current region. */      if (new_free_pointer <= unboxed_region.end_addr) {
1754    new_free_pointer = unboxed_region.free_pointer + nbytes;          /* If so then allocate from the current region. */
1755            void *new_obj = unboxed_region.free_pointer;
1756    
1757    if (new_free_pointer <= unboxed_region.end_addr) {          unboxed_region.free_pointer = new_free_pointer;
     /* If so then allocate from the current region. */  
     void *new_obj = unboxed_region.free_pointer;  
     unboxed_region.free_pointer = new_free_pointer;  
1758    
1759      return (void *) new_obj;          return (void *) new_obj;
1760      }      }
1761    
1762    /* Else call gc_alloc */      /* Else call gc_alloc */
1763    return gc_alloc_unboxed(nbytes);      return gc_alloc_unboxed(nbytes);
1764  }  }
1765    
1766  /*  /*
# Line 1684  static inline void *gc_quick_alloc_unbox Line 1770  static inline void *gc_quick_alloc_unbox
1770   *   *
1771   * A pointer to the start of the region is returned.   * A pointer to the start of the region is returned.
1772   */   */
1773  static inline void *gc_quick_alloc_large_unboxed(int nbytes)  static inline void *
1774    gc_quick_alloc_large_unboxed(int nbytes)
1775  {  {
1776    char *new_free_pointer;      char *new_free_pointer;
1777    
1778    if (nbytes >= large_object_size)      if (nbytes >= large_object_size)
1779      return gc_alloc_large(nbytes,1,&unboxed_region);          return gc_alloc_large(nbytes, 1, &unboxed_region);
1780    
1781    /* Check if there is room in the current region. */      /* Check if there is room in the current region. */
1782    new_free_pointer = unboxed_region.free_pointer + nbytes;      new_free_pointer = unboxed_region.free_pointer + nbytes;
1783    
1784    if (new_free_pointer <= unboxed_region.end_addr) {      if (new_free_pointer <= unboxed_region.end_addr) {
1785      /* If so then allocate from the current region. */          /* If so then allocate from the current region. */
1786      void *new_obj = unboxed_region.free_pointer;          void *new_obj = unboxed_region.free_pointer;
     unboxed_region.free_pointer = new_free_pointer;  
1787    
1788      return (void *) new_obj;          unboxed_region.free_pointer = new_free_pointer;
   }  
1789    
1790    /* Else call gc_alloc */          return (void *) new_obj;
1791    return gc_alloc_unboxed(nbytes);      }
1792    
1793        /* Else call gc_alloc */
1794        return gc_alloc_unboxed(nbytes);
1795  }  }
1796    
1797  /***************************************************************************/  /***************************************************************************/
   
1798    
1799    
1800  /* Scavenging/transporting routines derived from gc.c */  /* Scavenging/transporting routines derived from gc.c */
1801    
1802  static int (*scavtab[256])(lispobj *where, lispobj object);  static int (*scavtab[256]) (lispobj * where, lispobj object);
1803  static lispobj (*transother[256])(lispobj object);  static lispobj(*transother[256]) (lispobj object);
1804  static int (*sizetab[256])(lispobj *where);  static int (*sizetab[256]) (lispobj * where);
1805    
1806  static struct weak_pointer *weak_pointers;  static struct weak_pointer *weak_pointers;
1807  static struct scavenger_hook *scavenger_hooks = (struct scavenger_hook *) NIL;  static struct scavenger_hook *scavenger_hooks = (struct scavenger_hook *) NIL;
1808    
1809  #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))  #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
   
1810    
1811    
1812  /* Predicates */  /* Predicates */
1813    
1814  static inline boolean from_space_p(lispobj obj)  static inline boolean
1815    from_space_p(lispobj obj)
1816  {  {
1817    int page_index = (char*) obj - heap_base;      int page_index = (char *) obj - heap_base;
1818    return page_index >= 0  
1819      && (page_index = (unsigned int) page_index / PAGE_SIZE) < dynamic_space_pages      return page_index >= 0
1820      && PAGE_GENERATION(page_index) == from_space;          && (page_index =
1821                (unsigned int) page_index / PAGE_SIZE) < dynamic_space_pages
1822            && PAGE_GENERATION(page_index) == from_space;
1823  }  }
1824    
1825  static inline boolean new_space_p(lispobj obj)  static inline boolean
1826    new_space_p(lispobj obj)
1827  {  {
1828    int page_index = (char*) obj - heap_base;      int page_index = (char *) obj - heap_base;
   return page_index >= 0  
     && (page_index = (unsigned int) page_index / PAGE_SIZE) < dynamic_space_pages  
     && PAGE_GENERATION(page_index) == new_space;  
 }  
1829    
1830        return page_index >= 0
1831            && (page_index =
1832                (unsigned int) page_index / PAGE_SIZE) < dynamic_space_pages
1833            && PAGE_GENERATION(page_index) == new_space;
1834    }
1835    
1836    
1837  /* Copying Objects */  /* Copying Objects */
1838    
1839    
1840  /* Copying Boxed Objects */  /* Copying Boxed Objects */
1841  static inline lispobj copy_object(lispobj object, int nwords)  static inline lispobj
1842    copy_object(lispobj object, int nwords)
1843  {  {
1844    int tag;      int tag;
1845    lispobj *new;      lispobj *new;
1846    lispobj *source, *dest;      lispobj *source, *dest;
1847    
1848    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
1849    gc_assert(from_space_p(object));      gc_assert(from_space_p(object));
1850    gc_assert((nwords & 0x01) == 0);      gc_assert((nwords & 0x01) == 0);
1851    
1852    /* get tag of object */      /* get tag of object */
1853    tag = LowtagOf(object);      tag = LowtagOf(object);
1854    
1855    /* allocate space */      /* allocate space */
1856    new = gc_quick_alloc(nwords*sizeof(lispobj));      new = gc_quick_alloc(nwords * sizeof(lispobj));
   
   dest = new;  
   source = (lispobj *) PTR(object);  
   
   /* copy the object */  
   while (nwords > 0) {  
     dest[0] = source[0];  
     dest[1] = source[1];  
     dest += 2;  
     source += 2;  
     nwords -= 2;  
   }  
1857    
1858    /* return lisp pointer of new object */      dest = new;
1859    return (lispobj) new | tag;      source = (lispobj *) PTR(object);
1860    
1861        /* copy the object */
1862        while (nwords > 0) {
1863            dest[0] = source[0];
1864            dest[1] = source[1];
1865            dest += 2;
1866            source += 2;
1867            nwords -= 2;
1868        }
1869    
1870        /* return lisp pointer of new object */
1871        return (lispobj) new | tag;
1872  }  }
1873    
1874  /*  /*
# Line 1784  static inline lispobj copy_object(lispob Line 1879  static inline lispobj copy_object(lispob
1879   * Vectors may have shrunk. If the object is not copied the space   * Vectors may have shrunk. If the object is not copied the space
1880   * needs to be reclaimed, and the page_tables corrected.   * needs to be reclaimed, and the page_tables corrected.
1881   */   */
1882  static lispobj copy_large_object(lispobj object, int nwords)  static lispobj
1883    copy_large_object(lispobj object, int nwords)
1884  {  {
1885    int tag;      int tag;
1886    lispobj *new;      lispobj *new;
1887    lispobj *source, *dest;      lispobj *source, *dest;
1888    int first_page;      int first_page;
1889    
1890    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
1891    gc_assert(from_space_p(object));      gc_assert(from_space_p(object));
1892    gc_assert((nwords & 0x01) == 0);      gc_assert((nwords & 0x01) == 0);
1893    
1894    if (gencgc_verbose && nwords > 1024 * 1024)      if (gencgc_verbose && nwords > 1024 * 1024)
1895      fprintf(stderr, "** copy_large_object: %d\n", nwords * sizeof(lispobj));          fprintf(stderr, "** copy_large_object: %d\n", nwords * sizeof(lispobj));
1896    
1897    /* Check if it's a large object. */      /* Check if it's a large object. */
1898    first_page = find_page_index((void *) object);      first_page = find_page_index((void *) object);
1899    gc_assert(first_page >= 0);      gc_assert(first_page >= 0);
1900    
1901        if (PAGE_LARGE_OBJECT(first_page)) {
1902            /* Promote the object. */
1903            int remaining_bytes;
1904            int next_page;
1905            int bytes_freed;
1906            int old_bytes_used;
1907            int mmask, mflags;
1908    
1909    if (PAGE_LARGE_OBJECT(first_page)) {          /*
1910      /* Promote the object. */           * Note: Any page write protection must be removed, else a later
1911      int remaining_bytes;           * scavenge_newspace may incorrectly not scavenge these pages.
1912      int next_page;           * This would not be necessary if they are added to the new areas,
1913      int bytes_freed;           * but lets do it for them all (they'll probably be written
1914      int old_bytes_used;           * anyway?).
1915      int mmask, mflags;           */
1916    
1917      /*          gc_assert(page_table[first_page].first_object_offset == 0);
      * Note: Any page write protection must be removed, else a later  
      * scavenge_newspace may incorrectly not scavenge these pages.  
      * This would not be necessary if they are added to the new areas,  
      * but lets do it for them all (they'll probably be written  
      * anyway?).  
      */  
1918    
1919      gc_assert(page_table[first_page].first_object_offset == 0);          next_page = first_page;
1920            remaining_bytes = nwords * sizeof(lispobj);
1921            while (remaining_bytes > PAGE_SIZE) {
1922                gc_assert(PAGE_GENERATION(next_page) == from_space);
1923                gc_assert(PAGE_ALLOCATED(next_page));
1924                gc_assert(!PAGE_UNBOXED(next_page));
1925                gc_assert(PAGE_LARGE_OBJECT(next_page));
1926                gc_assert(page_table[next_page].first_object_offset ==
1927                          PAGE_SIZE * (first_page - next_page));
1928                gc_assert(page_table[next_page].bytes_used == PAGE_SIZE);
1929    
1930      next_page = first_page;              PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);
     remaining_bytes = nwords * sizeof(lispobj);  
     while (remaining_bytes > PAGE_SIZE) {  
       gc_assert(PAGE_GENERATION(next_page) == from_space);  
       gc_assert(PAGE_ALLOCATED(next_page));  
       gc_assert(!PAGE_UNBOXED(next_page));  
       gc_assert(PAGE_LARGE_OBJECT(next_page));  
       gc_assert(page_table[next_page].first_object_offset ==  
                 PAGE_SIZE * (first_page - next_page));  
       gc_assert(page_table[next_page].bytes_used == PAGE_SIZE);  
   
       PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);  
   
       /*  
        * Remove any write protection.  Should be able to religh on the  
        * WP flag to avoid redundant calls.  
        */  
       if (PAGE_WRITE_PROTECTED(next_page)) {  
         os_protect((os_vm_address_t) page_address(next_page), PAGE_SIZE, OS_VM_PROT_ALL);  
         page_table[next_page].flags &= ~PAGE_WRITE_PROTECTED_MASK;  
       }  
       remaining_bytes -= PAGE_SIZE;  
       next_page++;  
     }  
1931    
1932      /*              /*
1933       * Now only one page remains, but the object may have shrunk so               * Remove any write protection.  Should be able to religh on the
1934       * there may be more unused pages which will be freed.               * WP flag to avoid redundant calls.
1935       */               */
1936                if (PAGE_WRITE_PROTECTED(next_page)) {
1937                    os_protect((os_vm_address_t) page_address(next_page), PAGE_SIZE,
1938                               OS_VM_PROT_ALL);
1939                    page_table[next_page].flags &= ~PAGE_WRITE_PROTECTED_MASK;
1940                }
1941                remaining_bytes -= PAGE_SIZE;
1942                next_page++;
1943            }
1944    
1945      /* Object may have shrunk but shouldn't have grown - check. */          /*
1946      gc_assert(page_table[next_page].bytes_used >= remaining_bytes);           * Now only one page remains, but the object may have shrunk so
1947             * there may be more unused pages which will be freed.
1948             */
1949    
1950      PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);          /* Object may have shrunk but shouldn't have grown - check. */
1951      gc_assert(PAGE_ALLOCATED(next_page));          gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
     gc_assert(!PAGE_UNBOXED(next_page));  
1952    
1953      /* Adjust the bytes_used. */          PAGE_FLAGS_UPDATE(next_page, PAGE_GENERATION_MASK, new_space);
1954      old_bytes_used = page_table[next_page].bytes_used;          gc_assert(PAGE_ALLOCATED(next_page));
1955      page_table[next_page].bytes_used = remaining_bytes;          gc_assert(!PAGE_UNBOXED(next_page));
1956    
1957            /* Adjust the bytes_used. */
1958            old_bytes_used = page_table[next_page].bytes_used;
1959            page_table[next_page].bytes_used = remaining_bytes;
1960    
1961            bytes_freed = old_bytes_used - remaining_bytes;
1962    
1963            mmask = PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | PAGE_LARGE_OBJECT_MASK
1964                | PAGE_GENERATION_MASK;
1965            mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;
1966    
1967            /* Free any remaining pages; needs care. */
1968            next_page++;
1969            while (old_bytes_used == PAGE_SIZE &&
1970                   PAGE_FLAGS(next_page, mmask) == mflags &&
1971                   page_table[next_page].first_object_offset ==
1972                   PAGE_SIZE * (first_page - next_page)) {
1973                /*
1974                 * Checks out OK, free the page. Don't need to both zeroing
1975                 * pages as this should have been done before shrinking the
1976                 * object. These pages shouldn't be write protected as they
1977                 * should be zero filled.
1978                 */
1979                gc_assert(!PAGE_WRITE_PROTECTED(next_page));
1980    
1981      bytes_freed = old_bytes_used - remaining_bytes;              old_bytes_used = page_table[next_page].bytes_used;
1982                page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
1983                page_table[next_page].bytes_used = 0;
1984                bytes_freed += old_bytes_used;
1985                next_page++;
1986            }
1987    
1988      mmask = PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | PAGE_LARGE_OBJECT_MASK          if (gencgc_verbose && bytes_freed > 0)
1989        | PAGE_GENERATION_MASK;              fprintf(stderr, "* copy_large_boxed bytes_freed %d\n", bytes_freed);
     mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;  
1990    
1991      /* Free any remaining pages; needs care. */          generations[from_space].bytes_allocated -=
1992      next_page++;              sizeof(lispobj) * nwords + bytes_freed;
1993      while (old_bytes_used == PAGE_SIZE &&          generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;
1994             PAGE_FLAGS(next_page, mmask) == mflags &&          bytes_allocated -= bytes_freed;
            page_table[next_page].first_object_offset == PAGE_SIZE * (first_page  
                                                                      - next_page)) {  
       /*  
        * Checks out OK, free the page. Don't need to both zeroing  
        * pages as this should have been done before shrinking the  
        * object. These pages shouldn't be write protected as they  
        * should be zero filled.  
        */  
       gc_assert(!PAGE_WRITE_PROTECTED(next_page));  
   
       old_bytes_used = page_table[next_page].bytes_used;  
       page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;  
       page_table[next_page].bytes_used = 0;  
       bytes_freed += old_bytes_used;  
       next_page++;  
     }  
1995    
1996      if (gencgc_verbose && bytes_freed > 0)          /* Add the region to the new_areas if requested. */
1997        fprintf(stderr, "* copy_large_boxed bytes_freed %d\n", bytes_freed);          add_new_area(first_page, 0, nwords * sizeof(lispobj));
1998    
1999      generations[from_space].bytes_allocated -= sizeof(lispobj) * nwords + bytes_freed;          return object;
2000      generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;      } else {
2001      bytes_allocated -= bytes_freed;          /* get tag of object */
2002            tag = LowtagOf(object);
2003    
2004      /* Add the region to the new_areas if requested. */          /* allocate space */
2005      add_new_area(first_page, 0, nwords * sizeof(lispobj));          new = gc_quick_alloc_large(nwords * sizeof(lispobj));
2006    
2007            dest = new;
2008            source = (lispobj *) PTR(object);
2009    
2010            /* copy the object */
2011            while (nwords > 0) {
2012                dest[0] = source[0];
2013                dest[1] = source[1];
2014                dest += 2;
2015                source += 2;
2016                nwords -= 2;
2017            }
2018    
2019            /* return lisp pointer of new object */
2020            return (lispobj) new | tag;
2021        }
2022    }
2023    
2024    /* Copying UnBoxed Objects. */
2025    static inline lispobj
2026    copy_unboxed_object(lispobj object, int nwords)
2027    {
2028        int tag;
2029        lispobj *new;
2030        lispobj *source, *dest;
2031    
2032        gc_assert(Pointerp(object));
2033        gc_assert(from_space_p(object));
2034        gc_assert((nwords & 0x01) == 0);
2035    
     return object;  
   }  
   else {  
2036      /* get tag of object */      /* get tag of object */
2037      tag = LowtagOf(object);      tag = LowtagOf(object);
2038    
2039      /* allocate space */      /* allocate space */
2040      new = gc_quick_alloc_large(nwords * sizeof(lispobj));      new = gc_quick_alloc_unboxed(nwords * sizeof(lispobj));
2041    
2042      dest = new;      dest = new;
2043      source = (lispobj *) PTR(object);      source = (lispobj *) PTR(object);
2044    
2045      /* copy the object */      /* Copy the object */
2046      while (nwords > 0) {      while (nwords > 0) {
2047        dest[0] = source[0];          dest[0] = source[0];
2048        dest[1] = source[1];          dest[1] = source[1];
2049        dest += 2;          dest += 2;
2050        source += 2;          source += 2;
2051        nwords -= 2;          nwords -= 2;
2052      }      }
2053    
2054      /* return lisp pointer of new object */      /* Return lisp pointer of new object. */
2055      return (lispobj) new | tag;      return (lispobj) new | tag;
   }  
 }  
   
 /* Copying UnBoxed Objects. */  
 static inline lispobj copy_unboxed_object(lispobj object, int nwords)  
 {  
   int tag;  
   lispobj *new;  
   lispobj *source, *dest;  
   
   gc_assert(Pointerp(object));  
   gc_assert(from_space_p(object));  
   gc_assert((nwords & 0x01) == 0);  
   
   /* get tag of object */  
   tag = LowtagOf(object);  
   
   /* allocate space */  
   new = gc_quick_alloc_unboxed(nwords*sizeof(lispobj));  
   
   dest = new;  
   source = (lispobj *) PTR(object);  
   
   /* Copy the object */  
   while (nwords > 0) {  
     dest[0] = source[0];  
     dest[1] = source[1];  
     dest += 2;  
     source += 2;  
     nwords -= 2;  
   }  
   
   /* Return lisp pointer of new object. */  
   return (lispobj) new | tag;  
2056  }  }
2057    
2058    
# Line 1966  static inline lispobj copy_unboxed_objec Line 2064  static inline lispobj copy_unboxed_objec
2064   * Bignums and vectors may have shrunk. If the object is not copied   * Bignums and vectors may have shrunk. If the object is not copied
2065   * the space needs to be reclaimed, and the page_tables corrected.   * the space needs to be reclaimed, and the page_tables corrected.
2066   */   */
2067  static lispobj copy_large_unboxed_object(lispobj object, int nwords)  static lispobj
2068    copy_large_unboxed_object(lispobj object, int nwords)
2069  {  {
2070    int tag;      int tag;
2071    lispobj *new;      lispobj *new;
2072    lispobj *source, *dest;      lispobj *source, *dest;
2073    int first_page;      int first_page;
2074    
2075    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
2076    gc_assert(from_space_p(object));      gc_assert(from_space_p(object));
2077    gc_assert((nwords & 0x01) == 0);      gc_assert((nwords & 0x01) == 0);
2078    
2079    if (gencgc_verbose && nwords > 1024 * 1024)      if (gencgc_verbose && nwords > 1024 * 1024)
2080      fprintf(stderr, "** copy_large_unboxed_object: %d\n", nwords * sizeof(lispobj));          fprintf(stderr, "** copy_large_unboxed_object: %d\n",
2081                    nwords * sizeof(lispobj));
2082    /* Check if it's a large object. */  
2083    first_page = find_page_index((void *) object);      /* Check if it's a large object. */
2084    gc_assert(first_page >= 0);      first_page = find_page_index((void *) object);
2085        gc_assert(first_page >= 0);
   if (PAGE_LARGE_OBJECT(first_page)) {  
     /*  
      * Promote the object. Note: Unboxed objects may have been  
      * allocated to a BOXED region so it may be necessary to change  
      * the region to UNBOXED.  
      */  
     int remaining_bytes;  
     int next_page;  
     int bytes_freed;  
     int old_bytes_used;  
     int mmask, mflags;  
2086    
2087      gc_assert(page_table[first_page].first_object_offset == 0);      if (PAGE_LARGE_OBJECT(first_page)) {
2088            /*
2089      next_page = first_page;           * Promote the object. Note: Unboxed objects may have been
2090      remaining_bytes = nwords * sizeof(lispobj);           * allocated to a BOXED region so it may be necessary to change
2091      while (remaining_bytes > PAGE_SIZE) {           * the region to UNBOXED.
2092        gc_assert(PAGE_GENERATION(next_page) == from_space);           */
2093        gc_assert(PAGE_ALLOCATED(next_page));          int remaining_bytes;
2094        gc_assert(PAGE_LARGE_OBJECT(next_page));          int next_page;
2095        gc_assert(page_table[next_page].first_object_offset ==          int bytes_freed;
2096                  PAGE_SIZE * (first_page - next_page));          int old_bytes_used;
2097        gc_assert(page_table[next_page].bytes_used == PAGE_SIZE);          int mmask, mflags;
2098    
2099        PAGE_FLAGS_UPDATE(next_page, PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,          gc_assert(page_table[first_page].first_object_offset == 0);
2100                          PAGE_UNBOXED_MASK | new_space);  
2101        remaining_bytes -= PAGE_SIZE;          next_page = first_page;
2102        next_page++;          remaining_bytes = nwords * sizeof(lispobj);
2103      }          while (remaining_bytes > PAGE_SIZE) {
2104                gc_assert(PAGE_GENERATION(next_page) == from_space);
2105      /*              gc_assert(PAGE_ALLOCATED(next_page));
2106       * Now only one page remains, but the object may have shrunk so              gc_assert(PAGE_LARGE_OBJECT(next_page));
2107       * there may be more unused pages which will be freed.              gc_assert(page_table[next_page].first_object_offset ==
2108       */                        PAGE_SIZE * (first_page - next_page));
2109                gc_assert(page_table[next_page].bytes_used == PAGE_SIZE);
2110      /* Object may have shrunk but shouldn't have grown - check. */  
2111      gc_assert(page_table[next_page].bytes_used >= remaining_bytes);              PAGE_FLAGS_UPDATE(next_page,
2112                                  PAGE_UNBOXED_MASK | PAGE_GENERATION_MASK,
2113      PAGE_FLAGS_UPDATE(next_page, PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK                                PAGE_UNBOXED_MASK | new_space);
2114                        | PAGE_GENERATION_MASK,              remaining_bytes -= PAGE_SIZE;
2115                        PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | new_space);              next_page++;
2116            }
2117    
2118      /* Adjust the bytes_used. */          /*
2119      old_bytes_used = page_table[next_page].bytes_used;           * Now only one page remains, but the object may have shrunk so
2120      page_table[next_page].bytes_used = remaining_bytes;           * there may be more unused pages which will be freed.
2121             */
2122    
2123      bytes_freed = old_bytes_used - remaining_bytes;          /* Object may have shrunk but shouldn't have grown - check. */
2124            gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
2125    
2126      mmask = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK          PAGE_FLAGS_UPDATE(next_page, PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK
2127        | PAGE_GENERATION_MASK;                            | PAGE_GENERATION_MASK,
2128      mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;                            PAGE_ALLOCATED_MASK | PAGE_UNBOXED_MASK | new_space);
2129    
2130            /* Adjust the bytes_used. */
2131            old_bytes_used = page_table[next_page].bytes_used;
2132            page_table[next_page].bytes_used = remaining_bytes;
2133    
2134            bytes_freed = old_bytes_used - remaining_bytes;
2135    
2136            mmask = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK
2137                | PAGE_GENERATION_MASK;
2138            mflags = PAGE_ALLOCATED_MASK | PAGE_LARGE_OBJECT_MASK | from_space;
2139    
2140            /* Free any remaining pages; needs care. */
2141            next_page++;
2142            while (old_bytes_used == PAGE_SIZE &&
2143                   PAGE_FLAGS(next_page, mmask) == mflags &&
2144                   page_table[next_page].first_object_offset ==
2145                   PAGE_SIZE * (first_page - next_page)) {
2146                /*
2147                 * Checks out OK, free the page. Don't need to both zeroing
2148                 * pages as this should have been done before shrinking the
2149                 * object. These pages shouldn't be write protected, even if
2150                 * boxed they should be zero filled.
2151                 */
2152                gc_assert(!PAGE_WRITE_PROTECTED(next_page));
2153    
2154      /* Free any remaining pages; needs care. */              old_bytes_used = page_table[next_page].bytes_used;
2155      next_page++;              page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;
2156      while (old_bytes_used == PAGE_SIZE &&              page_table[next_page].bytes_used = 0;
2157             PAGE_FLAGS(next_page, mmask) == mflags &&              bytes_freed += old_bytes_used;
2158             page_table[next_page].first_object_offset == PAGE_SIZE * (first_page              next_page++;
2159                                                                       - next_page)) {          }
       /*  
        * Checks out OK, free the page. Don't need to both zeroing  
        * pages as this should have been done before shrinking the  
        * object. These pages shouldn't be write protected, even if  
        * boxed they should be zero filled.  
        */  
       gc_assert(!PAGE_WRITE_PROTECTED(next_page));  
   
       old_bytes_used = page_table[next_page].bytes_used;  
       page_table[next_page].flags &= ~PAGE_ALLOCATED_MASK;  
       page_table[next_page].bytes_used = 0;  
       bytes_freed += old_bytes_used;  
       next_page++;  
     }  
2160    
2161      if (gencgc_verbose && bytes_freed > 0)          if (gencgc_verbose && bytes_freed > 0)
2162        fprintf(stderr, "* copy_large_unboxed bytes_freed %d\n", bytes_freed);              fprintf(stderr, "* copy_large_unboxed bytes_freed %d\n",
2163                        bytes_freed);
2164    
2165            generations[from_space].bytes_allocated -=
2166                sizeof(lispobj) * nwords + bytes_freed;
2167            generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;
2168            bytes_allocated -= bytes_freed;
2169    
2170      generations[from_space].bytes_allocated -= sizeof(lispobj) * nwords + bytes_freed;          return object;
2171      generations[new_space].bytes_allocated += sizeof(lispobj) * nwords;      } else {
2172      bytes_allocated -= bytes_freed;          /* get tag of object */
2173            tag = LowtagOf(object);
2174    
2175      return object;          /* allocate space */
2176    }          new = gc_quick_alloc_large_unboxed(nwords * sizeof(lispobj));
   else {  
     /* get tag of object */  
     tag = LowtagOf(object);  
2177    
2178      /* allocate space */          dest = new;
2179      new = gc_quick_alloc_large_unboxed(nwords * sizeof(lispobj));          source = (lispobj *) PTR(object);
2180    
2181      dest = new;          /* copy the object */
2182      source = (lispobj *) PTR(object);          while (nwords > 0) {
2183                dest[0] = source[0];
2184                dest[1] = source[1];
2185                dest += 2;
2186                source += 2;
2187                nwords -= 2;
2188            }
2189    
2190      /* copy the object */          /* return lisp pointer of new object */
2191      while (nwords > 0) {          return (lispobj) new | tag;
       dest[0] = source[0];  
       dest[1] = source[1];  
       dest += 2;  
       source += 2;  
       nwords -= 2;  
2192      }      }
   
     /* return lisp pointer of new object */  
     return (lispobj) new | tag;  
   }  
2193  }  }
   
2194    
2195    
2196  /* Scavenging */  /* Scavenging */
2197    
2198  /*  /*
# Line 2107  static lispobj copy_large_unboxed_object Line 2209  static lispobj copy_large_unboxed_object
2209  #define DIRECT_SCAV 0  #define DIRECT_SCAV 0
2210    
2211  static void  static void
2212  scavenge (void *start_obj, long nwords)  scavenge(void *start_obj, long nwords)
2213  {  {
2214    lispobj* start;      lispobj *start;
2215    
2216    start = (lispobj*) start_obj;      start = (lispobj *) start_obj;
   
   while (nwords > 0)  
     {  
       lispobj object;  
       int words_scavenged;  
2217    
2218        object = *start;      while (nwords > 0) {
2219        /* Not a forwarding pointer. */          lispobj object;
2220        gc_assert (object != 0x01);          int words_scavenged;
2221    
2222            object = *start;
2223            /* Not a forwarding pointer. */
2224            gc_assert(object != 0x01);
2225    
2226  #if DIRECT_SCAV  #if DIRECT_SCAV
2227        words_scavenged = scavtab[TypeOf (object)] (start, object);          words_scavenged = scavtab[TypeOf(object)] (start, object);
2228  #else  /* not DIRECT_SCAV */  #else /* not DIRECT_SCAV */
2229        if (Pointerp (object))          if (Pointerp(object)) {
         {  
2230  #ifdef GC_ASSERTIONS  #ifdef GC_ASSERTIONS
2231            check_escaped_stack_object (start, object);              check_escaped_stack_object(start, object);
2232  #endif  #endif
   
           if (from_space_p (object))  
             {  
               lispobj *ptr = (lispobj *) PTR (object);  
               lispobj first_word = *ptr;  
2233    
2234                if (first_word == 0x01)              if (from_space_p(object)) {
2235                  {                  lispobj *ptr = (lispobj *) PTR(object);
2236                    *start = ptr[1];                  lispobj first_word = *ptr;
2237                    words_scavenged = 1;  
2238                  }                  if (first_word == 0x01) {
2239                else                      *start = ptr[1];
2240                  words_scavenged = scavtab[TypeOf (object)] (start, object);                      words_scavenged = 1;
2241              }                  } else
2242            else                      words_scavenged = scavtab[TypeOf(object)] (start, object);
2243                } else
2244                    words_scavenged = 1;
2245            } else if ((object & 3) == 0)
2246              words_scavenged = 1;              words_scavenged = 1;
2247          }          else
2248        else if ((object & 3) == 0)              words_scavenged = scavtab[TypeOf(object)] (start, object);
         words_scavenged = 1;  
       else  
         words_scavenged = scavtab[TypeOf (object)] (start, object);  
2249  #endif /* not DIRECT_SCAV */  #endif /* not DIRECT_SCAV */
2250    
2251        start += words_scavenged;          start += words_scavenged;
2252        nwords -= words_scavenged;          nwords -= words_scavenged;
2253      }      }
   
   gc_assert (nwords == 0);  
 }  
2254    
2255        gc_assert(nwords == 0);
2256    }
2257    
2258    
2259  #if !(defined(i386) || defined(__x86_64))  #if !(defined(i386) || defined(__x86_64))
2260  /* Scavenging Interrupt Contexts */  /* Scavenging Interrupt Contexts */
2261    
2262  static int boxed_registers[] = BOXED_REGISTERS;  static int boxed_registers[] = BOXED_REGISTERS;
2263    
2264  static void scavenge_interrupt_context(os_context_t *context)  static void
2265    scavenge_interrupt_context(os_context_t * context)
2266  {  {
2267    int i;      int i;
2268    
2269  #ifdef reg_LIP  #ifdef reg_LIP
2270    unsigned long lip;      unsigned long lip;
2271    unsigned long lip_offset;      unsigned long lip_offset;
2272    int lip_register_pair;      int lip_register_pair;
2273  #endif  #endif
2274    unsigned long pc_code_offset;      unsigned long pc_code_offset;
2275    
2276  #ifdef SC_NPC  #ifdef SC_NPC
2277    unsigned long npc_code_offset;      unsigned long npc_code_offset;
2278  #endif  #endif
2279    
2280  #ifdef reg_LIP  #ifdef reg_LIP
2281    /* Find the LIP's register pair and calculate it's offset */      /* Find the LIP's register pair and calculate it's offset */
2282    /* before we scavenge the context. */      /* before we scavenge the context. */
2283    
2284    /*      /*
2285     * I (RLT) think this is trying to find the boxed register that is       * I (RLT) think this is trying to find the boxed register that is
2286     * closest to the LIP address, without going past it.  Usually, it's       * closest to the LIP address, without going past it.  Usually, it's
2287     * reg_CODE or reg_LRA.  But sometimes, nothing can be found.       * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
2288     */       */
2289    lip = SC_REG(context, reg_LIP);      lip = SC_REG(context, reg_LIP);
2290    lip_offset = 0x7FFFFFFF;      lip_offset = 0x7FFFFFFF;
2291    lip_register_pair = -1;      lip_register_pair = -1;
2292    for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++)      for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2293      {          unsigned long reg;
2294        unsigned long reg;          long offset;
2295        long offset;          int index;
2296        int index;  
2297            index = boxed_registers[i];
2298        index = boxed_registers[i];          reg = SC_REG(context, index);
2299        reg = SC_REG(context, index);          if (Pointerp(reg) && PTR(reg) <= lip) {
2300        if (Pointerp(reg) && PTR(reg) <= lip) {              offset = lip - reg;
2301          offset = lip - reg;              if (offset < lip_offset) {
2302          if (offset < lip_offset) {                  lip_offset = offset;
2303            lip_offset = offset;                  lip_register_pair = index;
2304            lip_register_pair = index;              }
2305          }          }
       }  
2306      }      }
2307  #endif /* reg_LIP */  #endif /* reg_LIP */
2308    
2309    /* Compute the PC's offset from the start of the CODE */      /* Compute the PC's offset from the start of the CODE */
2310    /* register. */      /* register. */
2311    pc_code_offset = SC_PC(context) - SC_REG(context, reg_CODE);      pc_code_offset = SC_PC(context) - SC_REG(context, reg_CODE);
2312  #ifdef SC_NPC  #ifdef SC_NPC
2313    npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);      npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
2314  #endif /* SC_NPC */  #endif /* SC_NPC */
   
   /* Scanvenge all boxed registers in the context. */  
   for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++)  
     {  
       int index;  
       lispobj foo;  
   
       index = boxed_registers[i];  
       foo = SC_REG(context,index);  
       scavenge(&foo, 1);  
       SC_REG(context,index) = foo;  
2315    
2316        scavenge(&(SC_REG(context, index)), 1);      /* Scanvenge all boxed registers in the context. */
2317        for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
2318            int index;
2319            lispobj foo;
2320    
2321            index = boxed_registers[i];
2322            foo = SC_REG(context, index);
2323            scavenge(&foo, 1);
2324            SC_REG(context, index) = foo;
2325    
2326            scavenge(&(SC_REG(context, index)), 1);
2327      }      }
2328    
2329  #ifdef reg_LIP  #ifdef reg_LIP
2330    /* Fix the LIP */      /* Fix the LIP */
2331    
2332    /*      /*
2333     * But what happens if lip_register_pair is -1?  SC_REG on Solaris       * But what happens if lip_register_pair is -1?  SC_REG on Solaris
2334     * (see solaris_register_address in solaris-os.c) will return       * (see solaris_register_address in solaris-os.c) will return
2335     * &context->uc_mcontext.gregs[2].  But gregs[2] is REG_nPC.  Is       * &context->uc_mcontext.gregs[2].  But gregs[2] is REG_nPC.  Is
2336     * that what we really want?  My guess is that that is not what we       * that what we really want?  My guess is that that is not what we
2337     * want, so if lip_register_pair is -1, we don't touch reg_LIP at       * want, so if lip_register_pair is -1, we don't touch reg_LIP at
2338     * all.  But maybe it doesn't really matter if LIP is trashed?       * all.  But maybe it doesn't really matter if LIP is trashed?
2339     */       */
2340    if (lip_register_pair >= 0)      if (lip_register_pair >= 0) {
2341      {          SC_REG(context, reg_LIP) =
2342        SC_REG(context, reg_LIP) =              SC_REG(context, lip_register_pair) + lip_offset;
         SC_REG(context, lip_register_pair) + lip_offset;  
2343      }      }
2344  #endif /* reg_LIP */  #endif /* reg_LIP */
2345    
2346    /* Fix the PC if it was in from space */      /* Fix the PC if it was in from space */
2347    if (from_space_p(SC_PC(context)))      if (from_space_p(SC_PC(context)))
2348      SC_PC(context) = SC_REG(context, reg_CODE) + pc_code_offset;          SC_PC(context) = SC_REG(context, reg_CODE) + pc_code_offset;
2349  #ifdef SC_NPC  #ifdef SC_NPC
2350    if (from_space_p(SC_NPC(context)))      if (from_space_p(SC_NPC(context)))
2351      SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;          SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
2352  #endif /* SC_NPC */  #endif /* SC_NPC */
2353  }  }
2354    
2355  void scavenge_interrupt_contexts(void)  void
2356    scavenge_interrupt_contexts(void)
2357  {  {
2358    int i, index;      int i, index;
2359    os_context_t *context;      os_context_t *context;
2360    
2361  #ifdef PRINTNOISE  #ifdef PRINTNOISE
2362    printf("Scavenging interrupt contexts ...\n");      printf("Scavenging interrupt contexts ...\n");
2363  #endif  #endif
2364    
2365    index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));      index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
2366    
2367  #if defined(DEBUG_PRINT_CONTEXT_INDEX)  #if defined(DEBUG_PRINT_CONTEXT_INDEX)
2368    printf("Number of active contexts: %d\n", index);      printf("Number of active contexts: %d\n", index);
2369  #endif  #endif
2370    
2371    for (i = 0; i < index; i++)      for (i = 0; i < index; i++) {
2372      {          context = lisp_interrupt_contexts[i];
2373        context = lisp_interrupt_contexts[i];          scavenge_interrupt_context(context);
       scavenge_interrupt_context(context);  
2374      }      }
2375  }  }
2376  #endif  #endif
# Line 2286  void scavenge_interrupt_contexts(void) Line 2381  void scavenge_interrupt_contexts(void)
2381   * Aargh!  Why is SPARC so different here?  What is the advantage of   * Aargh!  Why is SPARC so different here?  What is the advantage of
2382   * making it different from all the other ports?   * making it different from all the other ports?
2383   */   */
2384  #ifdef sparc  #if defined(sparc) || defined(DARWIN)
2385  #define RAW_ADDR_OFFSET 0  #define RAW_ADDR_OFFSET 0
2386  #else  #else
2387  #define RAW_ADDR_OFFSET (6 * sizeof(lispobj) - type_FunctionPointer)  #define RAW_ADDR_OFFSET (6 * sizeof(lispobj) - type_FunctionPointer)
# Line 2296  static lispobj trans_function_header(lis Line 2391  static lispobj trans_function_header(lis
2391  static lispobj trans_boxed(lispobj object);  static lispobj trans_boxed(lispobj object);
2392    
2393  #if DIRECT_SCAV  #if DIRECT_SCAV
2394  static int scav_function_pointer(lispobj *where, lispobj object)  static int
2395    scav_function_pointer(lispobj * where, lispobj object)
2396  {  {
2397    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
2398    
2399    if (from_space_p(object)) {      if (from_space_p(object)) {
2400      lispobj first, *first_pointer;          lispobj first, *first_pointer;
2401    
2402      /*          /*
2403       * Object is a pointer into from space - check to see if it has           * Object is a pointer into from space - check to see if it has
2404       * been forwarded.           * been forwarded.
2405       */           */
2406      first_pointer = (lispobj *) PTR(object);          first_pointer = (lispobj *) PTR(object);
2407      first = *first_pointer;          first = *first_pointer;
2408    
2409      if (first == 0x01) {          if (first == 0x01) {
2410        /* Forwarded */              /* Forwarded */
2411        *where = first_pointer[1];              *where = first_pointer[1];
2412        return 1;              return 1;
2413      }          } else {
2414      else {              int type;
2415        int type;              lispobj copy;
       lispobj copy;  
2416    
2417        /*              /*
2418         * Must transport object -- object may point to either a               * Must transport object -- object may point to either a
2419         * function header, a closure function header, or to a closure               * function header, a closure function header, or to a closure
2420         * header.               * header.
2421         */               */
2422    
2423        type = TypeOf(first);              type = TypeOf(first);
2424        switch (type) {              switch (type) {
2425        case type_FunctionHeader:                case type_FunctionHeader:
2426        case type_ClosureFunctionHeader:                case type_ClosureFunctionHeader:
2427          copy = trans_function_header(object);                    copy = trans_function_header(object);
2428          break;                    break;
2429        default:                default:
2430          copy = trans_boxed(object);                    copy = trans_boxed(object);
2431          break;                    break;
2432        }              }
2433    
2434        if (copy != object) {              if (copy != object) {
2435          /* Set forwarding pointer. */                  /* Set forwarding pointer. */
2436          first_pointer[0] = 0x01;                  first_pointer[0] = 0x01;
2437          first_pointer[1] = copy;                  first_pointer[1] = copy;
2438        }              }
2439    
2440        first = copy;              first = copy;
2441      }          }
2442    
2443      gc_assert(Pointerp(first));          gc_assert(Pointerp(first));
2444      gc_assert(!from_space_p(first));          gc_assert(!from_space_p(first));
2445    
2446      *where = first;          *where = first;
2447    }      }
2448    return 1;      return 1;
2449  }  }
2450  #else  #else
2451  static int scav_function_pointer(lispobj *where, lispobj object)  static int
2452    scav_function_pointer(lispobj * where, lispobj object)
2453  {  {
2454    lispobj *first_pointer;      lispobj *first_pointer;
2455    lispobj copy;      lispobj copy;
2456    
2457    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
2458    
2459    /* Object is a pointer into from space - no a FP. */      /* Object is a pointer into from space - no a FP. */
2460    first_pointer = (lispobj *) PTR(object);      first_pointer = (lispobj *) PTR(object);
   
   /*  
    * Must transport object -- object may point to either a function  
    * header, a closure function header, or to a closure header.  
    */  
   
   switch (TypeOf(*first_pointer)) {  
   case type_FunctionHeader:  
   case type_ClosureFunctionHeader:  
     copy = trans_function_header(object);  
     break;  
   default:  
     copy = trans_boxed(object);  
     break;  
   }  
2461    
2462    if (copy != object) {      /*
2463      /* Set forwarding pointer */       * Must transport object -- object may point to either a function
2464      first_pointer[0] = 0x01;       * header, a closure function header, or to a closure header.
2465      first_pointer[1] = copy;       */
2466    }  
2467        switch (TypeOf(*first_pointer)) {
2468          case type_FunctionHeader:
2469          case type_ClosureFunctionHeader:
2470              copy = trans_function_header(object);
2471              break;
2472          default:
2473              copy = trans_boxed(object);
2474              break;
2475        }
2476    
2477        if (copy != object) {
2478            /* Set forwarding pointer */
2479            first_pointer[0] = 0x01;
2480            first_pointer[1] = copy;
2481        }
2482    
2483    gc_assert(Pointerp(copy));      gc_assert(Pointerp(copy));
2484    gc_assert(!from_space_p(copy));      gc_assert(!from_space_p(copy));
2485    
2486    *where = copy;      *where = copy;
2487    
2488    return 1;      return 1;
2489  }  }
2490  #endif  #endif
2491    
# Line 2405  static int scav_function_pointer(lispobj Line 2501  static int scav_function_pointer(lispobj
2501   * Currently only absolution fixups to the constant vector, or to the   * Currently only absolution fixups to the constant vector, or to the
2502   * code area are checked.   * code area are checked.
2503   */   */
2504  void sniff_code_object(struct code *code, unsigned displacement)  void
2505    sniff_code_object(struct code *code, unsigned displacement)
2506  {  {
2507    int nheader_words, ncode_words, nwords;      int nheader_words, ncode_words, nwords;
2508    void *p;      void *p;
2509    void *constants_start_addr, *constants_end_addr;      void *constants_start_addr, *constants_end_addr;
2510    void *code_start_addr, *code_end_addr;      void *code_start_addr, *code_end_addr;
2511    int fixup_found = 0;      int fixup_found = 0;
2512    
2513    if (!check_code_fixups)      if (!check_code_fixups)
2514      return;          return;
2515    
2516    /*      /*
2517     * It's ok if it's byte compiled code. The trace table offset will       * It's ok if it's byte compiled code. The trace table offset will
2518     * be a fixnum if it's x86 compiled code - check.       * be a fixnum if it's x86 compiled code - check.
2519     */       */
2520    if (code->trace_table_offset & 0x3) {      if (code->trace_table_offset & 0x3) {
2521  #if 0  #if 0
2522      fprintf(stderr, "*** Sniffing byte compiled code object at %x.\n",code);          fprintf(stderr, "*** Sniffing byte compiled code object at %x.\n",
2523                    code);
2524  #endif  #endif
2525      return;          return;
2526    }      }
2527    
2528    /* Else it's x86 machine code. */      /* Else it's x86 machine code. */
2529    
2530        ncode_words = fixnum_value(code->code_size);
2531        nheader_words = HeaderValue(*(lispobj *) code);
2532        nwords = ncode_words + nheader_words;
2533    
2534        constants_start_addr = (void *) code + 5 * sizeof(lispobj);
2535        constants_end_addr = (void *) code + nheader_words * sizeof(lispobj);
2536        code_start_addr = (void *) code + nheader_words * sizeof(lispobj);
2537        code_end_addr = (void *) code + nwords * sizeof(lispobj);
2538    
2539        /* Work through the unboxed code. */
2540        for (p = code_start_addr; p < code_end_addr; p++) {
2541            void *data = *(void **) p;
2542            unsigned d1 = *((unsigned char *) p - 1);
2543            unsigned d2 = *((unsigned char *) p - 2);
2544            unsigned d3 = *((unsigned char *) p - 3);
2545            unsigned d4 = *((unsigned char *) p - 4);
2546            unsigned d5 = *((unsigned char *) p - 5);
2547            unsigned d6 = *((unsigned char *) p - 6);
2548    
2549    ncode_words = fixnum_value(code->code_size);          /*
2550    nheader_words = HeaderValue(*(lispobj *) code);           * Check for code references.
2551    nwords = ncode_words + nheader_words;           *
2552             * Check for a 32 bit word that looks like an absolute reference
2553    constants_start_addr = (void *) code + 5 * sizeof(lispobj);           * to within the code adea of the code object.
2554    constants_end_addr = (void *) code + nheader_words * sizeof(lispobj);           */
2555    code_start_addr = (void *) code + nheader_words * sizeof(lispobj);          if (data >= code_start_addr - displacement
2556    code_end_addr = (void *) code + nwords * sizeof(lispobj);              && data < code_end_addr - displacement) {
2557                /* Function header */
2558    /* Work through the unboxed code. */              if (d4 == 0x5e
2559    for (p = code_start_addr; p < code_end_addr; p++) {                  && ((unsigned long) p - 4 -
2560      void *data = *(void **) p;                      4 * HeaderValue(*((unsigned long *) p - 1))) ==
2561      unsigned d1 = *((unsigned char *) p - 1);                  (unsigned long) code) {
2562      unsigned d2 = *((unsigned char *) p - 2);                  /* Skip the function header */
2563      unsigned d3 = *((unsigned char *) p - 3);                  p += 6 * 4 - 4 - 1;
2564      unsigned d4 = *((unsigned char *) p - 4);                  continue;
2565      unsigned d5 = *((unsigned char *) p - 5);              }
2566      unsigned d6 = *((unsigned char *) p - 6);              /* Push imm32 */
2567                if (d1 == 0x68) {
2568                    fixup_found = 1;
2569                    fprintf(stderr,
2570                            "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2571                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
2572                            (unsigned long) data);
2573                    fprintf(stderr, "***  Push $0x%.8lx\n", (unsigned long) data);
2574                }
2575                /* Mov [reg-8],imm32 */
2576                if (d3 == 0xc7
2577                    && (d2 == 0x40 || d2 == 0x41 || d2 == 0x42 || d2 == 0x43
2578                        || d2 == 0x45 || d2 == 0x46 || d2 == 0x47)
2579                    && d1 == 0xf8) {
2580                    fixup_found = 1;
2581                    fprintf(stderr,
2582                            "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2583                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
2584                            (unsigned long) data);
2585                    fprintf(stderr, "***  Mov [reg-8],$0x%.8lx\n",
2586                            (unsigned long) data);
2587                }
2588                /* Lea reg, [disp32] */
2589                if (d2 == 0x8d && (d1 & 0xc7) == 5) {
2590                    fixup_found = 1;
2591                    fprintf(stderr,
2592                            "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2593                            (unsigned long) p, d6, d5, d4, d3, d2, d1,
2594                            (unsigned long) data);
2595                    fprintf(stderr, "***  Lea reg,[$0x%.8lx]\n",
2596                            (unsigned long) data);
2597                }
2598            }
2599    
2600      /*          /*
2601       * Check for code references.           * Check for constant references.
2602       *           *
2603       * Check for a 32 bit word that looks like an absolute reference           * Check for a 32 bit word that looks like an absolution reference
2604       * to within the code adea of the code object.           * to within the constant vector. Constant references will be
2605       */           * aligned.
2606      if (data >= code_start_addr - displacement           */
2607          && data < code_end_addr - displacement) {          if (data >= constants_start_addr - displacement
2608        /* Function header */              && data < constants_end_addr - displacement
2609        if (d4 == 0x5e              && ((unsigned long) data & 0x3) == 0) {
2610            && ((unsigned long) p - 4 - 4 * HeaderValue(*((unsigned long *) p - 1))) == (unsigned long) code) {              /*  Mov eax,m32 */
2611          /* Skip the function header */              if (d1 == 0xa1) {
2612          p += 6 * 4 - 4 - 1;                  fixup_found = 1;
2613          continue;                  fprintf(stderr,
2614        }                          "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2615        /* Push imm32 */                          (unsigned long) p, d6, d5, d4, d3, d2, d1,
2616        if (d1 == 0x68) {                          (unsigned long) data);
2617          fixup_found = 1;                  fprintf(stderr, "***  Mov eax,0x%.8lx\n", (unsigned long) data);
2618          fprintf(stderr, "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",              }
2619                  (unsigned long) p, d6,d5,d4,d3,d2,d1,  
2620                  (unsigned long) data);              /*  Mov m32,eax */
2621          fprintf(stderr, "***  Push $0x%.8lx\n", (unsigned long) data);              if (d1 == 0xa3) {
2622        }                  fixup_found = 1;
2623        /* Mov [reg-8],imm32 */                  fprintf(stderr,
2624        if (d3 == 0xc7                          "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2625            && (d2 == 0x40 || d2 == 0x41 || d2 == 0x42 || d2 == 0x43                          (unsigned long) p, d6, d5, d4, d3, d2, d1,
2626                || d2 == 0x45 || d2 == 0x46 || d2 == 0x47)                          (unsigned long) data);
2627            && d1 == 0xf8) {                  fprintf(stderr, "***  Mov 0x%.8lx,eax\n", (unsigned long) data);
2628          fixup_found = 1;              }
2629          fprintf(stderr, "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
2630                  (unsigned long) p, d6,d5,d4,d3,d2,d1, (unsigned long) data);              /* Cmp m32,imm32 */
2631          fprintf(stderr, "***  Mov [reg-8],$0x%.8lx\n", (unsigned long) data);              if (d1 == 0x3d && d2 == 0x81) {
2632        }                  fixup_found = 1;
2633        /* Lea reg, [disp32] */                  fprintf(stderr,
2634        if (d2 == 0x8d && (d1 & 0xc7) == 5) {                          "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2635          fixup_found = 1;                          (unsigned long) p, d6, d5, d4, d3, d2, d1,
2636          fprintf(stderr, "Code ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",                          (unsigned long) data);
2637                  (unsigned long) p, d6,d5,d4,d3,d2,d1, (unsigned long) data);                  /* XX Check this */
2638          fprintf(stderr, "***  Lea reg,[$0x%.8lx]\n", (unsigned long) data);                  fprintf(stderr, "***  Cmp 0x%.8lx,immed32\n",
2639        }                          (unsigned long) data);
2640                }
2641    
2642                /* Check for a mod=00, r/m=101 byte. */
2643                if ((d1 & 0xc7) == 5) {
2644                    /* Cmp m32,reg */
2645                    if (d2 == 0x39) {
2646                        fixup_found = 1;
2647                        fprintf(stderr,
2648                                "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2649                                (unsigned long) p, d6, d5, d4, d3, d2, d1,
2650                                (unsigned long) data);
2651                        fprintf(stderr, "***  Cmp 0x%.8lx,reg\n",
2652                                (unsigned long) data);
2653                    }
2654                    /* Cmp reg32,m32 */
2655                    if (d2 == 0x3b) {
2656                        fixup_found = 1;
2657                        fprintf(stderr,
2658                                "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2659                                (unsigned long) p, d6, d5, d4, d3, d2, d1,
2660                                (unsigned long) data);
2661                        fprintf(stderr, "***  Cmp reg32,0x%.8lx\n",
2662                                (unsigned long) data);
2663                    }
2664                    /* Mov m32,reg32 */
2665                    if (d2 == 0x89) {
2666                        fixup_found = 1;
2667                        fprintf(stderr,
2668                                "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2669                                (unsigned long) p, d6, d5, d4, d3, d2, d1,
2670                                (unsigned long) data);
2671                        fprintf(stderr, "***  Mov 0x%.8lx,reg32\n",
2672                                (unsigned long) data);
2673                    }
2674                    /* Mov reg32,m32 */
2675                    if (d2 == 0x8b) {
2676                        fixup_found = 1;
2677                        fprintf(stderr,
2678                                "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2679                                (unsigned long) p, d6, d5, d4, d3, d2, d1,
2680                                (unsigned long) data);
2681                        fprintf(stderr, "***  Mov reg32,0x%.8lx\n",
2682                                (unsigned long) data);
2683                    }
2684                    /* Lea reg32,m32 */
2685                    if (d2 == 0x8d) {
2686                        fixup_found = 1;
2687                        fprintf(stderr,
2688                                "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",
2689                                (unsigned long) p, d6, d5, d4, d3, d2, d1,
2690                                (unsigned long) data);
2691                        fprintf(stderr, "***  Lea reg32,0x%.8lx\n",
2692                                (unsigned long) data);
2693                    }
2694                }
2695            }
2696        }
2697    
2698        /* If anything was found print out some info. on the code object. */
2699        if (fixup_found) {
2700            fprintf(stderr,
2701                    "*** Compiled code object at %lx: header_words=%d code_words=%d .\n",
2702                    (unsigned long) code, nheader_words, ncode_words);
2703            fprintf(stderr,
2704                    "*** Const. start = %lx; end= %lx; Code start = %lx; end = %lx\n",
2705                    (unsigned long) constants_start_addr,
2706                    (unsigned long) constants_end_addr,
2707                    (unsigned long) code_start_addr, (unsigned long) code_end_addr);
2708      }      }
2709    }
2710    
2711    static void
2712    apply_code_fixups(struct code *old_code, struct code *new_code)
2713    {
2714        int nheader_words, ncode_words, nwords;
2715        void *constants_start_addr, *constants_end_addr;
2716        void *code_start_addr, *code_end_addr;
2717        lispobj fixups = NIL;
2718        unsigned long displacement =
2719    
2720            (unsigned long) new_code - (unsigned long) old_code;
2721        struct vector *fixups_vector;
2722    
2723      /*      /*
2724       * Check for constant references.       * It's ok if it's byte compiled code. The trace table offset will
2725       *       * be a fixnum if it's x86 compiled code - check.
2726       * Check for a 32 bit word that looks like an absolution reference       */
2727       * to within the constant vector. Constant references will be      if (new_code->trace_table_offset & 0x3) {
      * aligned.  
      */  
     if (data >= constants_start_addr - displacement  
         && data < constants_end_addr - displacement  
         && ((unsigned long) data & 0x3) == 0) {  
       /*  Mov eax,m32 */  
       if (d1 == 0xa1) {  
         fixup_found = 1;  
         fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                 (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
         fprintf(stderr, "***  Mov eax,0x%.8lx\n", (unsigned long) data);  
       }  
   
       /*  Mov m32,eax */  
       if (d1 == 0xa3) {  
         fixup_found = 1;  
         fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                 (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
         fprintf(stderr, "***  Mov 0x%.8lx,eax\n", (unsigned long) data);  
       }  
   
       /* Cmp m32,imm32 */  
       if (d1 == 0x3d && d2 == 0x81) {  
         fixup_found = 1;  
         fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                 (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
         /* XX Check this */  
         fprintf(stderr, "***  Cmp 0x%.8lx,immed32\n", (unsigned long) data);  
       }  
   
       /* Check for a mod=00, r/m=101 byte. */  
       if ((d1 & 0xc7) == 5) {  
         /* Cmp m32,reg */  
         if (d2 == 0x39) {  
           fixup_found = 1;  
           fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                   (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
           fprintf(stderr, "***  Cmp 0x%.8lx,reg\n", (unsigned long) data);  
         }  
         /* Cmp reg32,m32 */  
         if (d2 == 0x3b) {  
           fixup_found = 1;  
           fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                   (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
           fprintf(stderr, "***  Cmp reg32,0x%.8lx\n", (unsigned long) data);  
         }  
         /* Mov m32,reg32 */  
         if (d2 == 0x89) {  
           fixup_found = 1;  
           fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                   (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
           fprintf(stderr, "***  Mov 0x%.8lx,reg32\n", (unsigned long) data);  
         }  
         /* Mov reg32,m32 */  
         if (d2 == 0x8b) {  
           fixup_found = 1;  
           fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                   (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
           fprintf(stderr, "***  Mov reg32,0x%.8lx\n", (unsigned long) data);  
         }  
         /* Lea reg32,m32 */  
         if (d2 == 0x8d) {  
           fixup_found = 1;  
           fprintf(stderr, "Abs. const. ref. @ %lx: %.2x %.2x %.2x %.2x %.2x %.2x (%.8lx)\n",  
                   (unsigned long) p, d6, d5, d4, d3, d2, d1, (unsigned long) data);  
           fprintf(stderr, "***  Lea reg32,0x%.8lx\n", (unsigned long) data);  
         }  
       }  
     }  
   }  
   
   /* If anything was found print out some info. on the code object. */  
   if (fixup_found) {  
     fprintf(stderr, "*** Compiled code object at %lx: header_words=%d code_words=%d .\n",  
             (unsigned long) code, nheader_words, ncode_words);  
     fprintf(stderr, "*** Const. start = %lx; end= %lx; Code start = %lx; end = %lx\n",  
             (unsigned long) constants_start_addr, (unsigned long) constants_end_addr,  
             (unsigned long) code_start_addr, (unsigned long) code_end_addr);  
   }  
 }  
   
 static void apply_code_fixups(struct code *old_code, struct code *new_code)  
 {  
   int nheader_words, ncode_words, nwords;  
   void *constants_start_addr, *constants_end_addr;  
   void *code_start_addr, *code_end_addr;  
   lispobj fixups = NIL;  
   unsigned long displacement = (unsigned long) new_code - (unsigned long) old_code;  
   struct vector *fixups_vector;  
   
   /*  
    * It's ok if it's byte compiled code. The trace table offset will  
    * be a fixnum if it's x86 compiled code - check.  
    */  
   if (new_code->trace_table_offset & 0x3) {  
2728  #if 0  #if 0
2729      fprintf(stderr, "*** Byte compiled code object at %x.\n", new_code);          fprintf(stderr, "*** Byte compiled code object at %x.\n", new_code);
2730  #endif  #endif
2731      return;          return;
2732    }      }
   
   /* Else it's x86 machine code. */  
   ncode_words = fixnum_value(new_code->code_size);  
   nheader_words = HeaderValue(*(lispobj *) new_code);  
   nwords = ncode_words + nheader_words;  
 #if 0  
   fprintf(stderr, "*** Compiled code object at %x: header_words=%d code_words=%d .\n",  
           new_code, nheader_words, ncode_words);  
 #endif  
   constants_start_addr = (void *) new_code + 5 * sizeof(lispobj);  
   constants_end_addr = (void *) new_code + nheader_words * sizeof(lispobj);  
   code_start_addr = (void *) new_code + nheader_words * sizeof(lispobj);  
   code_end_addr = (void *)new_code + nwords*sizeof(lispobj);  
 #if 0  
   fprintf(stderr, "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",  
           constants_start_addr, constants_end_addr,  
           code_start_addr, code_end_addr);  
 #endif  
   
   /*  
    * The first constant should be a pointer to the fixups for this  
    * code objects - Check.  
    */  
   fixups = new_code->constants[0];  
   
   /*  
    * It will be 0 or the unbound-marker if there are no fixups, and  
    * will be an other pointer if it is valid.  
    */  
   if (fixups == 0 || fixups == type_UnboundMarker || !Pointerp(fixups)) {  
     /* Check for possible errors. */  
     if (check_code_fixups)  
       sniff_code_object(new_code, displacement);  
2733    
2734        /* Else it's x86 machine code. */
2735        ncode_words = fixnum_value(new_code->code_size);
2736        nheader_words = HeaderValue(*(lispobj *) new_code);
2737        nwords = ncode_words + nheader_words;
2738  #if 0  #if 0
2739      fprintf(stderr, "Fixups for code object not found!?\n");      fprintf(stderr,
2740      fprintf(stderr, "*** Compiled code object at %x: header_words=%d code_words=%d .\n",              "*** Compiled code object at %x: header_words=%d code_words=%d .\n",
2741              new_code, nheader_words, ncode_words);              new_code, nheader_words, ncode_words);
     fprintf(stderr, "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",  
             constants_start_addr, constants_end_addr,  
             code_start_addr, code_end_addr);  
2742  #endif  #endif
2743      return;      constants_start_addr = (void *) new_code + 5 * sizeof(lispobj);
2744    }      constants_end_addr = (void *) new_code + nheader_words * sizeof(lispobj);
2745        code_start_addr = (void *) new_code + nheader_words * sizeof(lispobj);
2746        code_end_addr = (void *) new_code + nwords * sizeof(lispobj);
2747    #if 0
2748        fprintf(stderr,
2749                "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
2750                constants_start_addr, constants_end_addr, code_start_addr,
2751                code_end_addr);
2752    #endif
2753    
2754    fixups_vector = (struct vector *) PTR(fixups);      /*
2755         * The first constant should be a pointer to the fixups for this
2756         * code objects - Check.
2757         */
2758        fixups = new_code->constants[0];
2759    
2760        /*
2761         * It will be 0 or the unbound-marker if there are no fixups, and
2762         * will be an other pointer if it is valid.
2763         */
2764        if (fixups == 0 || fixups == type_UnboundMarker || !Pointerp(fixups)) {
2765            /* Check for possible errors. */
2766            if (check_code_fixups)
2767                sniff_code_object(new_code, displacement);
2768    
   /* Could be pointing to a forwarding pointer. */  
   if (Pointerp(fixups) && find_page_index((void*) fixups_vector) != -1  
       && fixups_vector->header == 0x01) {  
2769  #if 0  #if 0
2770      fprintf(stderr, "* FF\n");          fprintf(stderr, "Fixups for code object not found!?\n");
2771            fprintf(stderr,
2772                    "*** Compiled code object at %x: header_words=%d code_words=%d .\n",
2773                    new_code, nheader_words, ncode_words);
2774            fprintf(stderr,
2775                    "*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
2776                    constants_start_addr, constants_end_addr, code_start_addr,
2777                    code_end_addr);
2778  #endif  #endif
2779      /* If so then follow it. */          return;
2780      fixups_vector = (struct vector *) PTR((lispobj) fixups_vector->length);      }
2781    }  
2782        fixups_vector = (struct vector *) PTR(fixups);
2783    
2784        /* Could be pointing to a forwarding pointer. */
2785        if (Pointerp(fixups) && find_page_index((void *) fixups_vector) != -1
2786            && fixups_vector->header == 0x01) {
2787  #if 0  #if 0
2788    fprintf(stderr, "Got the fixups\n");          fprintf(stderr, "* FF\n");
2789    #endif
2790            /* If so then follow it. */
2791            fixups_vector = (struct vector *) PTR((lispobj) fixups_vector->length);
2792        }
2793    #if 0
2794        fprintf(stderr, "Got the fixups\n");
2795  #endif  #endif
2796    
2797    if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {      if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
     /*  
      * Got the fixups for the code block.  Now work through the  
      * vector, and apply a fixup at each address.  
      */  
     int length = fixnum_value(fixups_vector->length);  
     int i;  
     for (i = 0; i < length; i++) {  
       unsigned offset = fixups_vector->data[i];  
       /* Now check the current value of offset. */  
       unsigned long old_value = *(unsigned long *) ((unsigned long) code_start_addr + offset);  
   
       /*  
        * If it's within the old_code object then it must be an  
        * absolute fixup (relative ones are not saved).  
        */  
       if (old_value >= (unsigned long) old_code  
           && old_value < (unsigned long) old_code + nwords * sizeof(lispobj))  
         /* So add the dispacement. */  
         *(unsigned long *) ((unsigned long) code_start_addr + offset) = old_value  
           + displacement;  
       else  
2798          /*          /*
2799           * It is outside the old code object so it must be a relative           * Got the fixups for the code block.  Now work through the
2800           * fixup (absolute fixups are not saved). So subtract the           * vector, and apply a fixup at each address.
          * displacement.  
2801           */           */
2802          *(unsigned long *) ((unsigned long) code_start_addr + offset) = old_value          int length = fixnum_value(fixups_vector->length);
2803            - displacement;          int i;
2804    
2805            for (i = 0; i < length; i++) {
2806                unsigned offset = fixups_vector->data[i];
2807    
2808                /* Now check the current value of offset. */
2809                unsigned long old_value =
2810                    *(unsigned long *) ((unsigned long) code_start_addr + offset);
2811    
2812                /*
2813                 * If it's within the old_code object then it must be an
2814                 * absolute fixup (relative ones are not saved).
2815                 */
2816                if (old_value >= (unsigned long) old_code
2817                    && old_value <
2818                    (unsigned long) old_code + nwords * sizeof(lispobj))
2819                    /* So add the dispacement. */
2820                    *(unsigned long *) ((unsigned long) code_start_addr + offset) =
2821                        old_value + displacement;
2822                else
2823                    /*
2824                     * It is outside the old code object so it must be a relative
2825                     * fixup (absolute fixups are not saved). So subtract the
2826                     * displacement.
2827                     */
2828                    *(unsigned long *) ((unsigned long) code_start_addr + offset) =
2829                        old_value - displacement;
2830            }
2831      }      }
   }  
2832    
2833    /* Check for possible errors. */      /* Check for possible errors. */
2834    if (check_code_fixups)      if (check_code_fixups)
2835      sniff_code_object(new_code, displacement);          sniff_code_object(new_code, displacement);
2836  }  }
2837  #endif  #endif
2838    
2839  static struct code * trans_code(struct code *code)  static struct code *
2840    trans_code(struct code *code)
2841  {  {
2842    struct code *new_code;      struct code *new_code;
2843    lispobj l_code, l_new_code;      lispobj l_code, l_new_code;
2844    int nheader_words, ncode_words, nwords;      int nheader_words, ncode_words, nwords;
2845    unsigned long displacement;      unsigned long displacement;
2846    lispobj fheaderl, *prev_pointer;      lispobj fheaderl, *prev_pointer;
2847    
2848  #if 0  #if 0
2849    fprintf(stderr, "\nTransporting code object located at 0x%08x.\n",      fprintf(stderr, "\nTransporting code object located at 0x%08x.\n",
2850            (unsigned long) code);              (unsigned long) code);
2851  #endif  #endif
2852    
2853    /* If object has already been transported, just return pointer */      /* If object has already been transported, just return pointer */
2854    if (*(lispobj *) code == 0x01)      if (*(lispobj *) code == 0x01) {
2855      {          return (struct code *) (((lispobj *) code)[1]);
       return (struct code*) (((lispobj *) code)[1]);  
2856      }      }
   
2857    
   gc_assert(TypeOf(code->header) == type_CodeHeader);  
2858    
2859    /* prepare to transport the code vector */      gc_assert(TypeOf(code->header) == type_CodeHeader);
   l_code = (lispobj) code | type_OtherPointer;  
2860    
2861    ncode_words = fixnum_value(code->code_size);      /* prepare to transport the code vector */
2862    nheader_words = HeaderValue(code->header);      l_code = (lispobj) code | type_OtherPointer;
   nwords = ncode_words + nheader_words;  
   nwords = CEILING(nwords, 2);  
2863    
2864    l_new_code = copy_large_object(l_code, nwords);      ncode_words = fixnum_value(code->code_size);
2865    new_code = (struct code *) PTR(l_new_code);      nheader_words = HeaderValue(code->header);
2866        nwords = ncode_words + nheader_words;
2867        nwords = CEILING(nwords, 2);
2868    
2869    /* May not have been moved. */      l_new_code = copy_large_object(l_code, nwords);
2870    if (new_code == code)      new_code = (struct code *) PTR(l_new_code);
     return new_code;  
2871    
2872    displacement = l_new_code - l_code;      /* May not have been moved. */
2873        if (new_code == code)
2874            return new_code;
2875    
2876        displacement = l_new_code - l_code;
2877    
2878  #if 0  #if 0
2879    fprintf(stderr, "Old code object at 0x%08x, new code object at 0x%08x.\n",      fprintf(stderr, "Old code object at 0x%08x, new code object at 0x%08x.\n",
2880            (unsigned long) code, (unsigned long) new_code);              (unsigned long) code, (unsigned long) new_code);
2881    fprintf(stderr, "Code object is %d words long.\n", nwords);      fprintf(stderr, "Code object is %d words long.\n", nwords);
2882  #endif  #endif
2883    
2884    /* set forwarding pointer */      /* set forwarding pointer */
2885    ((lispobj *) code)[0] = 0x01;      ((lispobj *) code)[0] = 0x01;
2886    ((lispobj *) code)[1] = l_new_code;      ((lispobj *) code)[1] = l_new_code;
2887    
2888    /*      /*
2889     * Set forwarding pointers for all the function headers in the code       * Set forwarding pointers for all the function headers in the code
2890     * object; also fix all self pointers.       * object; also fix all self pointers.
2891     */       */
2892    
2893    fheaderl = code->entry_points;      fheaderl = code->entry_points;
2894    prev_pointer = &new_code->entry_points;      prev_pointer = &new_code->entry_points;
2895    
2896    while (fheaderl != NIL) {      while (fheaderl != NIL) {
2897      struct function *fheaderp, *nfheaderp;          struct function *fheaderp, *nfheaderp;
2898      lispobj nfheaderl;          lispobj nfheaderl;
2899    
2900      fheaderp = (struct function *) PTR(fheaderl);          fheaderp = (struct function *) PTR(fheaderl);
2901      gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);          gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
2902    
2903      /*          /*
2904       * Calcuate the new function pointer and the new function header.           * Calcuate the new function pointer and the new function header.
2905       */           */
2906      nfheaderl = fheaderl + displacement;          nfheaderl = fheaderl + displacement;
2907      nfheaderp = (struct function *) PTR(nfheaderl);          nfheaderp = (struct function *) PTR(nfheaderl);
2908    
2909      /* set forwarding pointer */          /* set forwarding pointer */
2910      ((lispobj *) fheaderp)[0] = 0x01;          ((lispobj *) fheaderp)[0] = 0x01;
2911      ((lispobj *) fheaderp)[1] = nfheaderl;          ((lispobj *) fheaderp)[1] = nfheaderl;
2912    
2913      /* Fix self pointer */          /* Fix self pointer */
2914      nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;          nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;
2915    
2916      *prev_pointer = nfheaderl;          *prev_pointer = nfheaderl;
2917    
2918      fheaderl = fheaderp->next;          fheaderl = fheaderp->next;
2919      prev_pointer = &nfheaderp->next;          prev_pointer = &nfheaderp->next;
2920    }      }
2921    
2922  #if 0  #if 0
2923    sniff_code_object(new_code, displacement);      sniff_code_object(new_code, displacement);
2924  #endif  #endif
2925  #if defined(i386) || defined(__x86_64)  #if defined(i386) || defined(__x86_64)
2926    apply_code_fixups(code, new_code);      apply_code_fixups(code, new_code);
2927  #else  #else
2928    /* From gc.c */      /* From gc.c */
2929  #ifndef MACH  #ifndef MACH
2930    os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),      os_flush_icache((os_vm_address_t) (((int *) new_code) + nheader_words),
2931                    ncode_words * sizeof(int));                      ncode_words * sizeof(int));
2932  #endif  #endif
2933  #endif  #endif
2934    
2935    return new_code;      return new_code;
2936  }  }
2937    
2938  static int scav_code_header(lispobj *where, lispobj object)  static int
2939    scav_code_header(lispobj * where, lispobj object)
2940  {  {
2941    struct code *code;      struct code *code;
2942    int nheader_words, ncode_words, nwords;      int nheader_words, ncode_words, nwords;
2943    lispobj fheaderl;      lispobj fheaderl;
2944    struct function *fheaderp;      struct function *fheaderp;
2945    
2946    code = (struct code *) where;      code = (struct code *) where;
2947    ncode_words = fixnum_value(code->code_size);      ncode_words = fixnum_value(code->code_size);
2948    nheader_words = HeaderValue(object);      nheader_words = HeaderValue(object);
2949    nwords = ncode_words + nheader_words;      nwords = ncode_words + nheader_words;
2950    nwords = CEILING(nwords, 2);      nwords = CEILING(nwords, 2);
2951    
2952    /* Scavenge the boxed section of the code data block */      /* Scavenge the boxed section of the code data block */
2953    scavenge(where + 1, nheader_words - 1);      scavenge(where + 1, nheader_words - 1);
2954    
2955    /*      /*
2956     * Scavenge the boxed section of each function object in the code       * Scavenge the boxed section of each function object in the code
2957     * data block       * data block
2958     */       */
2959    fheaderl = code->entry_points;      fheaderl = code->entry_points;
2960    while (fheaderl != NIL) {      while (fheaderl != NIL) {
2961      fheaderp = (struct function *) PTR(fheaderl);          fheaderp = (struct function *) PTR(fheaderl);
2962      gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);          gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
2963    
2964      scavenge(&fheaderp->name, 1);          scavenge(&fheaderp->name, 1);
2965      scavenge(&fheaderp->arglist, 1);          scavenge(&fheaderp->arglist, 1);
2966      scavenge(&fheaderp->type, 1);          scavenge(&fheaderp->type, 1);
2967    
2968      fheaderl = fheaderp->next;          fheaderl = fheaderp->next;
2969    }      }
2970    
2971    return nwords;      return nwords;
2972  }  }
2973    
2974  static lispobj trans_code_header(lispobj object)  static lispobj
2975    trans_code_header(lispobj object)
2976  {  {
2977          struct code *ncode;      struct code *ncode;
2978    
2979          ncode = trans_code((struct code *) PTR(object));      ncode = trans_code((struct code *) PTR(object));
2980          return (lispobj) ncode | type_OtherPointer;      return (lispobj) ncode | type_OtherPointer;
2981  }  }
2982    
2983  static int size_code_header(lispobj *where)  static int
2984    size_code_header(lispobj * where)
2985  {  {
2986          struct code *code;      struct code *code;
2987          int nheader_words, ncode_words, nwords;      int nheader_words, ncode_words, nwords;
2988    
2989          code = (struct code *) where;      code = (struct code *) where;
2990    
2991          ncode_words = fixnum_value(code->code_size);      ncode_words = fixnum_value(code->code_size);
2992          nheader_words = HeaderValue(code->header);      nheader_words = HeaderValue(code->header);
2993          nwords = ncode_words + nheader_words;      nwords = ncode_words + nheader_words;
2994          nwords = CEILING(nwords, 2);      nwords = CEILING(nwords, 2);
2995    
2996          return nwords;      return nwords;
2997  }  }
2998    
2999  #if !(defined(i386) || defined(__x86_64))  #if !(defined(i386) || defined(__x86_64))
3000    
3001  static int scav_return_pc_header(lispobj *where, lispobj object)  static int
3002    scav_return_pc_header(lispobj * where, lispobj object)
3003  {  {
3004      fprintf(stderr, "GC lossage.  Should not be scavenging a ");      fprintf(stderr, "GC lossage.  Should not be scavenging a ");
3005      fprintf(stderr, "Return PC Header.\n");      fprintf(stderr, "Return PC Header.\n");
# Line 2865  static int scav_return_pc_header(lispobj Line 3011  static int scav_return_pc_header(lispobj
3011    
3012  #endif /* not i386 */  #endif /* not i386 */
3013    
3014  static lispobj trans_return_pc_header(lispobj object)  static lispobj
3015    trans_return_pc_header(lispobj object)
3016  {  {
3017    struct function *return_pc;      struct function *return_pc;
3018    unsigned long offset;      unsigned long offset;
3019    struct code *code, *ncode;      struct code *code, *ncode;
3020    
3021    return_pc = (struct function *) PTR(object);      return_pc = (struct function *) PTR(object);
3022    offset = HeaderValue(return_pc->header) * sizeof(lispobj);      offset = HeaderValue(return_pc->header) * sizeof(lispobj);
3023    
3024    /* Transport the whole code object */      /* Transport the whole code object */
3025    code = (struct code *) ((unsigned long) return_pc - offset);      code = (struct code *) ((unsigned long) return_pc - offset);
   
   ncode = trans_code(code);  
3026    
3027    return ((lispobj) ncode + offset) | type_OtherPointer;      ncode = trans_code(code);
3028    
3029        return ((lispobj) ncode + offset) | type_OtherPointer;
3030  }  }
3031    
3032  /*  /*
# Line 2888  static lispobj trans_return_pc_header(li Line 3035  static lispobj trans_return_pc_header(li
3035   */   */
3036  #if defined(i386) || defined(__x86_64)  #if defined(i386) || defined(__x86_64)
3037    
3038  static int scav_closure_header(lispobj *where, lispobj object)  static int
3039    scav_closure_header(lispobj * where, lispobj object)
3040  {  {
3041    struct closure *closure;      struct closure *closure;
3042    lispobj fun;      lispobj fun;
3043    
3044    closure = (struct closure *)where;      closure = (struct closure *) where;
3045    fun = closure->function - RAW_ADDR_OFFSET;      fun = closure->function - RAW_ADDR_OFFSET;
3046    scavenge(&fun, 1);      scavenge(&fun, 1);
3047    /* The function may have moved so update the raw address. But don't      /* The function may have moved so update the raw address. But don't
3048       write unnecessarily. */         write unnecessarily. */
3049    if (closure->function != fun + RAW_ADDR_OFFSET)      if (closure->function != fun + RAW_ADDR_OFFSET)
3050      closure->function = fun + RAW_ADDR_OFFSET;          closure->function = fun + RAW_ADDR_OFFSET;
3051    
3052    return 2;      return 2;
3053  }  }
3054    
3055  #endif /* i386 */  #endif /* i386 */
3056    
3057  #if !(defined(i386) || defined(__x86_64))  #if !(defined(i386) || defined(__x86_64))
3058    
3059  static int scav_function_header(lispobj *where, lispobj object)  static int
3060    scav_function_header(lispobj * where, lispobj object)
3061  {  {
3062      fprintf(stderr, "GC lossage.  Should not be scavenging a ");      fprintf(stderr, "GC lossage.  Should not be scavenging a ");
3063      fprintf(stderr, "Function Header.\n");      fprintf(stderr, "Function Header.\n");
# Line 2920  static int scav_function_header(lispobj Line 3069  static int scav_function_header(lispobj
3069    
3070  #endif /* not i386 */  #endif /* not i386 */
3071    
3072  static lispobj trans_function_header(lispobj object)  static lispobj
3073    trans_function_header(lispobj object)
3074  {  {
3075    struct function *fheader;      struct function *fheader;
3076    unsigned long offset;      unsigned long offset;
3077    struct code *code, *ncode;      struct code *code, *ncode;
3078    
3079    fheader = (struct function *) PTR(object);      fheader = (struct function *) PTR(object);
3080    offset = HeaderValue(fheader->header) * sizeof(lispobj);      offset = HeaderValue(fheader->header) * sizeof(lispobj);
3081    
3082    /* Transport the whole code object */      /* Transport the whole code object */
3083    code = (struct code *) ((unsigned long) fheader - offset);      code = (struct code *) ((unsigned long) fheader - offset);
3084    ncode = trans_code(code);      ncode = trans_code(code);
3085    
3086    return ((lispobj) ncode + offset) | type_FunctionPointer;      return ((lispobj) ncode + offset) | type_FunctionPointer;
3087  }  }
   
3088    
3089    
3090  /* Instances */  /* Instances */
3091    
3092  #if DIRECT_SCAV  #if DIRECT_SCAV
3093  static int scav_instance_pointer(lispobj *where, lispobj object)  static int
3094    scav_instance_pointer(lispobj * where, lispobj object)
3095  {  {
3096    if (from_space_p(object)) {      if (from_space_p(object)) {
3097      lispobj first, *first_pointer;          lispobj first, *first_pointer;
3098    
3099      /*          /*
3100       * object is a pointer into from space.  check to see if it has           * object is a pointer into from space.  check to see if it has
3101       * been forwarded           * been forwarded
3102       */           */
3103      first_pointer = (lispobj *) PTR(object);          first_pointer = (lispobj *) PTR(object);
3104      first = *first_pointer;          first = *first_pointer;
3105    
3106      if (first == 0x01)          if (first == 0x01)
3107        /* Forwarded. */              /* Forwarded. */
3108        first = first_pointer[1];              first = first_pointer[1];
3109      else {          else {
3110        first = trans_boxed(object);              first = trans_boxed(object);
3111        gc_assert(first != object);              gc_assert(first != object);
3112        /* Set forwarding pointer */              /* Set forwarding pointer */
3113        first_pointer[0] = 0x01;              first_pointer[0] = 0x01;
3114        first_pointer[1] = first;              first_pointer[1] = first;
3115            }
3116            *where = first;
3117      }      }
3118      *where = first;      return 1;
   }  
   return 1;  
3119  }  }
3120  #else  #else
3121  static int scav_instance_pointer(lispobj *where, lispobj object)  static int
3122    scav_instance_pointer(lispobj * where, lispobj object)
3123  {  {
3124    lispobj copy, *first_pointer;      lispobj copy, *first_pointer;
3125    
3126    /* Object is a pointer into from space - not a FP */      /* Object is a pointer into from space - not a FP */
3127    copy = trans_boxed(object);      copy = trans_boxed(object);
3128    
3129    gc_assert(copy != object);      gc_assert(copy != object);
3130    
3131    first_pointer = (lispobj *) PTR(object);      first_pointer = (lispobj *) PTR(object);
3132    
3133    /* Set forwarding pointer. */      /* Set forwarding pointer. */
3134    first_pointer[0] = 0x01;      first_pointer[0] = 0x01;
3135    first_pointer[1] = copy;      first_pointer[1] = copy;
3136    *where = copy;      *where = copy;
3137    
3138    return 1;      return 1;
3139  }  }
3140  #endif  #endif
   
3141    
3142    
3143  /* Lists and Conses */  /* Lists and Conses */
3144    
3145  static lispobj trans_list(lispobj object);  static lispobj trans_list(lispobj object);
3146    
3147  #if DIRECT_SCAV  #if DIRECT_SCAV
3148  static int scav_list_pointer(lispobj *where, lispobj object)  static int
3149    scav_list_pointer(lispobj * where, lispobj object)
3150  {  {
3151    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
3152    
3153    if (from_space_p(object)) {      if (from_space_p(object)) {
3154      lispobj first, *first_pointer;          lispobj first, *first_pointer;
3155    
3156      /*          /*
3157       * Object is a pointer into from space - check to see if it has           * Object is a pointer into from space - check to see if it has
3158       * been forwarded.           * been forwarded.
3159       */           */
3160      first_pointer = (lispobj *) PTR(object);          first_pointer = (lispobj *) PTR(object);
3161      first = *first_pointer;          first = *first_pointer;
   
     if (first == 0x01)  
       /* Forwarded. */  
       first = first_pointer[1];  
     else {  
       first = trans_list(object);  
3162    
3163        /* Set forwarding pointer */          if (first == 0x01)
3164        first_pointer[0] = 0x01;              /* Forwarded. */
3165        first_pointer[1] = first;              first = first_pointer[1];
3166      }          else {
3167                first = trans_list(object);
3168    
3169                /* Set forwarding pointer */
3170                first_pointer[0] = 0x01;
3171                first_pointer[1] = first;
3172            }
3173    
3174      gc_assert(Pointerp(first));          gc_assert(Pointerp(first));
3175      gc_assert(!from_space_p(first));          gc_assert(!from_space_p(first));
3176      *where = first;          *where = first;
3177    }      }
3178    return 1;      return 1;
3179  }  }
3180  #else  #else
3181  static int scav_list_pointer(lispobj *where, lispobj object)  static int
3182    scav_list_pointer(lispobj * where, lispobj object)
3183  {  {
3184    lispobj first, *first_pointer;      lispobj first, *first_pointer;
3185    
3186    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
3187    
3188    /* Object is a pointer into from space - not FP */      /* Object is a pointer into from space - not FP */
3189    
3190    first = trans_list(object);      first = trans_list(object);
3191    gc_assert(first != object);      gc_assert(first != object);
3192    
3193    first_pointer = (lispobj *) PTR(object);      first_pointer = (lispobj *) PTR(object);
3194    
3195    /* Set forwarding pointer */      /* Set forwarding pointer */
3196    first_pointer[0] = 0x01;      first_pointer[0] = 0x01;
3197    first_pointer[1] = first;      first_pointer[1] = first;
3198    
3199    gc_assert(Pointerp(first));      gc_assert(Pointerp(first));
3200    gc_assert(!from_space_p(first));      gc_assert(!from_space_p(first));
3201    *where = first;      *where = first;
3202    return 1;      return 1;
3203  }  }
3204  #endif  #endif
3205    
3206  static lispobj trans_list(lispobj object)  static lispobj
3207    trans_list(lispobj object)
3208  {  {
3209    lispobj new_list_pointer;      lispobj new_list_pointer;
3210    struct cons *cons, *new_cons;      struct cons *cons, *new_cons;
3211    lispobj cdr;      lispobj cdr;
3212    
3213    gc_assert(from_space_p(object));      gc_assert(from_space_p(object));
3214    
3215    cons = (struct cons *) PTR(object);      cons = (struct cons *) PTR(object);
3216    
3217    /* copy 'object' */      /* copy 'object' */
3218    new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));      new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
   new_cons->car = cons->car;  
   new_cons->cdr = cons->cdr; /* updated later */  
   new_list_pointer = (lispobj) new_cons | LowtagOf(object);  
3219    
3220    /* Grab the cdr before it is clobbered */      new_cons->car = cons->car;
3221    cdr = cons->cdr;      new_cons->cdr = cons->cdr;  /* updated later */
3222        new_list_pointer = (lispobj) new_cons | LowtagOf(object);
3223    
3224    /* Set forwarding pointer (clobbers start of list). */      /* Grab the cdr before it is clobbered */
3225    cons->car = 0x01;      cdr = cons->cdr;
   cons->cdr = new_list_pointer;  
3226    
3227    /* Try to linearize the list in the cdr direction to help reduce paging. */      /* Set forwarding pointer (clobbers start of list). */
3228    while (1) {      cons->car = 0x01;
3229      lispobj  new_cdr;      cons->cdr = new_list_pointer;
3230      struct cons *cdr_cons, *new_cdr_cons;  
3231        /* Try to linearize the list in the cdr direction to help reduce paging. */
3232        while (1) {
3233            lispobj new_cdr;
3234            struct cons *cdr_cons, *new_cdr_cons;
3235    
3236      if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)          if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
3237          || *((lispobj *) PTR(cdr)) == 0x01)              || *((lispobj *) PTR(cdr)) == 0x01)
3238        break;              break;
3239    
3240      cdr_cons = (struct cons *) PTR(cdr);          cdr_cons = (struct cons *) PTR(cdr);
3241    
3242      /* copy 'cdr' */          /* copy 'cdr' */
3243      new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));          new_cdr_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
     new_cdr_cons->car = cdr_cons->car;  
     new_cdr_cons->cdr = cdr_cons->cdr;  
     new_cdr = (lispobj) new_cdr_cons | LowtagOf(cdr);  
3244    
3245      /* Grab the cdr before it is clobbered */          new_cdr_cons->car = cdr_cons->car;
3246      cdr = cdr_cons->cdr;          new_cdr_cons->cdr = cdr_cons->cdr;
3247            new_cdr = (lispobj) new_cdr_cons | LowtagOf(cdr);
3248    
3249      /* Set forwarding pointer */          /* Grab the cdr before it is clobbered */
3250      cdr_cons->car = 0x01;          cdr = cdr_cons->cdr;
     cdr_cons->cdr = new_cdr;  
3251    
3252      /*          /* Set forwarding pointer */
3253       * Update the cdr of the last cons copied into new space to keep          cdr_cons->car = 0x01;
3254       * the newspace scavenge from having to do it.          cdr_cons->cdr = new_cdr;
      */  
     new_cons->cdr = new_cdr;  
3255    
3256      new_cons = new_cdr_cons;          /*
3257    }           * Update the cdr of the last cons copied into new space to keep
3258             * the newspace scavenge from having to do it.
3259             */
3260            new_cons->cdr = new_cdr;
3261    
3262    return new_list_pointer;          new_cons = new_cdr_cons;
3263  }      }
3264    
3265        return new_list_pointer;
3266    }
3267    
3268    
3269  /* Scavenging and Transporting Other Pointers */  /* Scavenging and Transporting Other Pointers */
3270    
3271  #if DIRECT_SCAV  #if DIRECT_SCAV
3272  static int scav_other_pointer(lispobj *where, lispobj object)  static int
3273    scav_other_pointer(lispobj * where, lispobj object)
3274  {  {
3275    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
3276    
3277        if (from_space_p(object)) {
3278            lispobj first, *first_pointer;
3279    
3280            /*
3281             * Object is a pointer into from space.  check to see if it has
3282             * been forwarded.
3283             */
3284            first_pointer = (lispobj *) PTR(object);
3285            first = *first_pointer;
3286    
3287            if (first == 0x01) {
3288                /* Forwarded. */
3289                first = first_pointer[1];
3290                *where = first;
3291            } else {
3292                first = (transother[TypeOf(first)]) (object);
3293    
3294                if (first != object) {
3295                    /* Set forwarding pointer */
3296                    first_pointer[0] = 0x01;
3297                    first_pointer[1] = first;
3298                    *where = first;
3299                }
3300            }
3301    
3302    if (from_space_p(object)) {          gc_assert(Pointerp(first));
3303            gc_assert(!from_space_p(first));
3304        }
3305        return 1;
3306    }
3307    #else
3308    static int
3309    scav_other_pointer(lispobj * where, lispobj object)
3310    {
3311      lispobj first, *first_pointer;      lispobj first, *first_pointer;
3312    
3313      /*      gc_assert(Pointerp(object));
3314       * Object is a pointer into from space.  check to see if it has  
3315       * been forwarded.      /* Object is a pointer into from space - not FP */
      */  
3316      first_pointer = (lispobj *) PTR(object);      first_pointer = (lispobj *) PTR(object);
     first = *first_pointer;  
3317    
3318      if (first == 0x01) {      first = (transother[TypeOf(*first_pointer)]) (object);
       /* Forwarded. */  
       first = first_pointer[1];  
       *where = first;  
     } else {  
       first = (transother[TypeOf(first)])(object);  
3319    
3320        if (first != object) {      if (first != object) {
3321          /* Set forwarding pointer */          /* Set forwarding pointer */
3322          first_pointer[0] = 0x01;          first_pointer[0] = 0x01;
3323          first_pointer[1] = first;          first_pointer[1] = first;
3324          *where = first;          *where = first;
       }  
3325      }      }
3326    
3327      gc_assert(Pointerp(first));      gc_assert(Pointerp(first));
3328      gc_assert(!from_space_p(first));      gc_assert(!from_space_p(first));
   }  
   return 1;  
 }  
 #else  
 static int scav_other_pointer(lispobj *where, lispobj object)  
 {  
   lispobj first, *first_pointer;  
   
   gc_assert(Pointerp(object));  
3329    
3330    /* Object is a pointer into from space - not FP */      return 1;
   first_pointer = (lispobj *) PTR(object);  
   
   first = (transother[TypeOf(*first_pointer)])(object);  
   
   if (first != object) {  
     /* Set forwarding pointer */  
     first_pointer[0] = 0x01;  
     first_pointer[1] = first;  
     *where = first;  
   }  
   
   gc_assert(Pointerp(first));  
   gc_assert(!from_space_p(first));  
   
   return 1;  
3331  }  }
3332  #endif  #endif
   
3333    
3334    
3335  /* Immediate, Boxed, and Unboxed Objects */  /* Immediate, Boxed, and Unboxed Objects */
3336    
3337  static int size_pointer(lispobj *where)  static int
3338    size_pointer(lispobj * where)
3339  {  {
3340      return 1;      return 1;
3341  }  }
3342    
3343  static int scav_immediate(lispobj *where, lispobj object)  static int
3344    scav_immediate(lispobj * where, lispobj object)
3345  {  {
3346      return 1;      return 1;
3347  }  }
3348    
3349  static lispobj trans_immediate(lispobj object)  static lispobj
3350    trans_immediate(lispobj object)
3351  {  {
3352      fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");      fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
3353      lose(NULL);      lose(NULL);
3354      return NIL;      return NIL;
3355  }  }
3356    
3357  static int size_immediate(lispobj *where)  static int
3358    size_immediate(lispobj * where)
3359  {  {
3360      return 1;      return 1;
3361  }  }
3362    
3363    
3364  static int scav_boxed(lispobj *where, lispobj object)  static int
3365    scav_boxed(lispobj * where, lispobj object)
3366  {  {
3367      return 1;      return 1;
3368  }  }
3369    
3370  static lispobj trans_boxed(lispobj object)  static lispobj
3371    trans_boxed(lispobj object)
3372  {  {
3373    lispobj header;      lispobj header;
3374    unsigned long length;      unsigned long length;
3375    
3376    gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
3377    
3378    header = *((lispobj *) PTR(object));      header = *((lispobj *) PTR(object));
3379    length = HeaderValue(header) + 1;      length = HeaderValue(header) + 1;
3380    length = CEILING(length, 2);      length = CEILING(length, 2);
3381    
3382    return copy_object(object, length);      return copy_object(object, length);
3383  }  }
3384    
3385  static lispobj trans_boxed_large(lispobj object)  static lispobj
3386    trans_boxed_large(lispobj object)
3387  {  {
3388          lispobj header;      lispobj header;
3389          unsigned long length;      unsigned long length;
3390    
3391          gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
3392    
3393          header = *((lispobj *) PTR(object));      header = *((lispobj *) PTR(object));
3394          length = HeaderValue(header) + 1;      length = HeaderValue(header) + 1;
3395          length = CEILING(length, 2);      length = CEILING(length, 2);
3396    
3397          return copy_large_object(object, length);      return copy_large_object(object, length);
3398  }  }
3399    
3400  static int size_boxed(lispobj *where)  static int
3401    size_boxed(lispobj * where)
3402  {  {
3403          lispobj header;      lispobj header;
3404          unsigned long length;      unsigned long length;
3405    
3406          header = *where;      header = *where;
3407          length = HeaderValue(header) + 1;      length = HeaderValue(header) + 1;
3408          length = CEILING(length, 2);      length = CEILING(length, 2);
3409    
3410          return length;      return length;
3411  }  }
3412    
3413  /* Not needed on sparc because the raw_addr has a function lowtag */  /* Not needed on sparc and ppc because the raw_addr has a function lowtag */
3414  #ifndef sparc  #if !(defined(sparc) || defined(DARWIN))
3415  static int scav_fdefn(lispobj *where, lispobj object)  static int
3416    scav_fdefn(lispobj * where, lispobj object)
3417  {  {
3418    struct fdefn *fdefn;      struct fdefn *fdefn;
3419    
3420    fdefn = (struct fdefn *)where;      fdefn = (struct fdefn *) where;
3421    
3422    if ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {      if ((char *) (fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
3423      scavenge(where + 1, sizeof(struct fdefn) / sizeof(lispobj) - 1);          scavenge(where + 1, sizeof(struct fdefn) / sizeof(lispobj) - 1);
3424    
3425      /* Don't write unnecessarily */          /* Don't write unnecessarily */
3426      if (fdefn->raw_addr != (char *)(fdefn->function + RAW_ADDR_OFFSET))          if (fdefn->raw_addr != (char *) (fdefn->function + RAW_ADDR_OFFSET))
3427        fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);              fdefn->raw_addr = (char *) (fdefn->function + RAW_ADDR_OFFSET);
3428    
3429      return sizeof(struct fdefn) / sizeof(lispobj);          return sizeof(struct fdefn) / sizeof(lispobj);
3430    }      } else
3431    else          return 1;
     return 1;  
3432  }  }
3433  #endif  #endif
3434    
3435  static int scav_unboxed(lispobj *where, lispobj object)  static int
3436    scav_unboxed(lispobj * where, lispobj object)
3437  {  {
3438          unsigned long length;      unsigned long length;
3439    
3440          length = HeaderValue(object) + 1;      length = HeaderValue(object) + 1;
3441          length = CEILING(length, 2);      length = CEILING(length, 2);
3442    
3443          return length;      return length;
3444  }  }
3445    
3446  static lispobj trans_unboxed(lispobj object)  static lispobj
3447    trans_unboxed(lispobj object)
3448  {  {
3449          lispobj header;      lispobj header;
3450          unsigned long length;      unsigned long length;
3451    
3452    
3453          gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
3454    
3455          header = *((lispobj *) PTR(object));      header = *((lispobj *) PTR(object));
3456          length = HeaderValue(header) + 1;      length = HeaderValue(header) + 1;
3457          length = CEILING(length, 2);      length = CEILING(length, 2);
3458    
3459          return copy_unboxed_object(object, length);      return copy_unboxed_object(object, length);
3460  }  }
3461    
3462  static lispobj trans_unboxed_large(lispobj object)  static lispobj
3463    trans_unboxed_large(lispobj object)
3464  {  {
3465          lispobj header;      lispobj header;
3466          unsigned long length;      unsigned long length;
3467    
3468    
3469          gc_assert(Pointerp(object));      gc_assert(Pointerp(object));
3470    
3471          header = *((lispobj *) PTR(object));      header = *((lispobj *) PTR(object));
3472          length = HeaderValue(header) + 1;      length = HeaderValue(header) + 1;
3473          length = CEILING(length, 2);      length = CEILING(length, 2);
3474    
3475          return copy_large_unboxed_object(object, length);      return copy_large_unboxed_object(object, length);
3476  }  }
3477    
3478  static int size_unboxed(lispobj *where)  static int
3479    size_unboxed(lispobj * where)
3480  {  {
3481          lispobj header;      lispobj header;
3482          unsigned long length;      unsigned long length;
3483    
3484          header = *where;      header = *where;
3485          length = HeaderValue(header) + 1;      length = HeaderValue(header) + 1;
3486          length = CEILING(length, 2);      length = CEILING(length, 2);
3487    
3488          return length;      return length;
3489  }  }
   
3490    
3491    
3492  /* Vector-Like Objects */  /* Vector-Like Objects */
3493    
3494  #define NWORDS(x,y) (CEILING((x),(y)) / (y))  #define NWORDS(x,y) (CEILING((x),(y)) / (y))
3495    
3496  static int size_string(lispobj *where)  static int
3497    size_string(lispobj * where)
3498  {  {
3499          struct vector *vector;      struct vector *vector;
3500          int length, nwords;      int length, nwords;
3501    
3502          /*      /*
3503           * NOTE: Strings contain one more byte of data than the length       * NOTE: Strings contain one more byte of data than the length
3504           * slot indicates.       * slot indicates.
3505           */       */
3506    
3507          vector = (struct vector *) where;      vector = (struct vector *) where;
3508          length = fixnum_value(vector->length) + 1;      length = fixnum_value(vector->length) + 1;
3509  #ifdef __x86_64  #ifdef __x86_64
3510          nwords = CEILING(NWORDS(length, 8) + 2, 2);      nwords = CEILING(NWORDS(length, 8) + 2, 2);
3511  #else  #else
3512          nwords = CEILING(NWORDS(length, 4) + 2, 2);      nwords = CEILING(NWORDS(length, 4) + 2, 2);
3513  #endif  #endif
3514          return nwords;      return nwords;
3515  }  }
3516    
3517  static int scav_string(lispobj *where, lispobj object)  static int
3518    scav_string(lispobj * where, lispobj object)
3519  {  {
3520          return size_string(where);      return size_string(where);
3521  }  }
3522    
3523  static lispobj trans_string(lispobj object)  static lispobj
3524