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