1.0.5.14: make PURIFY a no-op on gencgc
[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 #include <errno.h>
21
22 #include "sbcl.h"
23 #include "runtime.h"
24 #include "os.h"
25 #include "globals.h"
26 #include "validate.h"
27 #include "interrupt.h"
28 #include "purify.h"
29 #include "interr.h"
30 #include "fixnump.h"
31 #include "gc.h"
32 #include "gc-internal.h"
33 #include "thread.h"
34 #include "genesis/primitive-objects.h"
35 #include "genesis/static-symbols.h"
36 #include "genesis/layout.h"
37
38 /* We don't ever do purification with GENCGC as of 1.0.5.*. There was
39  * a lot of hairy and fragile ifdeffage in here to support purify on
40  * x86oids, which has now been removed. So this code can't even be
41  * compiled with GENCGC any more.  -- JES, 2007-04-30.
42  */
43 #ifndef LISP_FEATURE_GENCGC
44
45 #define PRINTNOISE
46
47 static lispobj *dynamic_space_purify_pointer;
48
49 \f
50 /* These hold the original end of the read_only and static spaces so
51  * we can tell what are forwarding pointers. */
52
53 static lispobj *read_only_end, *static_end;
54
55 static lispobj *read_only_free, *static_free;
56
57 static lispobj *pscav(lispobj *addr, long nwords, boolean constant);
58
59 #define LATERBLOCKSIZE 1020
60 #define LATERMAXCOUNT 10
61
62 static struct
63 later {
64     struct later *next;
65     union {
66         lispobj *ptr;
67         long count;
68     } u[LATERBLOCKSIZE];
69 } *later_blocks = NULL;
70 static long later_count = 0;
71
72 #if N_WORD_BITS == 32
73  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
74 #elif N_WORD_BITS == 64
75  #define SIMPLE_ARRAY_WORD_WIDETAG SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
76 #endif
77
78 \f
79 static boolean
80 forwarding_pointer_p(lispobj obj)
81 {
82     lispobj *ptr = native_pointer(obj);
83
84     return ((static_end <= ptr && ptr <= static_free) ||
85             (read_only_end <= ptr && ptr <= read_only_free));
86 }
87
88 static boolean
89 dynamic_pointer_p(lispobj ptr)
90 {
91     return (ptr >= (lispobj)current_dynamic_space
92             &&
93             ptr < (lispobj)dynamic_space_purify_pointer);
94 }
95
96 static inline lispobj *
97 newspace_alloc(long nwords, int constantp)
98 {
99     lispobj *ret;
100     nwords=CEILING(nwords,2);
101     if(constantp) {
102         if(read_only_free + nwords >= (lispobj *)READ_ONLY_SPACE_END) {
103             lose("Ran out of read-only space while purifying!\n");
104         }
105         ret=read_only_free;
106         read_only_free+=nwords;
107     } else {
108         if(static_free + nwords >= (lispobj *)STATIC_SPACE_END) {
109             lose("Ran out of static space while purifying!\n");
110         }
111         ret=static_free;
112         static_free+=nwords;
113     }
114     return ret;
115 }
116
117 \f
118 static void
119 pscav_later(lispobj *where, long count)
120 {
121     struct later *new;
122
123     if (count > LATERMAXCOUNT) {
124         while (count > LATERMAXCOUNT) {
125             pscav_later(where, LATERMAXCOUNT);
126             count -= LATERMAXCOUNT;
127             where += LATERMAXCOUNT;
128         }
129     }
130     else {
131         if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
132             (later_count == LATERBLOCKSIZE-1 && count > 1)) {
133             new  = (struct later *)malloc(sizeof(struct later));
134             new->next = later_blocks;
135             if (later_blocks && later_count < LATERBLOCKSIZE)
136                 later_blocks->u[later_count].ptr = NULL;
137             later_blocks = new;
138             later_count = 0;
139         }
140
141         if (count != 1)
142             later_blocks->u[later_count++].count = count;
143         later_blocks->u[later_count++].ptr = where;
144     }
145 }
146
147 static lispobj
148 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
149 {
150     long nwords;
151     lispobj result, *new, *old;
152
153     nwords = CEILING(1 + HeaderValue(header), 2);
154
155     /* Allocate it */
156     old = (lispobj *)native_pointer(thing);
157     new = newspace_alloc(nwords,constant);
158
159     /* Copy it. */
160     bcopy(old, new, nwords * sizeof(lispobj));
161
162     /* Deposit forwarding pointer. */
163     result = make_lispobj(new, lowtag_of(thing));
164     *old = result;
165
166     /* Scavenge it. */
167     pscav(new, nwords, constant);
168
169     return result;
170 }
171
172 /* We need to look at the layout to see whether it is a pure structure
173  * class, and only then can we transport as constant. If it is pure,
174  * we can ALWAYS transport as a constant. */
175 static lispobj
176 ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
177 {
178     struct layout *layout =
179       (struct layout *) native_pointer(((struct instance *)native_pointer(thing))->slots[0]);
180     lispobj pure = layout->pure;
181
182     switch (pure) {
183     case T:
184         return (ptrans_boxed(thing, header, 1));
185     case NIL:
186         return (ptrans_boxed(thing, header, 0));
187     case 0:
188         {
189             /* Substructure: special case for the COMPACT-INFO-ENVs,
190              * where the instance may have a point to the dynamic
191              * space placed into it (e.g. the cache-name slot), but
192              * the lists and arrays at the time of a purify can be
193              * moved to the RO space. */
194             long nwords;
195             lispobj result, *new, *old;
196
197             nwords = CEILING(1 + HeaderValue(header), 2);
198
199             /* Allocate it */
200             old = (lispobj *)native_pointer(thing);
201             new = newspace_alloc(nwords, 0); /*  inconstant */
202
203             /* Copy it. */
204             bcopy(old, new, nwords * sizeof(lispobj));
205
206             /* Deposit forwarding pointer. */
207             result = make_lispobj(new, lowtag_of(thing));
208             *old = result;
209
210             /* Scavenge it. */
211             pscav(new, nwords, 1);
212
213             return result;
214         }
215     default:
216         gc_abort();
217         return NIL; /* dummy value: return something ... */
218     }
219 }
220
221 static lispobj
222 ptrans_fdefn(lispobj thing, lispobj header)
223 {
224     long nwords;
225     lispobj result, *new, *old, oldfn;
226     struct fdefn *fdefn;
227
228     nwords = CEILING(1 + HeaderValue(header), 2);
229
230     /* Allocate it */
231     old = (lispobj *)native_pointer(thing);
232     new = newspace_alloc(nwords, 0);    /* inconstant */
233
234     /* Copy it. */
235     bcopy(old, new, nwords * sizeof(lispobj));
236
237     /* Deposit forwarding pointer. */
238     result = make_lispobj(new, lowtag_of(thing));
239     *old = result;
240
241     /* Scavenge the function. */
242     fdefn = (struct fdefn *)new;
243     oldfn = fdefn->fun;
244     pscav(&fdefn->fun, 1, 0);
245     if ((char *)oldfn + FUN_RAW_ADDR_OFFSET == fdefn->raw_addr)
246         fdefn->raw_addr = (char *)fdefn->fun + FUN_RAW_ADDR_OFFSET;
247
248     return result;
249 }
250
251 static lispobj
252 ptrans_unboxed(lispobj thing, lispobj header)
253 {
254     long nwords;
255     lispobj result, *new, *old;
256
257     nwords = CEILING(1 + HeaderValue(header), 2);
258
259     /* Allocate it */
260     old = (lispobj *)native_pointer(thing);
261     new = newspace_alloc(nwords,1);     /* always constant */
262
263     /* copy it. */
264     bcopy(old, new, nwords * sizeof(lispobj));
265
266     /* Deposit forwarding pointer. */
267     result = make_lispobj(new , lowtag_of(thing));
268     *old = result;
269
270     return result;
271 }
272
273 static lispobj
274 ptrans_vector(lispobj thing, long bits, long extra,
275               boolean boxed, boolean constant)
276 {
277     struct vector *vector;
278     long nwords;
279     lispobj result, *new;
280     long length;
281
282     vector = (struct vector *)native_pointer(thing);
283     length = fixnum_value(vector->length)+extra;
284     // Argh, handle simple-vector-nil separately.
285     if (bits == 0) {
286       nwords = 2;
287     } else {
288       nwords = CEILING(NWORDS(length, bits) + 2, 2);
289     }
290
291     new=newspace_alloc(nwords, (constant || !boxed));
292     bcopy(vector, new, nwords * sizeof(lispobj));
293
294     result = make_lispobj(new, lowtag_of(thing));
295     vector->header = result;
296
297     if (boxed)
298         pscav(new, nwords, constant);
299
300     return result;
301 }
302
303 static lispobj
304 ptrans_code(lispobj thing)
305 {
306     struct code *code, *new;
307     long nwords;
308     lispobj func, result;
309
310     code = (struct code *)native_pointer(thing);
311     nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size),
312                      2);
313
314     new = (struct code *)newspace_alloc(nwords,1); /* constant */
315
316     bcopy(code, new, nwords * sizeof(lispobj));
317
318     result = make_lispobj(new, OTHER_POINTER_LOWTAG);
319
320     /* Stick in a forwarding pointer for the code object. */
321     *(lispobj *)code = result;
322
323     /* Put in forwarding pointers for all the functions. */
324     for (func = code->entry_points;
325          func != NIL;
326          func = ((struct simple_fun *)native_pointer(func))->next) {
327
328         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
329
330         *(lispobj *)native_pointer(func) = result + (func - thing);
331     }
332
333     /* Arrange to scavenge the debug info later. */
334     pscav_later(&new->debug_info, 1);
335
336     /* FIXME: why would this be a fixnum? */
337     /* "why" is a hard word, but apparently for compiled functions the
338        trace_table_offset contains the length of the instructions, as
339        a fixnum.  See CODE-INST-AREA-LENGTH in
340        src/compiler/target-disassem.lisp.  -- CSR, 2004-01-08 */
341     if (!(fixnump(new->trace_table_offset)))
342 #if 0
343         pscav(&new->trace_table_offset, 1, 0);
344 #else
345         new->trace_table_offset = NIL; /* limit lifetime */
346 #endif
347
348     /* Scavenge the constants. */
349     pscav(new->constants, HeaderValue(new->header)-5, 1);
350
351     /* Scavenge all the functions. */
352     pscav(&new->entry_points, 1, 1);
353     for (func = new->entry_points;
354          func != NIL;
355          func = ((struct simple_fun *)native_pointer(func))->next) {
356         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
357         gc_assert(!dynamic_pointer_p(func));
358
359         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
360         pscav_later(&((struct simple_fun *)native_pointer(func))->name, 4);
361     }
362
363     return result;
364 }
365
366 static lispobj
367 ptrans_func(lispobj thing, lispobj header)
368 {
369     long nwords;
370     lispobj code, *new, *old, result;
371     struct simple_fun *function;
372
373     /* Thing can either be a function header, a closure function
374      * header, a closure, or a funcallable-instance. If it's a closure
375      * or a funcallable-instance, we do the same as ptrans_boxed.
376      * Otherwise we have to do something strange, 'cause it is buried
377      * inside a code object. */
378
379     if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG) {
380
381         /* We can only end up here if the code object has not been
382          * scavenged, because if it had been scavenged, forwarding pointers
383          * would have been left behind for all the entry points. */
384
385         function = (struct simple_fun *)native_pointer(thing);
386         code =
387             make_lispobj
388             ((native_pointer(thing) -
389               (HeaderValue(function->header))), OTHER_POINTER_LOWTAG);
390
391         /* This will cause the function's header to be replaced with a
392          * forwarding pointer. */
393
394         ptrans_code(code);
395
396         /* So we can just return that. */
397         return function->header;
398     }
399     else {
400         /* It's some kind of closure-like thing. */
401         nwords = CEILING(1 + HeaderValue(header), 2);
402         old = (lispobj *)native_pointer(thing);
403
404         /* Allocate the new one.  FINs *must* not go in read_only
405          * space.  Closures can; they never change */
406
407         new = newspace_alloc
408             (nwords,(widetag_of(header)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG));
409
410         /* Copy it. */
411         bcopy(old, new, nwords * sizeof(lispobj));
412
413         /* Deposit forwarding pointer. */
414         result = make_lispobj(new, lowtag_of(thing));
415         *old = result;
416
417         /* Scavenge it. */
418         pscav(new, nwords, 0);
419
420         return result;
421     }
422 }
423
424 static lispobj
425 ptrans_returnpc(lispobj thing, lispobj header)
426 {
427     lispobj code, new;
428
429     /* Find the corresponding code object. */
430     code = thing - HeaderValue(header)*sizeof(lispobj);
431
432     /* Make sure it's been transported. */
433     new = *(lispobj *)native_pointer(code);
434     if (!forwarding_pointer_p(new))
435         new = ptrans_code(code);
436
437     /* Maintain the offset: */
438     return new + (thing - code);
439 }
440
441 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
442
443 static lispobj
444 ptrans_list(lispobj thing, boolean constant)
445 {
446     struct cons *old, *new, *orig;
447     long length;
448
449     orig = (struct cons *) newspace_alloc(0,constant);
450     length = 0;
451
452     do {
453         /* Allocate a new cons cell. */
454         old = (struct cons *)native_pointer(thing);
455         new = (struct cons *) newspace_alloc(WORDS_PER_CONS,constant);
456
457         /* Copy the cons cell and keep a pointer to the cdr. */
458         new->car = old->car;
459         thing = new->cdr = old->cdr;
460
461         /* Set up the forwarding pointer. */
462         *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG);
463
464         /* And count this cell. */
465         length++;
466     } while (lowtag_of(thing) == LIST_POINTER_LOWTAG &&
467              dynamic_pointer_p(thing) &&
468              !(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
469
470     /* Scavenge the list we just copied. */
471     pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
472
473     return make_lispobj(orig, LIST_POINTER_LOWTAG);
474 }
475
476 static lispobj
477 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
478 {
479     switch (widetag_of(header)) {
480         /* FIXME: this needs a reindent */
481       case BIGNUM_WIDETAG:
482       case SINGLE_FLOAT_WIDETAG:
483       case DOUBLE_FLOAT_WIDETAG:
484 #ifdef LONG_FLOAT_WIDETAG
485       case LONG_FLOAT_WIDETAG:
486 #endif
487 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
488       case COMPLEX_SINGLE_FLOAT_WIDETAG:
489 #endif
490 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
491       case COMPLEX_DOUBLE_FLOAT_WIDETAG:
492 #endif
493 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
494       case COMPLEX_LONG_FLOAT_WIDETAG:
495 #endif
496       case SAP_WIDETAG:
497           return ptrans_unboxed(thing, header);
498 #ifdef LUTEX_WIDETAG
499       case LUTEX_WIDETAG:
500           gencgc_unregister_lutex(native_pointer(thing));
501           return ptrans_unboxed(thing, header);
502 #endif
503
504       case RATIO_WIDETAG:
505       case COMPLEX_WIDETAG:
506       case SIMPLE_ARRAY_WIDETAG:
507       case COMPLEX_BASE_STRING_WIDETAG:
508 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
509     case COMPLEX_CHARACTER_STRING_WIDETAG:
510 #endif
511       case COMPLEX_BIT_VECTOR_WIDETAG:
512       case COMPLEX_VECTOR_NIL_WIDETAG:
513       case COMPLEX_VECTOR_WIDETAG:
514       case COMPLEX_ARRAY_WIDETAG:
515         return ptrans_boxed(thing, header, constant);
516
517       case VALUE_CELL_HEADER_WIDETAG:
518       case WEAK_POINTER_WIDETAG:
519         return ptrans_boxed(thing, header, 0);
520
521       case SYMBOL_HEADER_WIDETAG:
522         return ptrans_boxed(thing, header, 0);
523
524       case SIMPLE_ARRAY_NIL_WIDETAG:
525         return ptrans_vector(thing, 0, 0, 0, constant);
526
527       case SIMPLE_BASE_STRING_WIDETAG:
528         return ptrans_vector(thing, 8, 1, 0, constant);
529
530 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
531     case SIMPLE_CHARACTER_STRING_WIDETAG:
532         return ptrans_vector(thing, 32, 1, 0, constant);
533 #endif
534
535       case SIMPLE_BIT_VECTOR_WIDETAG:
536         return ptrans_vector(thing, 1, 0, 0, constant);
537
538       case SIMPLE_VECTOR_WIDETAG:
539         return ptrans_vector(thing, N_WORD_BITS, 0, 1, constant);
540
541       case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
542         return ptrans_vector(thing, 2, 0, 0, constant);
543
544       case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
545         return ptrans_vector(thing, 4, 0, 0, constant);
546
547       case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
548 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
549       case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
550       case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
551 #endif
552         return ptrans_vector(thing, 8, 0, 0, constant);
553
554       case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
555 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
556       case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
557       case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
558 #endif
559         return ptrans_vector(thing, 16, 0, 0, constant);
560
561       case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
562 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
563       case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
564       case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
565 #endif
566 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
567       case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
568       case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
569 #endif
570         return ptrans_vector(thing, 32, 0, 0, constant);
571
572 #if N_WORD_BITS == 64
573 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
574       case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
575 #endif
576 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
577       case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
578 #endif
579 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
580       case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
581 #endif
582 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
583       case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
584 #endif
585 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
586       case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
587 #endif
588         return ptrans_vector(thing, 64, 0, 0, constant);
589 #endif
590
591       case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
592         return ptrans_vector(thing, 32, 0, 0, constant);
593
594       case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
595         return ptrans_vector(thing, 64, 0, 0, constant);
596
597 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
598       case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
599 #ifdef LISP_FEATURE_SPARC
600         return ptrans_vector(thing, 128, 0, 0, constant);
601 #endif
602 #endif
603
604 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
605       case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
606         return ptrans_vector(thing, 64, 0, 0, constant);
607 #endif
608
609 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
610       case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
611         return ptrans_vector(thing, 128, 0, 0, constant);
612 #endif
613
614 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
615       case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
616 #ifdef LISP_FEATURE_SPARC
617         return ptrans_vector(thing, 256, 0, 0, constant);
618 #endif
619 #endif
620
621       case CODE_HEADER_WIDETAG:
622         return ptrans_code(thing);
623
624       case RETURN_PC_HEADER_WIDETAG:
625         return ptrans_returnpc(thing, header);
626
627       case FDEFN_WIDETAG:
628         return ptrans_fdefn(thing, header);
629
630       default:
631         fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header));
632         /* Should only come across other pointers to the above stuff. */
633         gc_abort();
634         return NIL;
635     }
636 }
637
638 static long
639 pscav_fdefn(struct fdefn *fdefn)
640 {
641     boolean fix_func;
642
643     fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
644     pscav(&fdefn->name, 1, 1);
645     pscav(&fdefn->fun, 1, 0);
646     if (fix_func)
647         fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
648     return sizeof(struct fdefn) / sizeof(lispobj);
649 }
650
651 static lispobj *
652 pscav(lispobj *addr, long nwords, boolean constant)
653 {
654     lispobj thing, *thingp, header;
655     long count = 0; /* (0 = dummy init value to stop GCC warning) */
656     struct vector *vector;
657
658     while (nwords > 0) {
659         thing = *addr;
660         if (is_lisp_pointer(thing)) {
661             /* It's a pointer. Is it something we might have to move? */
662             if (dynamic_pointer_p(thing)) {
663                 /* Maybe. Have we already moved it? */
664                 thingp = (lispobj *)native_pointer(thing);
665                 header = *thingp;
666                 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
667                     /* Yep, so just copy the forwarding pointer. */
668                     thing = header;
669                 else {
670                     /* Nope, copy the object. */
671                     switch (lowtag_of(thing)) {
672                       case FUN_POINTER_LOWTAG:
673                         thing = ptrans_func(thing, header);
674                         break;
675
676                       case LIST_POINTER_LOWTAG:
677                         thing = ptrans_list(thing, constant);
678                         break;
679
680                       case INSTANCE_POINTER_LOWTAG:
681                         thing = ptrans_instance(thing, header, constant);
682                         break;
683
684                       case OTHER_POINTER_LOWTAG:
685                         thing = ptrans_otherptr(thing, header, constant);
686                         break;
687
688                       default:
689                         /* It was a pointer, but not one of them? */
690                         gc_abort();
691                     }
692                 }
693                 *addr = thing;
694             }
695             count = 1;
696         }
697 #if N_WORD_BITS == 64
698         else if (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) {
699             count = 1;
700         }
701 #endif
702         else if (thing & FIXNUM_TAG_MASK) {
703             /* It's an other immediate. Maybe the header for an unboxed */
704             /* object. */
705             switch (widetag_of(thing)) {
706               case BIGNUM_WIDETAG:
707               case SINGLE_FLOAT_WIDETAG:
708               case DOUBLE_FLOAT_WIDETAG:
709 #ifdef LONG_FLOAT_WIDETAG
710               case LONG_FLOAT_WIDETAG:
711 #endif
712               case SAP_WIDETAG:
713                 /* It's an unboxed simple object. */
714                 count = CEILING(HeaderValue(thing)+1, 2);
715                 break;
716
717               case SIMPLE_VECTOR_WIDETAG:
718                   if (HeaderValue(thing) == subtype_VectorValidHashing) {
719                     *addr = (subtype_VectorMustRehash << N_WIDETAG_BITS) |
720                         SIMPLE_VECTOR_WIDETAG;
721                   }
722                 count = 2;
723                 break;
724
725               case SIMPLE_ARRAY_NIL_WIDETAG:
726                 count = 2;
727                 break;
728
729               case SIMPLE_BASE_STRING_WIDETAG:
730                 vector = (struct vector *)addr;
731                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,8)+2,2);
732                 break;
733
734 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
735             case SIMPLE_CHARACTER_STRING_WIDETAG:
736                 vector = (struct vector *)addr;
737                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,32)+2,2);
738                 break;
739 #endif
740
741               case SIMPLE_BIT_VECTOR_WIDETAG:
742                 vector = (struct vector *)addr;
743                 count = CEILING(NWORDS(fixnum_value(vector->length),1)+2,2);
744                 break;
745
746               case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
747                 vector = (struct vector *)addr;
748                 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
749                 break;
750
751               case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
752                 vector = (struct vector *)addr;
753                 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
754                 break;
755
756               case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
757 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
758               case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
759               case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
760 #endif
761                 vector = (struct vector *)addr;
762                 count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
763                 break;
764
765               case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
766 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
767               case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
768               case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
769 #endif
770                 vector = (struct vector *)addr;
771                 count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
772                 break;
773
774               case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
775 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
776               case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
777               case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
778 #endif
779 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
780               case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
781               case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
782 #endif
783                 vector = (struct vector *)addr;
784                 count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
785                 break;
786
787 #if N_WORD_BITS == 64
788               case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
789 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
790               case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
791               case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
792 #endif
793 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
794               case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
795               case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
796 #endif
797                 vector = (struct vector *)addr;
798                 count = CEILING(NWORDS(fixnum_value(vector->length),64)+2,2);
799                 break;
800 #endif
801
802               case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
803                 vector = (struct vector *)addr;
804                 count = CEILING(NWORDS(fixnum_value(vector->length), 32) + 2,
805                                 2);
806                 break;
807
808               case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
809 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
810               case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
811 #endif
812                 vector = (struct vector *)addr;
813                 count = CEILING(NWORDS(fixnum_value(vector->length), 64) + 2,
814                                 2);
815                 break;
816
817 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
818               case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
819                 vector = (struct vector *)addr;
820 #ifdef LISP_FEATURE_SPARC
821                 count = fixnum_value(vector->length)*4+2;
822 #endif
823                 break;
824 #endif
825
826 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
827               case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
828                 vector = (struct vector *)addr;
829                 count = CEILING(NWORDS(fixnum_value(vector->length), 128) + 2,
830                                 2);
831                 break;
832 #endif
833
834 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
835               case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
836                 vector = (struct vector *)addr;
837 #ifdef LISP_FEATURE_SPARC
838                 count = fixnum_value(vector->length)*8+2;
839 #endif
840                 break;
841 #endif
842
843               case CODE_HEADER_WIDETAG:
844                 gc_abort(); /* no code headers in static space */
845                 break;
846
847               case SIMPLE_FUN_HEADER_WIDETAG:
848               case RETURN_PC_HEADER_WIDETAG:
849                 /* We should never hit any of these, 'cause they occur
850                  * buried in the middle of code objects. */
851                 gc_abort();
852                 break;
853
854               case WEAK_POINTER_WIDETAG:
855                 /* Weak pointers get preserved during purify, 'cause I
856                  * don't feel like figuring out how to break them. */
857                 pscav(addr+1, 2, constant);
858                 count = 4;
859                 break;
860
861               case FDEFN_WIDETAG:
862                 /* We have to handle fdefn objects specially, so we
863                  * can fix up the raw function address. */
864                 count = pscav_fdefn((struct fdefn *)addr);
865                 break;
866
867               case INSTANCE_HEADER_WIDETAG:
868                 {
869                     struct instance *instance = (struct instance *) addr;
870                     struct layout *layout
871                         = (struct layout *) native_pointer(instance->slots[0]);
872                     long nuntagged = fixnum_value(layout->n_untagged_slots);
873                     long nslots = HeaderValue(*addr);
874                     pscav(addr + 1, nslots - nuntagged, constant);
875                     count = CEILING(1 + nslots, 2);
876                 }
877                 break;
878
879               default:
880                 count = 1;
881                 break;
882             }
883         }
884         else {
885             /* It's a fixnum. */
886             count = 1;
887         }
888
889         addr += count;
890         nwords -= count;
891     }
892
893     return addr;
894 }
895
896 int
897 purify(lispobj static_roots, lispobj read_only_roots)
898 {
899     lispobj *clean;
900     long count, i;
901     struct later *laters, *next;
902     struct thread *thread;
903
904     if(all_threads->next) {
905         /* FIXME: there should be _some_ sensible error reporting
906          * convention.  See following comment too */
907         fprintf(stderr,"Can't purify when more than one thread exists\n");
908         fflush(stderr);
909         return 0;
910     }
911
912 #ifdef PRINTNOISE
913     printf("[doing purification:");
914     fflush(stdout);
915 #endif
916
917     for_each_thread(thread)
918         if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
919         /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
920          * its error simply by a. printing a string b. to stdout instead
921          * of stderr. */
922         printf(" Ack! Can't purify interrupt contexts. ");
923         fflush(stdout);
924         return 0;
925     }
926
927     dynamic_space_purify_pointer = dynamic_space_free_pointer;
928
929     read_only_end = read_only_free =
930         (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
931     static_end = static_free =
932         (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
933
934 #ifdef PRINTNOISE
935     printf(" roots");
936     fflush(stdout);
937 #endif
938
939     pscav(&static_roots, 1, 0);
940     pscav(&read_only_roots, 1, 1);
941
942 #ifdef PRINTNOISE
943     printf(" handlers");
944     fflush(stdout);
945 #endif
946     pscav((lispobj *) interrupt_handlers,
947           sizeof(interrupt_handlers) / sizeof(lispobj),
948           0);
949
950 #ifdef PRINTNOISE
951     printf(" stack");
952     fflush(stdout);
953 #endif
954     pscav((lispobj *)all_threads->control_stack_start,
955           current_control_stack_pointer -
956           all_threads->control_stack_start,
957           0);
958
959 #ifdef PRINTNOISE
960     printf(" bindings");
961     fflush(stdout);
962 #endif
963
964     pscav( (lispobj *)all_threads->binding_stack_start,
965           (lispobj *)current_binding_stack_pointer -
966            all_threads->binding_stack_start,
967           0);
968
969     /* The original CMU CL code had scavenge-read-only-space code
970      * controlled by the Lisp-level variable
971      * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
972      * wasn't documented under what circumstances it was useful or
973      * safe to turn it on, so it's been turned off in SBCL. If you
974      * want/need this functionality, and can test and document it,
975      * please submit a patch. */
976 #if 0
977     if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG
978         && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
979       unsigned  read_only_space_size =
980           (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
981           (lispobj *)READ_ONLY_SPACE_START;
982       fprintf(stderr,
983               "scavenging read only space: %d bytes\n",
984               read_only_space_size * sizeof(lispobj));
985       pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
986     }
987 #endif
988
989 #ifdef PRINTNOISE
990     printf(" static");
991     fflush(stdout);
992 #endif
993     clean = (lispobj *)STATIC_SPACE_START;
994     do {
995         while (clean != static_free)
996             clean = pscav(clean, static_free - clean, 0);
997         laters = later_blocks;
998         count = later_count;
999         later_blocks = NULL;
1000         later_count = 0;
1001         while (laters != NULL) {
1002             for (i = 0; i < count; i++) {
1003                 if (laters->u[i].count == 0) {
1004                     ;
1005                 } else if (laters->u[i].count <= LATERMAXCOUNT) {
1006                     pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
1007                     i++;
1008                 } else {
1009                     pscav(laters->u[i].ptr, 1, 1);
1010                 }
1011             }
1012             next = laters->next;
1013             free(laters);
1014             laters = next;
1015             count = LATERBLOCKSIZE;
1016         }
1017     } while (clean != static_free || later_blocks != NULL);
1018
1019 #ifdef PRINTNOISE
1020     printf(" cleanup");
1021     fflush(stdout);
1022 #endif
1023
1024     os_zero((os_vm_address_t) current_dynamic_space,
1025             (os_vm_size_t) dynamic_space_size);
1026
1027     /* Zero the stack. */
1028     os_zero((os_vm_address_t) current_control_stack_pointer,
1029             (os_vm_size_t)
1030             ((all_threads->control_stack_end -
1031               current_control_stack_pointer) * sizeof(lispobj)));
1032
1033     /* It helps to update the heap free pointers so that free_heap can
1034      * verify after it's done. */
1035     SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
1036     SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
1037
1038     dynamic_space_free_pointer = current_dynamic_space;
1039     set_auto_gc_trigger(bytes_consed_between_gcs);
1040
1041     /* Blast away instruction cache */
1042     os_flush_icache((os_vm_address_t)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE);
1043     os_flush_icache((os_vm_address_t)STATIC_SPACE_START, STATIC_SPACE_SIZE);
1044
1045 #ifdef PRINTNOISE
1046     printf(" done]\n");
1047     fflush(stdout);
1048 #endif
1049     return 0;
1050 }
1051 #else /* LISP_FEATURE_GENCGC */
1052 int
1053 purify(lispobj static_roots, lispobj read_only_roots)
1054 {
1055     lose("purify called for GENCGC. This should not happen.");
1056 }
1057 #endif /* LISP_FEATURE_GENCGC */