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