0.8.5.47:
[sbcl.git] / src / runtime / purify.c
1 /*
2  * C-level stuff to implement Lisp-level PURIFY
3  */
4
5 /*
6  * This software is part of the SBCL system. See the README file for
7  * more information.
8  *
9  * This software is derived from the CMU CL system, which was
10  * written at Carnegie Mellon University and released into the
11  * public domain. The software is in the public domain and is
12  * provided with absolutely no warranty. See the COPYING and CREDITS
13  * files for more information.
14  */
15
16 #include <stdio.h>
17 #include <sys/types.h>
18 #include <stdlib.h>
19 #include <strings.h>
20 #if (defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_LINUX))
21 #include <sys/ptrace.h>
22 #include <linux/user.h>
23 #endif
24 #include <errno.h>
25
26 #include "runtime.h"
27 #include "os.h"
28 #include "sbcl.h"
29 #include "globals.h"
30 #include "validate.h"
31 #include "interrupt.h"
32 #include "purify.h"
33 #include "interr.h"
34 #include "gc.h"
35 #include "gc-internal.h"
36 #include "thread.h"
37 #include "genesis/primitive-objects.h"
38 #include "genesis/static-symbols.h"
39
40 #define PRINTNOISE
41
42 #if defined(LISP_FEATURE_X86)
43 /* again, what's so special about the x86 that this is differently
44  * visible there than on other platforms? -dan 20010125 
45  */
46 static lispobj *dynamic_space_free_pointer;
47 #endif
48 extern unsigned long bytes_consed_between_gcs;
49
50 #define gc_abort() \
51   lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__)
52
53 #if 1
54 #define gc_assert(ex) do { \
55         if (!(ex)) gc_abort(); \
56 } while (0)
57 #else
58 #define gc_assert(ex)
59 #endif
60
61 \f
62 /* These hold the original end of the read_only and static spaces so
63  * we can tell what are forwarding pointers. */
64
65 static lispobj *read_only_end, *static_end;
66
67 static lispobj *read_only_free, *static_free;
68
69 static lispobj *pscav(lispobj *addr, int nwords, boolean constant);
70
71 #define LATERBLOCKSIZE 1020
72 #define LATERMAXCOUNT 10
73
74 static struct
75 later {
76     struct later *next;
77     union {
78         lispobj *ptr;
79         int count;
80     } u[LATERBLOCKSIZE];
81 } *later_blocks = NULL;
82 static int later_count = 0;
83
84 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
85 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
86
87 /* FIXME: Shouldn't this be defined in sbcl.h?  See also notes in
88  * cheneygc.c */
89
90 #ifdef sparc
91 #define FUN_RAW_ADDR_OFFSET 0
92 #else
93 #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
94 #endif
95 \f
96 static boolean
97 forwarding_pointer_p(lispobj obj)
98 {
99     lispobj *ptr = native_pointer(obj);
100
101     return ((static_end <= ptr && ptr <= static_free) ||
102             (read_only_end <= ptr && ptr <= read_only_free));
103 }
104
105 static boolean
106 dynamic_pointer_p(lispobj ptr)
107 {
108 #ifndef LISP_FEATURE_X86
109     return (ptr >= (lispobj)current_dynamic_space
110             &&
111             ptr < (lispobj)dynamic_space_free_pointer);
112 #else
113     /* Be more conservative, and remember, this is a maybe. */
114     return (ptr >= (lispobj)DYNAMIC_SPACE_START
115             &&
116             ptr < (lispobj)dynamic_space_free_pointer);
117 #endif
118 }
119
120 \f
121 #ifdef LISP_FEATURE_X86
122
123 #ifdef LISP_FEATURE_GENCGC
124 /*
125  * enhanced x86/GENCGC stack scavenging by Douglas Crosher
126  *
127  * Scavenging the stack on the i386 is problematic due to conservative
128  * roots and raw return addresses. Here it is handled in two passes:
129  * the first pass runs before any objects are moved and tries to
130  * identify valid pointers and return address on the stack, the second
131  * pass scavenges these.
132  */
133
134 static unsigned pointer_filter_verbose = 0;
135
136 /* FIXME: This is substantially the same code as
137  * possibly_valid_dynamic_space_pointer in gencgc.c.  The only
138  * relevant difference seems to be that the gencgc code also checks
139  * for raw pointers into Code objects */
140
141 static int
142 valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
143 {
144     /* If it's not a return address then it needs to be a valid Lisp
145      * pointer. */
146     if (!is_lisp_pointer((lispobj)pointer))
147         return 0;
148
149     /* Check that the object pointed to is consistent with the pointer
150      * low tag. */
151     switch (lowtag_of((lispobj)pointer)) {
152     case FUN_POINTER_LOWTAG:
153         /* Start_addr should be the enclosing code object, or a closure
154          * header. */
155         switch (widetag_of(*start_addr)) {
156         case CODE_HEADER_WIDETAG:
157             /* This case is probably caught above. */
158             break;
159         case CLOSURE_HEADER_WIDETAG:
160         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
161             if ((int)pointer != ((int)start_addr+FUN_POINTER_LOWTAG)) {
162                 if (pointer_filter_verbose) {
163                     fprintf(stderr,"*Wf2: %x %x %x\n", (unsigned int) pointer, 
164                             (unsigned int) start_addr, *start_addr);
165                 }
166                 return 0;
167             }
168             break;
169         default:
170             if (pointer_filter_verbose) {
171                 fprintf(stderr,"*Wf3: %x %x %x\n", (unsigned int) pointer, 
172                         (unsigned int) start_addr, *start_addr);
173             }
174             return 0;
175         }
176         break;
177     case LIST_POINTER_LOWTAG:
178         if ((int)pointer != ((int)start_addr+LIST_POINTER_LOWTAG)) {
179             if (pointer_filter_verbose)
180                 fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned int) pointer, 
181                         (unsigned int) start_addr, *start_addr);
182             return 0;
183         }
184         /* Is it plausible cons? */
185         if ((is_lisp_pointer(start_addr[0])
186             || ((start_addr[0] & 3) == 0) /* fixnum */
187             || (widetag_of(start_addr[0]) == BASE_CHAR_WIDETAG)
188             || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG))
189            && (is_lisp_pointer(start_addr[1])
190                || ((start_addr[1] & 3) == 0) /* fixnum */
191                || (widetag_of(start_addr[1]) == BASE_CHAR_WIDETAG)
192                || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG))) {
193             break;
194         } else {
195             if (pointer_filter_verbose) {
196                 fprintf(stderr,"*Wl2: %x %x %x\n", (unsigned int) pointer, 
197                         (unsigned int) start_addr, *start_addr);
198             }
199             return 0;
200         }
201     case INSTANCE_POINTER_LOWTAG:
202         if ((int)pointer != ((int)start_addr+INSTANCE_POINTER_LOWTAG)) {
203             if (pointer_filter_verbose) {
204                 fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned int) pointer, 
205                         (unsigned int) start_addr, *start_addr);
206             }
207             return 0;
208         }
209         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
210             if (pointer_filter_verbose) {
211                 fprintf(stderr,"*Wi2: %x %x %x\n", (unsigned int) pointer, 
212                         (unsigned int) start_addr, *start_addr);
213             }
214             return 0;
215         }
216         break;
217     case OTHER_POINTER_LOWTAG:
218         if ((int)pointer != ((int)start_addr+OTHER_POINTER_LOWTAG)) {
219             if (pointer_filter_verbose) {
220                 fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned int) pointer, 
221                         (unsigned int) start_addr, *start_addr);
222             }
223             return 0;
224         }
225         /* Is it plausible? Not a cons. XXX should check the headers. */
226         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
227             if (pointer_filter_verbose) {
228                 fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer, 
229                         (unsigned int) start_addr, *start_addr);
230             }
231             return 0;
232         }
233         switch (widetag_of(start_addr[0])) {
234         case UNBOUND_MARKER_WIDETAG:
235         case BASE_CHAR_WIDETAG:
236             if (pointer_filter_verbose) {
237                 fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned int) pointer, 
238                         (unsigned int) start_addr, *start_addr);
239             }
240             return 0;
241
242             /* only pointed to by function pointers? */
243         case CLOSURE_HEADER_WIDETAG:
244         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
245             if (pointer_filter_verbose) {
246                 fprintf(stderr,"*Wo4: %x %x %x\n", (unsigned int) pointer, 
247                         (unsigned int) start_addr, *start_addr);
248             }
249             return 0;
250
251         case INSTANCE_HEADER_WIDETAG:
252             if (pointer_filter_verbose) {
253                 fprintf(stderr,"*Wo5: %x %x %x\n", (unsigned int) pointer, 
254                         (unsigned int) start_addr, *start_addr);
255             }
256             return 0;
257
258             /* the valid other immediate pointer objects */
259         case SIMPLE_VECTOR_WIDETAG:
260         case RATIO_WIDETAG:
261         case COMPLEX_WIDETAG:
262 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
263         case COMPLEX_SINGLE_FLOAT_WIDETAG:
264 #endif
265 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
266         case COMPLEX_DOUBLE_FLOAT_WIDETAG:
267 #endif
268 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
269         case COMPLEX_LONG_FLOAT_WIDETAG:
270 #endif
271         case SIMPLE_ARRAY_WIDETAG:
272         case COMPLEX_BASE_STRING_WIDETAG:
273         case COMPLEX_VECTOR_NIL_WIDETAG:
274         case COMPLEX_BIT_VECTOR_WIDETAG:
275         case COMPLEX_VECTOR_WIDETAG:
276         case COMPLEX_ARRAY_WIDETAG:
277         case VALUE_CELL_HEADER_WIDETAG:
278         case SYMBOL_HEADER_WIDETAG:
279         case FDEFN_WIDETAG:
280         case CODE_HEADER_WIDETAG:
281         case BIGNUM_WIDETAG:
282         case SINGLE_FLOAT_WIDETAG:
283         case DOUBLE_FLOAT_WIDETAG:
284 #ifdef LONG_FLOAT_WIDETAG
285         case LONG_FLOAT_WIDETAG:
286 #endif
287         case SIMPLE_ARRAY_NIL_WIDETAG:
288         case SIMPLE_BASE_STRING_WIDETAG:
289         case SIMPLE_BIT_VECTOR_WIDETAG:
290         case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
291         case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
292         case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
293         case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
294         case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
295         case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
296         case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
297         case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
298         case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
299 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
300         case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
301 #endif
302 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
303         case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
304 #endif
305 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
306         case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
307 #endif
308 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
309         case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
310 #endif
311         case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
312         case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
313 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
314         case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
315 #endif
316 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
317         case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
318 #endif
319 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
320         case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
321 #endif
322 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
323         case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
324 #endif
325         case SAP_WIDETAG:
326         case WEAK_POINTER_WIDETAG:
327             break;
328
329         default:
330             if (pointer_filter_verbose) {
331                 fprintf(stderr,"*Wo6: %x %x %x\n", (unsigned int) pointer, 
332                         (unsigned int) start_addr, *start_addr);
333             }
334             return 0;
335         }
336         break;
337     default:
338         if (pointer_filter_verbose) {
339             fprintf(stderr,"*W?: %x %x %x\n", (unsigned int) pointer, 
340                     (unsigned int) start_addr, *start_addr);
341         }
342         return 0;
343     }
344
345     /* looks good */
346     return 1;
347 }
348
349 #define MAX_STACK_POINTERS 256
350 lispobj *valid_stack_locations[MAX_STACK_POINTERS];
351 unsigned int num_valid_stack_locations;
352
353 #define MAX_STACK_RETURN_ADDRESSES 128
354 lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
355 lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
356 unsigned int num_valid_stack_ra_locations;
357
358 /* Identify valid stack slots. */
359 static void
360 setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
361 {
362     lispobj *sp = lowaddr;
363     num_valid_stack_locations = 0;
364     num_valid_stack_ra_locations = 0;
365     for (sp = lowaddr; sp < base; sp++) {
366         lispobj thing = *sp;
367         /* Find the object start address */
368         lispobj *start_addr = search_dynamic_space((void *)thing);
369         if (start_addr) {
370             /* We need to allow raw pointers into Code objects for
371              * return addresses. This will also pick up pointers to
372              * functions in code objects. */
373             if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
374                 /* FIXME asserting here is a really dumb thing to do.
375                  * If we've overflowed some arbitrary static limit, we
376                  * should just refuse to purify, instead of killing
377                  * the whole lisp session
378                  */
379                 gc_assert(num_valid_stack_ra_locations <
380                           MAX_STACK_RETURN_ADDRESSES);
381                 valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
382                 valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
383                     (lispobj *)((int)start_addr + OTHER_POINTER_LOWTAG);
384             } else {
385                 if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
386                     gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
387                     valid_stack_locations[num_valid_stack_locations++] = sp;
388                 }
389             }
390         }
391     }
392     if (pointer_filter_verbose) {
393         fprintf(stderr, "number of valid stack pointers = %d\n",
394                 num_valid_stack_locations);
395         fprintf(stderr, "number of stack return addresses = %d\n",
396                 num_valid_stack_ra_locations);
397     }
398 }
399
400 static void
401 pscav_i386_stack(void)
402 {
403     int i;
404
405     for (i = 0; i < num_valid_stack_locations; i++)
406         pscav(valid_stack_locations[i], 1, 0);
407
408     for (i = 0; i < num_valid_stack_ra_locations; i++) {
409         lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
410         pscav(&code_obj, 1, 0);
411         if (pointer_filter_verbose) {
412             fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
413                     *valid_stack_ra_locations[i],
414                     (int)(*valid_stack_ra_locations[i])
415                     - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
416                     (unsigned int) valid_stack_ra_code_objects[i], code_obj);
417         }
418         *valid_stack_ra_locations[i] =
419             ((int)(*valid_stack_ra_locations[i])
420              - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
421     }
422 }
423 #endif
424 #endif
425
426 \f
427 static void
428 pscav_later(lispobj *where, int count)
429 {
430     struct later *new;
431
432     if (count > LATERMAXCOUNT) {
433         while (count > LATERMAXCOUNT) {
434             pscav_later(where, LATERMAXCOUNT);
435             count -= LATERMAXCOUNT;
436             where += LATERMAXCOUNT;
437         }
438     }
439     else {
440         if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
441             (later_count == LATERBLOCKSIZE-1 && count > 1)) {
442             new  = (struct later *)malloc(sizeof(struct later));
443             new->next = later_blocks;
444             if (later_blocks && later_count < LATERBLOCKSIZE)
445                 later_blocks->u[later_count].ptr = NULL;
446             later_blocks = new;
447             later_count = 0;
448         }
449
450         if (count != 1)
451             later_blocks->u[later_count++].count = count;
452         later_blocks->u[later_count++].ptr = where;
453     }
454 }
455
456 static lispobj
457 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
458 {
459     int nwords;
460     lispobj result, *new, *old;
461
462     nwords = 1 + HeaderValue(header);
463
464     /* Allocate it */
465     old = (lispobj *)native_pointer(thing);
466     if (constant) {
467         new = read_only_free;
468         read_only_free += CEILING(nwords, 2);
469     }
470     else {
471         new = static_free;
472         static_free += CEILING(nwords, 2);
473     }
474
475     /* Copy it. */
476     bcopy(old, new, nwords * sizeof(lispobj));
477
478     /* Deposit forwarding pointer. */
479     result = make_lispobj(new, lowtag_of(thing));
480     *old = result;
481
482     /* Scavenge it. */
483     pscav(new, nwords, constant);
484
485     return result;
486 }
487
488 /* We need to look at the layout to see whether it is a pure structure
489  * class, and only then can we transport as constant. If it is pure,
490  * we can ALWAYS transport as a constant. */
491 static lispobj
492 ptrans_instance(lispobj thing, lispobj header, boolean constant)
493 {
494     lispobj layout = ((struct instance *)native_pointer(thing))->slots[0];
495     lispobj pure = ((struct instance *)native_pointer(layout))->slots[15];
496
497     switch (pure) {
498     case T:
499         return (ptrans_boxed(thing, header, 1));
500     case NIL:
501         return (ptrans_boxed(thing, header, 0));
502     case 0:
503         {
504             /* Substructure: special case for the COMPACT-INFO-ENVs,
505              * where the instance may have a point to the dynamic
506              * space placed into it (e.g. the cache-name slot), but
507              * the lists and arrays at the time of a purify can be
508              * moved to the RO space. */
509             int nwords;
510             lispobj result, *new, *old;
511
512             nwords = 1 + HeaderValue(header);
513
514             /* Allocate it */
515             old = (lispobj *)native_pointer(thing);
516             new = static_free;
517             static_free += CEILING(nwords, 2);
518
519             /* Copy it. */
520             bcopy(old, new, nwords * sizeof(lispobj));
521
522             /* Deposit forwarding pointer. */
523             result = make_lispobj(new, lowtag_of(thing));
524             *old = result;
525
526             /* Scavenge it. */
527             pscav(new, nwords, 1);
528
529             return result;
530         }
531     default:
532         gc_abort();
533         return NIL; /* dummy value: return something ... */
534     }
535 }
536
537 static lispobj
538 ptrans_fdefn(lispobj thing, lispobj header)
539 {
540     int nwords;
541     lispobj result, *new, *old, oldfn;
542     struct fdefn *fdefn;
543
544     nwords = 1 + HeaderValue(header);
545
546     /* Allocate it */
547     old = (lispobj *)native_pointer(thing);
548     new = static_free;
549     static_free += CEILING(nwords, 2);
550
551     /* Copy it. */
552     bcopy(old, new, nwords * sizeof(lispobj));
553
554     /* Deposit forwarding pointer. */
555     result = make_lispobj(new, lowtag_of(thing));
556     *old = result;
557
558     /* Scavenge the function. */
559     fdefn = (struct fdefn *)new;
560     oldfn = fdefn->fun;
561     pscav(&fdefn->fun, 1, 0);
562     if ((char *)oldfn + FUN_RAW_ADDR_OFFSET == fdefn->raw_addr)
563         fdefn->raw_addr = (char *)fdefn->fun + FUN_RAW_ADDR_OFFSET;
564
565     return result;
566 }
567
568 static lispobj
569 ptrans_unboxed(lispobj thing, lispobj header)
570 {
571     int nwords;
572     lispobj result, *new, *old;
573     
574     nwords = 1 + HeaderValue(header);
575     
576     /* Allocate it */
577     old = (lispobj *)native_pointer(thing);
578     new = read_only_free;
579     read_only_free += CEILING(nwords, 2);
580     
581     /* Copy it. */
582     bcopy(old, new, nwords * sizeof(lispobj));
583     
584     /* Deposit forwarding pointer. */
585     result = make_lispobj(new , lowtag_of(thing));
586     *old = result;
587
588     return result;
589 }
590
591 static lispobj
592 ptrans_vector(lispobj thing, int bits, int extra,
593               boolean boxed, boolean constant)
594 {
595     struct vector *vector;
596     int nwords;
597     lispobj result, *new;
598
599     vector = (struct vector *)native_pointer(thing);
600     nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5);
601
602     if (boxed && !constant) {
603         new = static_free;
604         static_free += CEILING(nwords, 2);
605     }
606     else {
607         new = read_only_free;
608         read_only_free += CEILING(nwords, 2);
609     }
610
611     bcopy(vector, new, nwords * sizeof(lispobj));
612
613     result = make_lispobj(new, lowtag_of(thing));
614     vector->header = result;
615
616     if (boxed)
617         pscav(new, nwords, constant);
618
619     return result;
620 }
621
622 #ifdef LISP_FEATURE_X86
623 static void
624 apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
625 {
626     int nheader_words, ncode_words, nwords;
627     void  *constants_start_addr, *constants_end_addr;
628     void  *code_start_addr, *code_end_addr;
629     lispobj fixups = NIL;
630     unsigned  displacement = (unsigned)new_code - (unsigned)old_code;
631     struct vector *fixups_vector;
632
633     ncode_words = fixnum_value(new_code->code_size);
634     nheader_words = HeaderValue(*(lispobj *)new_code);
635     nwords = ncode_words + nheader_words;
636
637     constants_start_addr = (void *)new_code + 5*4;
638     constants_end_addr = (void *)new_code + nheader_words*4;
639     code_start_addr = (void *)new_code + nheader_words*4;
640     code_end_addr = (void *)new_code + nwords*4;
641
642     /* The first constant should be a pointer to the fixups for this
643      * code objects. Check. */
644     fixups = new_code->constants[0];
645
646     /* It will be 0 or the unbound-marker if there are no fixups, and
647      * will be an other-pointer to a vector if it is valid. */
648     if ((fixups==0) ||
649         (fixups==UNBOUND_MARKER_WIDETAG) ||
650         !is_lisp_pointer(fixups)) {
651 #ifdef LISP_FEATURE_GENCGC
652         /* Check for a possible errors. */
653         sniff_code_object(new_code,displacement);
654 #endif
655         return;
656     }
657
658     fixups_vector = (struct vector *)native_pointer(fixups);
659
660     /* Could be pointing to a forwarding pointer. */
661     if (is_lisp_pointer(fixups) && (dynamic_pointer_p(fixups))
662         && forwarding_pointer_p(*(lispobj *)fixups_vector)) {
663         /* If so then follow it. */
664         fixups_vector =
665             (struct vector *)native_pointer(*(lispobj *)fixups_vector);
666     }
667
668     if (widetag_of(fixups_vector->header) ==
669         SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG) {
670         /* We got the fixups for the code block. Now work through the
671          * vector, and apply a fixup at each address. */
672         int length = fixnum_value(fixups_vector->length);
673         int i;
674         for (i=0; i<length; i++) {
675             unsigned offset = fixups_vector->data[i];
676             /* Now check the current value of offset. */
677             unsigned old_value =
678                 *(unsigned *)((unsigned)code_start_addr + offset);
679
680             /* If it's within the old_code object then it must be an
681              * absolute fixup (relative ones are not saved) */
682             if ((old_value>=(unsigned)old_code)
683                 && (old_value<((unsigned)old_code + nwords*4)))
684                 /* So add the dispacement. */
685                 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
686                     + displacement;
687             else
688                 /* It is outside the old code object so it must be a relative
689                  * fixup (absolute fixups are not saved). So subtract the
690                  * displacement. */
691                 *(unsigned *)((unsigned)code_start_addr + offset) = old_value
692                     - displacement;
693         }
694     }
695
696     /* No longer need the fixups. */
697     new_code->constants[0] = 0;
698
699 #ifdef LISP_FEATURE_GENCGC
700     /* Check for possible errors. */
701     sniff_code_object(new_code,displacement);
702 #endif
703 }
704 #endif
705
706 static lispobj
707 ptrans_code(lispobj thing)
708 {
709     struct code *code, *new;
710     int nwords;
711     lispobj func, result;
712
713     code = (struct code *)native_pointer(thing);
714     nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
715
716     new = (struct code *)read_only_free;
717     read_only_free += CEILING(nwords, 2);
718
719     bcopy(code, new, nwords * sizeof(lispobj));
720
721 #ifdef LISP_FEATURE_X86
722     apply_code_fixups_during_purify(code,new);
723 #endif
724
725     result = make_lispobj(new, OTHER_POINTER_LOWTAG);
726
727     /* Stick in a forwarding pointer for the code object. */
728     *(lispobj *)code = result;
729
730     /* Put in forwarding pointers for all the functions. */
731     for (func = code->entry_points;
732          func != NIL;
733          func = ((struct simple_fun *)native_pointer(func))->next) {
734
735         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
736
737         *(lispobj *)native_pointer(func) = result + (func - thing);
738     }
739
740     /* Arrange to scavenge the debug info later. */
741     pscav_later(&new->debug_info, 1);
742
743     if (new->trace_table_offset & 0x3)
744 #if 0
745       pscav(&new->trace_table_offset, 1, 0);
746 #else
747       new->trace_table_offset = NIL; /* limit lifetime */
748 #endif
749
750     /* Scavenge the constants. */
751     pscav(new->constants, HeaderValue(new->header)-5, 1);
752
753     /* Scavenge all the functions. */
754     pscav(&new->entry_points, 1, 1);
755     for (func = new->entry_points;
756          func != NIL;
757          func = ((struct simple_fun *)native_pointer(func))->next) {
758         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
759         gc_assert(!dynamic_pointer_p(func));
760
761 #ifdef LISP_FEATURE_X86
762         /* Temporarly convert the self pointer to a real function pointer. */
763         ((struct simple_fun *)native_pointer(func))->self
764             -= FUN_RAW_ADDR_OFFSET;
765 #endif
766         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
767 #ifdef LISP_FEATURE_X86
768         ((struct simple_fun *)native_pointer(func))->self
769             += FUN_RAW_ADDR_OFFSET;
770 #endif
771         pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3);
772     }
773
774     return result;
775 }
776
777 static lispobj
778 ptrans_func(lispobj thing, lispobj header)
779 {
780     int nwords;
781     lispobj code, *new, *old, result;
782     struct simple_fun *function;
783
784     /* Thing can either be a function header, a closure function
785      * header, a closure, or a funcallable-instance. If it's a closure
786      * or a funcallable-instance, we do the same as ptrans_boxed.
787      * Otherwise we have to do something strange, 'cause it is buried
788      * inside a code object. */
789
790     if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG) {
791
792         /* We can only end up here if the code object has not been
793          * scavenged, because if it had been scavenged, forwarding pointers
794          * would have been left behind for all the entry points. */
795
796         function = (struct simple_fun *)native_pointer(thing);
797         code =
798             make_lispobj
799             ((native_pointer(thing) -
800               (HeaderValue(function->header))), OTHER_POINTER_LOWTAG);
801         
802         /* This will cause the function's header to be replaced with a 
803          * forwarding pointer. */
804
805         ptrans_code(code);
806
807         /* So we can just return that. */
808         return function->header;
809     }
810     else {
811         /* It's some kind of closure-like thing. */
812         nwords = 1 + HeaderValue(header);
813         old = (lispobj *)native_pointer(thing);
814
815         /* Allocate the new one. */
816         if (widetag_of(header) == FUNCALLABLE_INSTANCE_HEADER_WIDETAG) {
817             /* FINs *must* not go in read_only space. */
818             new = static_free;
819             static_free += CEILING(nwords, 2);
820         }
821         else {
822             /* Closures can always go in read-only space, 'cause they
823              * never change. */
824
825             new = read_only_free;
826             read_only_free += CEILING(nwords, 2);
827         }
828         /* Copy it. */
829         bcopy(old, new, nwords * sizeof(lispobj));
830
831         /* Deposit forwarding pointer. */
832         result = make_lispobj(new, lowtag_of(thing));
833         *old = result;
834
835         /* Scavenge it. */
836         pscav(new, nwords, 0);
837
838         return result;
839     }
840 }
841
842 static lispobj
843 ptrans_returnpc(lispobj thing, lispobj header)
844 {
845     lispobj code, new;
846
847     /* Find the corresponding code object. */
848     code = thing - HeaderValue(header)*sizeof(lispobj);
849
850     /* Make sure it's been transported. */
851     new = *(lispobj *)native_pointer(code);
852     if (!forwarding_pointer_p(new))
853         new = ptrans_code(code);
854
855     /* Maintain the offset: */
856     return new + (thing - code);
857 }
858
859 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
860
861 static lispobj
862 ptrans_list(lispobj thing, boolean constant)
863 {
864     struct cons *old, *new, *orig;
865     int length;
866
867     if (constant)
868         orig = (struct cons *)read_only_free;
869     else
870         orig = (struct cons *)static_free;
871     length = 0;
872
873     do {
874         /* Allocate a new cons cell. */
875         old = (struct cons *)native_pointer(thing);
876         if (constant) {
877             new = (struct cons *)read_only_free;
878             read_only_free += WORDS_PER_CONS;
879         }
880         else {
881             new = (struct cons *)static_free;
882             static_free += WORDS_PER_CONS;
883         }
884
885         /* Copy the cons cell and keep a pointer to the cdr. */
886         new->car = old->car;
887         thing = new->cdr = old->cdr;
888
889         /* Set up the forwarding pointer. */
890         *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG);
891
892         /* And count this cell. */
893         length++;
894     } while (lowtag_of(thing) == LIST_POINTER_LOWTAG &&
895              dynamic_pointer_p(thing) &&
896              !(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
897
898     /* Scavenge the list we just copied. */
899     pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
900
901     return make_lispobj(orig, LIST_POINTER_LOWTAG);
902 }
903
904 static lispobj
905 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
906 {
907     switch (widetag_of(header)) {
908         /* FIXME: this needs a reindent */
909       case BIGNUM_WIDETAG:
910       case SINGLE_FLOAT_WIDETAG:
911       case DOUBLE_FLOAT_WIDETAG:
912 #ifdef LONG_FLOAT_WIDETAG
913       case LONG_FLOAT_WIDETAG:
914 #endif
915 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
916       case COMPLEX_SINGLE_FLOAT_WIDETAG:
917 #endif
918 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
919       case COMPLEX_DOUBLE_FLOAT_WIDETAG:
920 #endif
921 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
922       case COMPLEX_LONG_FLOAT_WIDETAG:
923 #endif
924       case SAP_WIDETAG:
925           return ptrans_unboxed(thing, header);
926
927       case RATIO_WIDETAG:
928       case COMPLEX_WIDETAG:
929       case SIMPLE_ARRAY_WIDETAG:
930       case COMPLEX_BASE_STRING_WIDETAG:
931       case COMPLEX_BIT_VECTOR_WIDETAG:
932       case COMPLEX_VECTOR_NIL_WIDETAG:
933       case COMPLEX_VECTOR_WIDETAG:
934       case COMPLEX_ARRAY_WIDETAG:
935         return ptrans_boxed(thing, header, constant);
936         
937       case VALUE_CELL_HEADER_WIDETAG:
938       case WEAK_POINTER_WIDETAG:
939         return ptrans_boxed(thing, header, 0);
940
941       case SYMBOL_HEADER_WIDETAG:
942         return ptrans_boxed(thing, header, 0);
943
944       case SIMPLE_ARRAY_NIL_WIDETAG:
945         return ptrans_vector(thing, 0, 0, 0, constant);
946
947       case SIMPLE_BASE_STRING_WIDETAG:
948         return ptrans_vector(thing, 8, 1, 0, constant);
949
950       case SIMPLE_BIT_VECTOR_WIDETAG:
951         return ptrans_vector(thing, 1, 0, 0, constant);
952
953       case SIMPLE_VECTOR_WIDETAG:
954         return ptrans_vector(thing, 32, 0, 1, constant);
955
956       case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
957         return ptrans_vector(thing, 2, 0, 0, constant);
958
959       case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
960         return ptrans_vector(thing, 4, 0, 0, constant);
961
962       case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
963 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
964       case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
965       case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
966 #endif
967         return ptrans_vector(thing, 8, 0, 0, constant);
968
969       case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
970 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
971       case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
972       case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
973 #endif
974         return ptrans_vector(thing, 16, 0, 0, constant);
975
976       case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
977 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
978       case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
979       case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
980 #endif
981 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
982       case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
983       case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
984 #endif
985         return ptrans_vector(thing, 32, 0, 0, constant);
986
987       case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
988         return ptrans_vector(thing, 32, 0, 0, constant);
989
990       case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
991         return ptrans_vector(thing, 64, 0, 0, constant);
992
993 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
994       case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
995 #ifdef LISP_FEATURE_X86
996         return ptrans_vector(thing, 96, 0, 0, constant);
997 #endif
998 #ifdef sparc
999         return ptrans_vector(thing, 128, 0, 0, constant);
1000 #endif
1001 #endif
1002
1003 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1004       case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
1005         return ptrans_vector(thing, 64, 0, 0, constant);
1006 #endif
1007
1008 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1009       case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
1010         return ptrans_vector(thing, 128, 0, 0, constant);
1011 #endif
1012
1013 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1014       case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
1015 #ifdef LISP_FEATURE_X86
1016         return ptrans_vector(thing, 192, 0, 0, constant);
1017 #endif
1018 #ifdef sparc
1019         return ptrans_vector(thing, 256, 0, 0, constant);
1020 #endif
1021 #endif
1022
1023       case CODE_HEADER_WIDETAG:
1024         return ptrans_code(thing);
1025
1026       case RETURN_PC_HEADER_WIDETAG:
1027         return ptrans_returnpc(thing, header);
1028
1029       case FDEFN_WIDETAG:
1030         return ptrans_fdefn(thing, header);
1031
1032       default:
1033         /* Should only come across other pointers to the above stuff. */
1034         gc_abort();
1035         return NIL;
1036     }
1037 }
1038
1039 static int
1040 pscav_fdefn(struct fdefn *fdefn)
1041 {
1042     boolean fix_func;
1043
1044     fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
1045     pscav(&fdefn->name, 1, 1);
1046     pscav(&fdefn->fun, 1, 0);
1047     if (fix_func)
1048         fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
1049     return sizeof(struct fdefn) / sizeof(lispobj);
1050 }
1051
1052 #ifdef LISP_FEATURE_X86
1053 /* now putting code objects in static space */
1054 static int
1055 pscav_code(struct code*code)
1056 {
1057     int nwords;
1058     lispobj func;
1059     nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
1060
1061     /* Arrange to scavenge the debug info later. */
1062     pscav_later(&code->debug_info, 1);
1063
1064     /* Scavenge the constants. */
1065     pscav(code->constants, HeaderValue(code->header)-5, 1);
1066
1067     /* Scavenge all the functions. */
1068     pscav(&code->entry_points, 1, 1);
1069     for (func = code->entry_points;
1070          func != NIL;
1071          func = ((struct simple_fun *)native_pointer(func))->next) {
1072         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
1073         gc_assert(!dynamic_pointer_p(func));
1074
1075 #ifdef LISP_FEATURE_X86
1076         /* Temporarily convert the self pointer to a real function
1077          * pointer. */
1078         ((struct simple_fun *)native_pointer(func))->self
1079             -= FUN_RAW_ADDR_OFFSET;
1080 #endif
1081         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
1082 #ifdef LISP_FEATURE_X86
1083         ((struct simple_fun *)native_pointer(func))->self
1084             += FUN_RAW_ADDR_OFFSET;
1085 #endif
1086         pscav_later(&((struct simple_fun *)native_pointer(func))->name, 3);
1087     }
1088
1089     return CEILING(nwords,2);
1090 }
1091 #endif
1092
1093 static lispobj *
1094 pscav(lispobj *addr, int nwords, boolean constant)
1095 {
1096     lispobj thing, *thingp, header;
1097     int count = 0; /* (0 = dummy init value to stop GCC warning) */
1098     struct vector *vector;
1099
1100     while (nwords > 0) {
1101         thing = *addr;
1102         if (is_lisp_pointer(thing)) {
1103             /* It's a pointer. Is it something we might have to move? */
1104             if (dynamic_pointer_p(thing)) {
1105                 /* Maybe. Have we already moved it? */
1106                 thingp = (lispobj *)native_pointer(thing);
1107                 header = *thingp;
1108                 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
1109                     /* Yep, so just copy the forwarding pointer. */
1110                     thing = header;
1111                 else {
1112                     /* Nope, copy the object. */
1113                     switch (lowtag_of(thing)) {
1114                       case FUN_POINTER_LOWTAG:
1115                         thing = ptrans_func(thing, header);
1116                         break;
1117
1118                       case LIST_POINTER_LOWTAG:
1119                         thing = ptrans_list(thing, constant);
1120                         break;
1121
1122                       case INSTANCE_POINTER_LOWTAG:
1123                         thing = ptrans_instance(thing, header, constant);
1124                         break;
1125
1126                       case OTHER_POINTER_LOWTAG:
1127                         thing = ptrans_otherptr(thing, header, constant);
1128                         break;
1129
1130                       default:
1131                         /* It was a pointer, but not one of them? */
1132                         gc_abort();
1133                     }
1134                 }
1135                 *addr = thing;
1136             }
1137             count = 1;
1138         }
1139         else if (thing & 3) {
1140             /* It's an other immediate. Maybe the header for an unboxed */
1141             /* object. */
1142             switch (widetag_of(thing)) {
1143               case BIGNUM_WIDETAG:
1144               case SINGLE_FLOAT_WIDETAG:
1145               case DOUBLE_FLOAT_WIDETAG:
1146 #ifdef LONG_FLOAT_WIDETAG
1147               case LONG_FLOAT_WIDETAG:
1148 #endif
1149               case SAP_WIDETAG:
1150                 /* It's an unboxed simple object. */
1151                 count = HeaderValue(thing)+1;
1152                 break;
1153
1154               case SIMPLE_VECTOR_WIDETAG:
1155                   if (HeaderValue(thing) == subtype_VectorValidHashing) {
1156                     *addr = (subtype_VectorMustRehash << N_WIDETAG_BITS) |
1157                         SIMPLE_VECTOR_WIDETAG;
1158                   }
1159                 count = 1;
1160                 break;
1161
1162               case SIMPLE_ARRAY_NIL_WIDETAG:
1163                 count = 2;
1164                 break;
1165
1166               case SIMPLE_BASE_STRING_WIDETAG:
1167                 vector = (struct vector *)addr;
1168                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2);
1169                 break;
1170
1171               case SIMPLE_BIT_VECTOR_WIDETAG:
1172                 vector = (struct vector *)addr;
1173                 count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
1174                 break;
1175
1176               case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
1177                 vector = (struct vector *)addr;
1178                 count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
1179                 break;
1180
1181               case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
1182                 vector = (struct vector *)addr;
1183                 count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
1184                 break;
1185
1186               case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
1187 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
1188               case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
1189               case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
1190 #endif
1191                 vector = (struct vector *)addr;
1192                 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
1193                 break;
1194
1195               case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
1196 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
1197               case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
1198               case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
1199 #endif
1200                 vector = (struct vector *)addr;
1201                 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
1202                 break;
1203
1204               case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
1205 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
1206               case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
1207               case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
1208 #endif
1209 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
1210               case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
1211               case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
1212 #endif
1213                 vector = (struct vector *)addr;
1214                 count = CEILING(fixnum_value(vector->length)+2,2);
1215                 break;
1216
1217               case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
1218                 vector = (struct vector *)addr;
1219                 count = CEILING(fixnum_value(vector->length)+2,2);
1220                 break;
1221
1222               case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
1223 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
1224               case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
1225 #endif
1226                 vector = (struct vector *)addr;
1227                 count = fixnum_value(vector->length)*2+2;
1228                 break;
1229
1230 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
1231               case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
1232                 vector = (struct vector *)addr;
1233 #ifdef LISP_FEATURE_X86
1234                 count = fixnum_value(vector->length)*3+2;
1235 #endif
1236 #ifdef sparc
1237                 count = fixnum_value(vector->length)*4+2;
1238 #endif
1239                 break;
1240 #endif
1241
1242 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
1243               case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
1244                 vector = (struct vector *)addr;
1245                 count = fixnum_value(vector->length)*4+2;
1246                 break;
1247 #endif
1248
1249 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
1250               case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
1251                 vector = (struct vector *)addr;
1252 #ifdef LISP_FEATURE_X86
1253                 count = fixnum_value(vector->length)*6+2;
1254 #endif
1255 #ifdef sparc
1256                 count = fixnum_value(vector->length)*8+2;
1257 #endif
1258                 break;
1259 #endif
1260
1261               case CODE_HEADER_WIDETAG:
1262 #ifndef LISP_FEATURE_X86
1263                 gc_abort(); /* no code headers in static space */
1264 #else
1265                 count = pscav_code((struct code*)addr);
1266 #endif
1267                 break;
1268
1269               case SIMPLE_FUN_HEADER_WIDETAG:
1270               case RETURN_PC_HEADER_WIDETAG:
1271                 /* We should never hit any of these, 'cause they occur
1272                  * buried in the middle of code objects. */
1273                 gc_abort();
1274                 break;
1275
1276 #ifdef LISP_FEATURE_X86
1277               case CLOSURE_HEADER_WIDETAG:
1278               case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
1279                 /* The function self pointer needs special care on the
1280                  * x86 because it is the real entry point. */
1281                 {
1282                   lispobj fun = ((struct closure *)addr)->fun
1283                     - FUN_RAW_ADDR_OFFSET;
1284                   pscav(&fun, 1, constant);
1285                   ((struct closure *)addr)->fun = fun + FUN_RAW_ADDR_OFFSET;
1286                 }
1287                 count = 2;
1288                 break;
1289 #endif
1290
1291               case WEAK_POINTER_WIDETAG:
1292                 /* Weak pointers get preserved during purify, 'cause I
1293                  * don't feel like figuring out how to break them. */
1294                 pscav(addr+1, 2, constant);
1295                 count = 4;
1296                 break;
1297
1298               case FDEFN_WIDETAG:
1299                 /* We have to handle fdefn objects specially, so we
1300                  * can fix up the raw function address. */
1301                 count = pscav_fdefn((struct fdefn *)addr);
1302                 break;
1303
1304               default:
1305                 count = 1;
1306                 break;
1307             }
1308         }
1309         else {
1310             /* It's a fixnum. */
1311             count = 1;
1312         }
1313
1314         addr += count;
1315         nwords -= count;
1316     }
1317
1318     return addr;
1319 }
1320
1321 int
1322 purify(lispobj static_roots, lispobj read_only_roots)
1323 {
1324     lispobj *clean;
1325     int count, i;
1326     struct later *laters, *next;
1327     struct thread *thread;
1328
1329 #ifdef PRINTNOISE
1330     printf("[doing purification:");
1331     fflush(stdout);
1332 #endif
1333 #ifdef LISP_FEATURE_GENCGC
1334     gc_alloc_update_all_page_tables();
1335 #endif
1336     for_each_thread(thread)
1337         if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
1338         /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
1339          * its error simply by a. printing a string b. to stdout instead
1340          * of stderr. */
1341         printf(" Ack! Can't purify interrupt contexts. ");
1342         fflush(stdout);
1343         return 0;
1344     }
1345
1346 #if defined(LISP_FEATURE_X86)
1347     dynamic_space_free_pointer =
1348       (lispobj*)SymbolValue(ALLOCATION_POINTER,0);
1349 #endif
1350
1351     read_only_end = read_only_free =
1352         (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
1353     static_end = static_free =
1354         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
1355
1356 #ifdef PRINTNOISE
1357     printf(" roots");
1358     fflush(stdout);
1359 #endif
1360
1361 #if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
1362 #if 0
1363     /* This is what we should do, but can't unless the threads in
1364      * question are suspended with ptrace.  That's right, purify is not
1365      * threadsafe
1366      */
1367     for_each_thread(thread) {
1368         void **ptr;
1369         struct user_regs_struct regs;
1370         if(ptrace(PTRACE_GETREGS,thread->pid,0,&regs)){
1371             fprintf(stderr,"child pid %d, %s\n",thread->pid,strerror(errno));
1372             lose("PTRACE_GETREGS");
1373         }
1374         setup_i386_stack_scav(regs.ebp,
1375                               ((void *)thread->control_stack_end));
1376     }
1377 #endif /* 0 */
1378     /* stopgap until we can set things up as in preceding comment */
1379     setup_i386_stack_scav(((&static_roots)-2),
1380                           ((void *)all_threads->control_stack_end));
1381 #endif
1382
1383     pscav(&static_roots, 1, 0);
1384     pscav(&read_only_roots, 1, 1);
1385
1386 #ifdef PRINTNOISE
1387     printf(" handlers");
1388     fflush(stdout);
1389 #endif
1390     pscav((lispobj *) all_threads->interrupt_data->interrupt_handlers,
1391           sizeof(all_threads->interrupt_data->interrupt_handlers)
1392           / sizeof(lispobj),
1393           0);
1394
1395 #ifdef PRINTNOISE
1396     printf(" stack");
1397     fflush(stdout);
1398 #endif
1399 #ifndef LISP_FEATURE_X86
1400     pscav((lispobj *)all_threads->control_stack_start,
1401           current_control_stack_pointer - 
1402           all_threads->control_stack_start,
1403           0);
1404 #else
1405 #ifdef LISP_FEATURE_GENCGC
1406     pscav_i386_stack();
1407 #endif
1408 #endif
1409
1410 #ifdef PRINTNOISE
1411     printf(" bindings");
1412     fflush(stdout);
1413 #endif
1414 #if !defined(LISP_FEATURE_X86)
1415     pscav( (lispobj *)all_threads->binding_stack_start,
1416           (lispobj *)current_binding_stack_pointer -
1417            all_threads->binding_stack_start,
1418           0);
1419 #else
1420     for_each_thread(thread) {
1421         pscav( (lispobj *)thread->binding_stack_start,
1422                (lispobj *)SymbolValue(BINDING_STACK_POINTER,thread) -
1423                (lispobj *)thread->binding_stack_start,
1424           0);
1425         pscav( (lispobj *) (thread+1),
1426                fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) -
1427                (sizeof (struct thread))/(sizeof (lispobj)),
1428           0);
1429     }
1430
1431
1432 #endif
1433
1434     /* The original CMU CL code had scavenge-read-only-space code
1435      * controlled by the Lisp-level variable
1436      * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
1437      * wasn't documented under what circumstances it was useful or
1438      * safe to turn it on, so it's been turned off in SBCL. If you
1439      * want/need this functionality, and can test and document it,
1440      * please submit a patch. */
1441 #if 0
1442     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG
1443         && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
1444       unsigned  read_only_space_size =
1445           (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
1446           (lispobj *)READ_ONLY_SPACE_START;
1447       fprintf(stderr,
1448               "scavenging read only space: %d bytes\n",
1449               read_only_space_size * sizeof(lispobj));
1450       pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
1451     }
1452 #endif
1453
1454 #ifdef PRINTNOISE
1455     printf(" static");
1456     fflush(stdout);
1457 #endif
1458     clean = (lispobj *)STATIC_SPACE_START;
1459     do {
1460         while (clean != static_free)
1461             clean = pscav(clean, static_free - clean, 0);
1462         laters = later_blocks;
1463         count = later_count;
1464         later_blocks = NULL;
1465         later_count = 0;
1466         while (laters != NULL) {
1467             for (i = 0; i < count; i++) {
1468                 if (laters->u[i].count == 0) {
1469                     ;
1470                 } else if (laters->u[i].count <= LATERMAXCOUNT) {
1471                     pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
1472                     i++;
1473                 } else {
1474                     pscav(laters->u[i].ptr, 1, 1);
1475                 }
1476             }
1477             next = laters->next;
1478             free(laters);
1479             laters = next;
1480             count = LATERBLOCKSIZE;
1481         }
1482     } while (clean != static_free || later_blocks != NULL);
1483
1484 #ifdef PRINTNOISE
1485     printf(" cleanup");
1486     fflush(stdout);
1487 #endif
1488
1489     os_zero((os_vm_address_t) current_dynamic_space,
1490             (os_vm_size_t) DYNAMIC_SPACE_SIZE);
1491
1492     /* Zero the stack. Note that the stack is also zeroed by SUB-GC
1493      * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
1494 #ifndef LISP_FEATURE_X86
1495     os_zero((os_vm_address_t) current_control_stack_pointer,
1496             (os_vm_size_t)
1497             ((all_threads->control_stack_end -
1498               current_control_stack_pointer) * sizeof(lispobj)));
1499 #endif
1500
1501     /* It helps to update the heap free pointers so that free_heap can
1502      * verify after it's done. */
1503     SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
1504     SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
1505
1506 #if !defined(LISP_FEATURE_X86)
1507     dynamic_space_free_pointer = current_dynamic_space;
1508     set_auto_gc_trigger(bytes_consed_between_gcs);
1509 #else
1510 #if defined LISP_FEATURE_GENCGC
1511     gc_free_heap();
1512 #else
1513 #error unsupported case /* in CMU CL, was "ibmrt using GC" */
1514 #endif
1515 #endif
1516
1517 #ifdef PRINTNOISE
1518     printf(" done]\n");
1519     fflush(stdout);
1520 #endif
1521     return 0;
1522 }