2 * C-level stuff to implement Lisp-level PURIFY
6 * This software is part of the SBCL system. See the README file for
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.
17 #include <sys/types.h>
27 #include "interrupt.h"
31 #include "gc-internal.h"
33 #include "genesis/primitive-objects.h"
34 #include "genesis/static-symbols.h"
35 #include "genesis/layout.h"
36 #include "genesis/hash-table.h"
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.
44 #ifndef LISP_FEATURE_GENCGC
48 static lispobj *dynamic_space_purify_pointer;
51 /* These hold the original end of the read_only and static spaces so
52 * we can tell what are forwarding pointers. */
54 static lispobj *read_only_end, *static_end;
56 static lispobj *read_only_free, *static_free;
58 static lispobj *pscav(lispobj *addr, long nwords, boolean constant);
60 #define LATERBLOCKSIZE 1020
61 #define LATERMAXCOUNT 10
70 } *later_blocks = NULL;
71 static long later_count = 0;
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
81 forwarding_pointer_p(lispobj obj)
83 lispobj *ptr = native_pointer(obj);
85 return ((static_end <= ptr && ptr <= static_free) ||
86 (read_only_end <= ptr && ptr <= read_only_free));
90 dynamic_pointer_p(lispobj ptr)
92 return (ptr >= (lispobj)current_dynamic_space
94 ptr < (lispobj)dynamic_space_purify_pointer);
97 static inline lispobj *
98 newspace_alloc(long nwords, int constantp)
101 nwords=CEILING(nwords,2);
103 if(read_only_free + nwords >= (lispobj *)READ_ONLY_SPACE_END) {
104 lose("Ran out of read-only space while purifying!\n");
107 read_only_free+=nwords;
109 if(static_free + nwords >= (lispobj *)STATIC_SPACE_END) {
110 lose("Ran out of static space while purifying!\n");
120 pscav_later(lispobj *where, long count)
124 if (count > LATERMAXCOUNT) {
125 while (count > LATERMAXCOUNT) {
126 pscav_later(where, LATERMAXCOUNT);
127 count -= LATERMAXCOUNT;
128 where += LATERMAXCOUNT;
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;
143 later_blocks->u[later_count++].count = count;
144 later_blocks->u[later_count++].ptr = where;
149 ptrans_boxed(lispobj thing, lispobj header, boolean constant)
152 lispobj result, *new, *old;
154 nwords = CEILING(1 + HeaderValue(header), 2);
157 old = (lispobj *)native_pointer(thing);
158 new = newspace_alloc(nwords,constant);
161 bcopy(old, new, nwords * sizeof(lispobj));
163 /* Deposit forwarding pointer. */
164 result = make_lispobj(new, lowtag_of(thing));
168 pscav(new, nwords, constant);
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. */
177 ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
179 struct layout *layout =
180 (struct layout *) native_pointer(((struct instance *)native_pointer(thing))->slots[0]);
181 lispobj pure = layout->pure;
185 return (ptrans_boxed(thing, header, 1));
187 return (ptrans_boxed(thing, header, 0));
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. */
196 lispobj result, *new, *old;
198 nwords = CEILING(1 + HeaderValue(header), 2);
201 old = (lispobj *)native_pointer(thing);
202 new = newspace_alloc(nwords, 0); /* inconstant */
205 bcopy(old, new, nwords * sizeof(lispobj));
207 /* Deposit forwarding pointer. */
208 result = make_lispobj(new, lowtag_of(thing));
212 pscav(new, nwords, 1);
218 return NIL; /* dummy value: return something ... */
223 ptrans_fdefn(lispobj thing, lispobj header)
226 lispobj result, *new, *old, oldfn;
229 nwords = CEILING(1 + HeaderValue(header), 2);
232 old = (lispobj *)native_pointer(thing);
233 new = newspace_alloc(nwords, 0); /* inconstant */
236 bcopy(old, new, nwords * sizeof(lispobj));
238 /* Deposit forwarding pointer. */
239 result = make_lispobj(new, lowtag_of(thing));
242 /* Scavenge the function. */
243 fdefn = (struct fdefn *)new;
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;
253 ptrans_unboxed(lispobj thing, lispobj header)
256 lispobj result, *new, *old;
258 nwords = CEILING(1 + HeaderValue(header), 2);
261 old = (lispobj *)native_pointer(thing);
262 new = newspace_alloc(nwords,1); /* always constant */
265 bcopy(old, new, nwords * sizeof(lispobj));
267 /* Deposit forwarding pointer. */
268 result = make_lispobj(new , lowtag_of(thing));
275 ptrans_vector(lispobj thing, long bits, long extra,
276 boolean boxed, boolean constant)
278 struct vector *vector;
280 lispobj result, *new;
283 vector = (struct vector *)native_pointer(thing);
284 length = fixnum_value(vector->length)+extra;
285 // Argh, handle simple-vector-nil separately.
289 nwords = CEILING(NWORDS(length, bits) + 2, 2);
292 new=newspace_alloc(nwords, (constant || !boxed));
293 bcopy(vector, new, nwords * sizeof(lispobj));
295 result = make_lispobj(new, lowtag_of(thing));
296 vector->header = result;
299 pscav(new, nwords, constant);
305 ptrans_code(lispobj thing)
307 struct code *code, *new;
309 lispobj func, result;
311 code = (struct code *)native_pointer(thing);
312 nwords = CEILING(HeaderValue(code->header) + fixnum_value(code->code_size),
315 new = (struct code *)newspace_alloc(nwords,1); /* constant */
317 bcopy(code, new, nwords * sizeof(lispobj));
319 result = make_lispobj(new, OTHER_POINTER_LOWTAG);
321 /* Stick in a forwarding pointer for the code object. */
322 *(lispobj *)code = result;
324 /* Put in forwarding pointers for all the functions. */
325 for (func = code->entry_points;
327 func = ((struct simple_fun *)native_pointer(func))->next) {
329 gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
331 *(lispobj *)native_pointer(func) = result + (func - thing);
334 /* Arrange to scavenge the debug info later. */
335 pscav_later(&new->debug_info, 1);
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)))
344 pscav(&new->trace_table_offset, 1, 0);
346 new->trace_table_offset = NIL; /* limit lifetime */
349 /* Scavenge the constants. */
350 pscav(new->constants, HeaderValue(new->header)-5, 1);
352 /* Scavenge all the functions. */
353 pscav(&new->entry_points, 1, 1);
354 for (func = new->entry_points;
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));
360 pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
361 pscav_later(&((struct simple_fun *)native_pointer(func))->name, 4);
368 ptrans_func(lispobj thing, lispobj header)
371 lispobj code, *new, *old, result;
372 struct simple_fun *function;
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. */
380 if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG) {
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. */
386 function = (struct simple_fun *)native_pointer(thing);
389 ((native_pointer(thing) -
390 (HeaderValue(function->header))), OTHER_POINTER_LOWTAG);
392 /* This will cause the function's header to be replaced with a
393 * forwarding pointer. */
397 /* So we can just return that. */
398 return function->header;
401 /* It's some kind of closure-like thing. */
402 nwords = CEILING(1 + HeaderValue(header), 2);
403 old = (lispobj *)native_pointer(thing);
405 /* Allocate the new one. FINs *must* not go in read_only
406 * space. Closures can; they never change */
409 (nwords,(widetag_of(header)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG));
412 bcopy(old, new, nwords * sizeof(lispobj));
414 /* Deposit forwarding pointer. */
415 result = make_lispobj(new, lowtag_of(thing));
419 pscav(new, nwords, 0);
426 ptrans_returnpc(lispobj thing, lispobj header)
430 /* Find the corresponding code object. */
431 code = thing - HeaderValue(header)*sizeof(lispobj);
433 /* Make sure it's been transported. */
434 new = *(lispobj *)native_pointer(code);
435 if (!forwarding_pointer_p(new))
436 new = ptrans_code(code);
438 /* Maintain the offset: */
439 return new + (thing - code);
442 #define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
445 ptrans_list(lispobj thing, boolean constant)
447 struct cons *old, *new, *orig;
450 orig = (struct cons *) newspace_alloc(0,constant);
454 /* Allocate a new cons cell. */
455 old = (struct cons *)native_pointer(thing);
456 new = (struct cons *) newspace_alloc(WORDS_PER_CONS,constant);
458 /* Copy the cons cell and keep a pointer to the cdr. */
460 thing = new->cdr = old->cdr;
462 /* Set up the forwarding pointer. */
463 *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG);
465 /* And count this cell. */
467 } while (lowtag_of(thing) == LIST_POINTER_LOWTAG &&
468 dynamic_pointer_p(thing) &&
469 !(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
471 /* Scavenge the list we just copied. */
472 pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
474 return make_lispobj(orig, LIST_POINTER_LOWTAG);
478 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
480 switch (widetag_of(header)) {
481 /* FIXME: this needs a reindent */
483 case SINGLE_FLOAT_WIDETAG:
484 case DOUBLE_FLOAT_WIDETAG:
485 #ifdef LONG_FLOAT_WIDETAG
486 case LONG_FLOAT_WIDETAG:
488 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
489 case COMPLEX_SINGLE_FLOAT_WIDETAG:
491 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
492 case COMPLEX_DOUBLE_FLOAT_WIDETAG:
494 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
495 case COMPLEX_LONG_FLOAT_WIDETAG:
498 return ptrans_unboxed(thing, header);
501 gencgc_unregister_lutex((struct lutex *) native_pointer(thing));
502 return ptrans_unboxed(thing, header);
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:
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);
518 case VALUE_CELL_HEADER_WIDETAG:
519 case WEAK_POINTER_WIDETAG:
520 return ptrans_boxed(thing, header, 0);
522 case SYMBOL_HEADER_WIDETAG:
523 return ptrans_boxed(thing, header, 0);
525 case SIMPLE_ARRAY_NIL_WIDETAG:
526 return ptrans_vector(thing, 0, 0, 0, constant);
528 case SIMPLE_BASE_STRING_WIDETAG:
529 return ptrans_vector(thing, 8, 1, 0, constant);
531 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
532 case SIMPLE_CHARACTER_STRING_WIDETAG:
533 return ptrans_vector(thing, 32, 1, 0, constant);
536 case SIMPLE_BIT_VECTOR_WIDETAG:
537 return ptrans_vector(thing, 1, 0, 0, constant);
539 case SIMPLE_VECTOR_WIDETAG:
540 return ptrans_vector(thing, N_WORD_BITS, 0, 1, constant);
542 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
543 return ptrans_vector(thing, 2, 0, 0, constant);
545 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
546 return ptrans_vector(thing, 4, 0, 0, constant);
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:
553 return ptrans_vector(thing, 8, 0, 0, constant);
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:
560 return ptrans_vector(thing, 16, 0, 0, constant);
562 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
563 case SIMPLE_ARRAY_FIXNUM_WIDETAG:
564 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
565 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
566 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
567 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
569 return ptrans_vector(thing, 32, 0, 0, constant);
571 #if N_WORD_BITS == 64
572 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
573 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
575 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
576 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
578 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
579 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
581 return ptrans_vector(thing, 64, 0, 0, constant);
584 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
585 return ptrans_vector(thing, 32, 0, 0, constant);
587 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
588 return ptrans_vector(thing, 64, 0, 0, constant);
590 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
591 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
592 #ifdef LISP_FEATURE_SPARC
593 return ptrans_vector(thing, 128, 0, 0, constant);
597 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
598 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
599 return ptrans_vector(thing, 64, 0, 0, constant);
602 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
603 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
604 return ptrans_vector(thing, 128, 0, 0, constant);
607 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
608 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
609 #ifdef LISP_FEATURE_SPARC
610 return ptrans_vector(thing, 256, 0, 0, constant);
614 case CODE_HEADER_WIDETAG:
615 return ptrans_code(thing);
617 case RETURN_PC_HEADER_WIDETAG:
618 return ptrans_returnpc(thing, header);
621 return ptrans_fdefn(thing, header);
624 fprintf(stderr, "Invalid widetag: %d\n", widetag_of(header));
625 /* Should only come across other pointers to the above stuff. */
632 pscav_fdefn(struct fdefn *fdefn)
636 fix_func = ((char *)(fdefn->fun+FUN_RAW_ADDR_OFFSET) == fdefn->raw_addr);
637 pscav(&fdefn->name, 1, 1);
638 pscav(&fdefn->fun, 1, 0);
640 fdefn->raw_addr = (char *)(fdefn->fun + FUN_RAW_ADDR_OFFSET);
641 return sizeof(struct fdefn) / sizeof(lispobj);
645 pscav(lispobj *addr, long nwords, boolean constant)
647 lispobj thing, *thingp, header;
648 long count = 0; /* (0 = dummy init value to stop GCC warning) */
649 struct vector *vector;
653 if (is_lisp_pointer(thing)) {
654 /* It's a pointer. Is it something we might have to move? */
655 if (dynamic_pointer_p(thing)) {
656 /* Maybe. Have we already moved it? */
657 thingp = (lispobj *)native_pointer(thing);
659 if (is_lisp_pointer(header) && forwarding_pointer_p(header))
660 /* Yep, so just copy the forwarding pointer. */
663 /* Nope, copy the object. */
664 switch (lowtag_of(thing)) {
665 case FUN_POINTER_LOWTAG:
666 thing = ptrans_func(thing, header);
669 case LIST_POINTER_LOWTAG:
670 thing = ptrans_list(thing, constant);
673 case INSTANCE_POINTER_LOWTAG:
674 thing = ptrans_instance(thing, header, constant);
677 case OTHER_POINTER_LOWTAG:
678 thing = ptrans_otherptr(thing, header, constant);
682 /* It was a pointer, but not one of them? */
690 #if N_WORD_BITS == 64
691 else if (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) {
695 else if (thing & FIXNUM_TAG_MASK) {
696 /* It's an other immediate. Maybe the header for an unboxed */
698 switch (widetag_of(thing)) {
700 case SINGLE_FLOAT_WIDETAG:
701 case DOUBLE_FLOAT_WIDETAG:
702 #ifdef LONG_FLOAT_WIDETAG
703 case LONG_FLOAT_WIDETAG:
706 /* It's an unboxed simple object. */
707 count = CEILING(HeaderValue(thing)+1, 2);
710 case SIMPLE_VECTOR_WIDETAG:
711 if (HeaderValue(thing) == subtype_VectorValidHashing) {
712 struct hash_table *hash_table =
713 (struct hash_table *)native_pointer(addr[2]);
714 hash_table->needs_rehash_p = T;
719 case SIMPLE_ARRAY_NIL_WIDETAG:
723 case SIMPLE_BASE_STRING_WIDETAG:
724 vector = (struct vector *)addr;
725 count = CEILING(NWORDS(fixnum_value(vector->length)+1,8)+2,2);
728 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
729 case SIMPLE_CHARACTER_STRING_WIDETAG:
730 vector = (struct vector *)addr;
731 count = CEILING(NWORDS(fixnum_value(vector->length)+1,32)+2,2);
735 case SIMPLE_BIT_VECTOR_WIDETAG:
736 vector = (struct vector *)addr;
737 count = CEILING(NWORDS(fixnum_value(vector->length),1)+2,2);
740 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
741 vector = (struct vector *)addr;
742 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
745 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
746 vector = (struct vector *)addr;
747 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
750 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
751 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
752 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
753 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
755 vector = (struct vector *)addr;
756 count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
759 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
760 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
761 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
762 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
764 vector = (struct vector *)addr;
765 count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
768 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
770 case SIMPLE_ARRAY_FIXNUM_WIDETAG:
771 case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
773 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
774 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
775 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
777 vector = (struct vector *)addr;
778 count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
781 #if N_WORD_BITS == 64
782 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
783 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
784 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
785 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
787 vector = (struct vector *)addr;
788 count = CEILING(NWORDS(fixnum_value(vector->length),64)+2,2);
792 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
793 vector = (struct vector *)addr;
794 count = CEILING(NWORDS(fixnum_value(vector->length), 32) + 2,
798 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
799 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
800 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
802 vector = (struct vector *)addr;
803 count = CEILING(NWORDS(fixnum_value(vector->length), 64) + 2,
807 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
808 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
809 vector = (struct vector *)addr;
810 #ifdef LISP_FEATURE_SPARC
811 count = fixnum_value(vector->length)*4+2;
816 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
817 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
818 vector = (struct vector *)addr;
819 count = CEILING(NWORDS(fixnum_value(vector->length), 128) + 2,
824 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
825 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
826 vector = (struct vector *)addr;
827 #ifdef LISP_FEATURE_SPARC
828 count = fixnum_value(vector->length)*8+2;
833 case CODE_HEADER_WIDETAG:
834 gc_abort(); /* no code headers in static space */
837 case SIMPLE_FUN_HEADER_WIDETAG:
838 case RETURN_PC_HEADER_WIDETAG:
839 /* We should never hit any of these, 'cause they occur
840 * buried in the middle of code objects. */
844 case WEAK_POINTER_WIDETAG:
845 /* Weak pointers get preserved during purify, 'cause I
846 * don't feel like figuring out how to break them. */
847 pscav(addr+1, 2, constant);
852 /* We have to handle fdefn objects specially, so we
853 * can fix up the raw function address. */
854 count = pscav_fdefn((struct fdefn *)addr);
857 case INSTANCE_HEADER_WIDETAG:
859 struct instance *instance = (struct instance *) addr;
860 struct layout *layout
861 = (struct layout *) native_pointer(instance->slots[0]);
862 long nuntagged = fixnum_value(layout->n_untagged_slots);
863 long nslots = HeaderValue(*addr);
864 pscav(addr + 1, nslots - nuntagged, constant);
865 count = CEILING(1 + nslots, 2);
887 purify(lispobj static_roots, lispobj read_only_roots)
891 struct later *laters, *next;
892 struct thread *thread;
894 if(all_threads->next) {
895 /* FIXME: there should be _some_ sensible error reporting
896 * convention. See following comment too */
897 fprintf(stderr,"Can't purify when more than one thread exists\n");
903 printf("[doing purification:");
907 for_each_thread(thread)
908 if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
909 /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
910 * its error simply by a. printing a string b. to stdout instead
912 printf(" Ack! Can't purify interrupt contexts. ");
917 dynamic_space_purify_pointer = dynamic_space_free_pointer;
919 read_only_end = read_only_free =
920 (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
921 static_end = static_free =
922 (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
929 pscav(&static_roots, 1, 0);
930 pscav(&read_only_roots, 1, 1);
936 pscav((lispobj *) interrupt_handlers,
937 sizeof(interrupt_handlers) / sizeof(lispobj),
944 pscav((lispobj *)all_threads->control_stack_start,
945 access_control_stack_pointer(all_threads) -
946 all_threads->control_stack_start,
954 pscav( (lispobj *)all_threads->binding_stack_start,
955 (lispobj *)get_binding_stack_pointer(all_threads) -
956 all_threads->binding_stack_start,
959 /* The original CMU CL code had scavenge-read-only-space code
960 * controlled by the Lisp-level variable
961 * *SCAVENGE-READ-ONLY-SPACE*. It was disabled by default, and it
962 * wasn't documented under what circumstances it was useful or
963 * safe to turn it on, so it's been turned off in SBCL. If you
964 * want/need this functionality, and can test and document it,
965 * please submit a patch. */
967 if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != UNBOUND_MARKER_WIDETAG
968 && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
969 unsigned read_only_space_size =
970 (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
971 (lispobj *)READ_ONLY_SPACE_START;
973 "scavenging read only space: %d bytes\n",
974 read_only_space_size * sizeof(lispobj));
975 pscav( (lispobj *)READ_ONLY_SPACE_START, read_only_space_size, 0);
983 clean = (lispobj *)STATIC_SPACE_START;
985 while (clean != static_free)
986 clean = pscav(clean, static_free - clean, 0);
987 laters = later_blocks;
991 while (laters != NULL) {
992 for (i = 0; i < count; i++) {
993 if (laters->u[i].count == 0) {
995 } else if (laters->u[i].count <= LATERMAXCOUNT) {
996 pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
999 pscav(laters->u[i].ptr, 1, 1);
1002 next = laters->next;
1005 count = LATERBLOCKSIZE;
1007 } while (clean != static_free || later_blocks != NULL);
1013 #ifdef LISP_FEATURE_HPUX
1014 clear_auto_gc_trigger(); /* restore mmap as it was given by os */
1017 os_zero((os_vm_address_t) current_dynamic_space,
1018 (os_vm_size_t) dynamic_space_size);
1020 /* Zero the stack. */
1021 os_zero((os_vm_address_t) access_control_stack_pointer(all_threads),
1023 ((all_threads->control_stack_end -
1024 access_control_stack_pointer(all_threads)) * sizeof(lispobj)));
1026 /* It helps to update the heap free pointers so that free_heap can
1027 * verify after it's done. */
1028 SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
1029 SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
1031 dynamic_space_free_pointer = current_dynamic_space;
1032 set_auto_gc_trigger(bytes_consed_between_gcs);
1034 /* Blast away instruction cache */
1035 os_flush_icache((os_vm_address_t)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE);
1036 os_flush_icache((os_vm_address_t)STATIC_SPACE_START, STATIC_SPACE_SIZE);
1044 #else /* LISP_FEATURE_GENCGC */
1046 purify(lispobj static_roots, lispobj read_only_roots)
1048 lose("purify called for GENCGC. This should not happen.");
1050 #endif /* LISP_FEATURE_GENCGC */