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