0.8.7.3
[sbcl.git] / src / runtime / purify.c
index dc66cd2..cb7ed3f 100644 (file)
@@ -17,6 +17,7 @@
 #include <sys/types.h>
 #include <stdlib.h>
 #include <strings.h>
+#include <errno.h>
 
 #include "runtime.h"
 #include "os.h"
 #include "interrupt.h"
 #include "purify.h"
 #include "interr.h"
-#ifdef GENCGC
-#include "gencgc.h"
-#endif
+#include "gc.h"
+#include "gc-internal.h"
+#include "thread.h"
+#include "genesis/primitive-objects.h"
+#include "genesis/static-symbols.h"
 
 #define PRINTNOISE
 
-#if defined(__i386__)
+#if defined(LISP_FEATURE_X86)
 /* again, what's so special about the x86 that this is differently
  * visible there than on other platforms? -dan 20010125 
  */
 static lispobj *dynamic_space_free_pointer;
 #endif
+extern unsigned long bytes_consed_between_gcs;
 
 #define gc_abort() \
   lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__)
@@ -76,7 +80,9 @@ static int later_count = 0;
 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
 
-/* FIXME: (1) Shouldn't this be defined in sbcl.h? */
+/* FIXME: Shouldn't this be defined in sbcl.h?  See also notes in
+ * cheneygc.c */
+
 #ifdef sparc
 #define FUN_RAW_ADDR_OFFSET 0
 #else
@@ -86,9 +92,7 @@ static int later_count = 0;
 static boolean
 forwarding_pointer_p(lispobj obj)
 {
-    lispobj *ptr;
-
-    ptr = (lispobj *)obj;
+    lispobj *ptr = native_pointer(obj);
 
     return ((static_end <= ptr && ptr <= static_free) ||
             (read_only_end <= ptr && ptr <= read_only_free));
@@ -97,7 +101,7 @@ forwarding_pointer_p(lispobj obj)
 static boolean
 dynamic_pointer_p(lispobj ptr)
 {
-#ifndef __i386__
+#ifndef LISP_FEATURE_GENCGC
     return (ptr >= (lispobj)current_dynamic_space
            &&
            ptr < (lispobj)dynamic_space_free_pointer);
@@ -109,10 +113,25 @@ dynamic_pointer_p(lispobj ptr)
 #endif
 }
 
+static inline newspace_alloc(int nwords, int constantp) 
+{
+    lispobj *ret;
+    nwords=CEILING(nwords,2);
+    if(constantp) {
+       ret=read_only_free;
+       read_only_free+=nwords;
+    } else {
+       ret=static_free;
+       static_free+=nwords;
+    }
+    return ret;
+}
+
+
 \f
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
 
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
 /*
  * enhanced x86/GENCGC stack scavenging by Douglas Crosher
  *
@@ -125,17 +144,13 @@ dynamic_pointer_p(lispobj ptr)
 
 static unsigned pointer_filter_verbose = 0;
 
-/* FIXME: This is substantially the same code as in gencgc.c. (There
- * are some differences, at least (1) the gencgc.c code needs to worry
- * about return addresses on the stack pinning code objects, (2) the
- * gencgc.c code needs to worry about the GC maybe happening in an
- * interrupt service routine when the main thread of control was
- * interrupted just as it had allocated memory and before it
- * initialized it, while PURIFY needn't worry about that, and (3) the
- * gencgc.c code has mutated more under maintenance since the fork
- * from CMU CL than the code here has.) The two versions should be
- * made to explicitly share common code, instead of just two different
- * cut-and-pasted versions. */
+/* FIXME: This is substantially the same code as
+ * possibly_valid_dynamic_space_pointer in gencgc.c.  The only
+ * relevant difference seems to be that the gencgc code also checks
+ * for raw pointers into Code objects, whereas in purify these are
+ * checked separately in setup_i386_stack_scav - they go onto
+ * valid_stack_ra_locations instead of just valid_stack_locations */
+
 static int
 valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
 {
@@ -267,7 +282,8 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
        case COMPLEX_LONG_FLOAT_WIDETAG:
 #endif
        case SIMPLE_ARRAY_WIDETAG:
-       case COMPLEX_STRING_WIDETAG:
+       case COMPLEX_BASE_STRING_WIDETAG:
+       case COMPLEX_VECTOR_NIL_WIDETAG:
        case COMPLEX_BIT_VECTOR_WIDETAG:
        case COMPLEX_VECTOR_WIDETAG:
        case COMPLEX_ARRAY_WIDETAG:
@@ -281,12 +297,17 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
 #ifdef LONG_FLOAT_WIDETAG
        case LONG_FLOAT_WIDETAG:
 #endif
-       case SIMPLE_STRING_WIDETAG:
+       case SIMPLE_ARRAY_NIL_WIDETAG:
+       case SIMPLE_BASE_STRING_WIDETAG:
        case SIMPLE_BIT_VECTOR_WIDETAG:
        case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
        case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
+       case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
        case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
+       case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
        case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
+       case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
+       case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
        case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
        case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
@@ -363,6 +384,11 @@ setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
             * return addresses. This will also pick up pointers to
             * functions in code objects. */
            if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
+               /* FIXME asserting here is a really dumb thing to do.
+                * If we've overflowed some arbitrary static limit, we
+                * should just refuse to purify, instead of killing
+                * the whole lisp session
+                */
                gc_assert(num_valid_stack_ra_locations <
                          MAX_STACK_RETURN_ADDRESSES);
                valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
@@ -450,20 +476,13 @@ ptrans_boxed(lispobj thing, lispobj header, boolean constant)
 
     /* Allocate it */
     old = (lispobj *)native_pointer(thing);
-    if (constant) {
-        new = read_only_free;
-        read_only_free += CEILING(nwords, 2);
-    }
-    else {
-        new = static_free;
-        static_free += CEILING(nwords, 2);
-    }
+    new = newspace_alloc(nwords,constant);
 
     /* Copy it. */
     bcopy(old, new, nwords * sizeof(lispobj));
 
     /* Deposit forwarding pointer. */
-    result = (lispobj)new | lowtag_of(thing);
+    result = make_lispobj(new, lowtag_of(thing));
     *old = result;
 
     /* Scavenge it. */
@@ -476,7 +495,7 @@ ptrans_boxed(lispobj thing, lispobj header, boolean constant)
  * class, and only then can we transport as constant. If it is pure,
  * we can ALWAYS transport as a constant. */
 static lispobj
-ptrans_instance(lispobj thing, lispobj header, boolean constant)
+ptrans_instance(lispobj thing, lispobj header, boolean /* ignored */ constant)
 {
     lispobj layout = ((struct instance *)native_pointer(thing))->slots[0];
     lispobj pure = ((struct instance *)native_pointer(layout))->slots[15];
@@ -500,14 +519,13 @@ ptrans_instance(lispobj thing, lispobj header, boolean constant)
 
            /* Allocate it */
            old = (lispobj *)native_pointer(thing);
-           new = static_free;
-           static_free += CEILING(nwords, 2);
+           new = newspace_alloc(nwords, 0); /*  inconstant */
 
            /* Copy it. */
            bcopy(old, new, nwords * sizeof(lispobj));
 
            /* Deposit forwarding pointer. */
-           result = (lispobj)new | lowtag_of(thing);
+           result = make_lispobj(new, lowtag_of(thing));
            *old = result;
 
            /* Scavenge it. */
@@ -532,14 +550,13 @@ ptrans_fdefn(lispobj thing, lispobj header)
 
     /* Allocate it */
     old = (lispobj *)native_pointer(thing);
-    new = static_free;
-    static_free += CEILING(nwords, 2);
+    new = newspace_alloc(nwords, 0);   /* inconstant */
 
     /* Copy it. */
     bcopy(old, new, nwords * sizeof(lispobj));
 
     /* Deposit forwarding pointer. */
-    result = (lispobj)new | lowtag_of(thing);
+    result = make_lispobj(new, lowtag_of(thing));
     *old = result;
 
     /* Scavenge the function. */
@@ -557,19 +574,18 @@ ptrans_unboxed(lispobj thing, lispobj header)
 {
     int nwords;
     lispobj result, *new, *old;
-
+    
     nwords = 1 + HeaderValue(header);
-
+    
     /* Allocate it */
     old = (lispobj *)native_pointer(thing);
-    new = read_only_free;
-    read_only_free += CEILING(nwords, 2);
-
-    /* Copy it. */
+    new = newspace_alloc(nwords,1);    /* always constant */
+    
+    /* copy it. */
     bcopy(old, new, nwords * sizeof(lispobj));
-
+    
     /* Deposit forwarding pointer. */
-    result = (lispobj)new | lowtag_of(thing);
+    result = make_lispobj(new , lowtag_of(thing));
     *old = result;
 
     return result;
@@ -586,18 +602,10 @@ ptrans_vector(lispobj thing, int bits, int extra,
     vector = (struct vector *)native_pointer(thing);
     nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5);
 
-    if (boxed && !constant) {
-        new = static_free;
-        static_free += CEILING(nwords, 2);
-    }
-    else {
-        new = read_only_free;
-        read_only_free += CEILING(nwords, 2);
-    }
-
+    new=newspace_alloc(nwords, (constant || !boxed));
     bcopy(vector, new, nwords * sizeof(lispobj));
 
-    result = (lispobj)new | lowtag_of(thing);
+    result = make_lispobj(new, lowtag_of(thing));
     vector->header = result;
 
     if (boxed)
@@ -606,7 +614,7 @@ ptrans_vector(lispobj thing, int bits, int extra,
     return result;
 }
 
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
 static void
 apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
 {
@@ -635,7 +643,7 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
     if ((fixups==0) ||
        (fixups==UNBOUND_MARKER_WIDETAG) ||
        !is_lisp_pointer(fixups)) {
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
        /* Check for a possible errors. */
        sniff_code_object(new_code,displacement);
 #endif
@@ -683,7 +691,7 @@ apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
     /* No longer need the fixups. */
     new_code->constants[0] = 0;
 
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
     /* Check for possible errors. */
     sniff_code_object(new_code,displacement);
 #endif
@@ -700,16 +708,15 @@ ptrans_code(lispobj thing)
     code = (struct code *)native_pointer(thing);
     nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
 
-    new = (struct code *)read_only_free;
-    read_only_free += CEILING(nwords, 2);
+    new = (struct code *)newspace_alloc(nwords,1); /* constant */
 
     bcopy(code, new, nwords * sizeof(lispobj));
 
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
     apply_code_fixups_during_purify(code,new);
 #endif
 
-    result = (lispobj)new | OTHER_POINTER_LOWTAG;
+    result = make_lispobj(new, OTHER_POINTER_LOWTAG);
 
     /* Stick in a forwarding pointer for the code object. */
     *(lispobj *)code = result;
@@ -727,11 +734,12 @@ ptrans_code(lispobj thing)
     /* Arrange to scavenge the debug info later. */
     pscav_later(&new->debug_info, 1);
 
-    if (new->trace_table_offset & 0x3)
+    /* FIXME: why would this be a fixnum? */
+    if (!(new->trace_table_offset & (EVEN_FIXNUM_LOWTAG|ODD_FIXNUM_LOWTAG)))
 #if 0
-      pscav(&new->trace_table_offset, 1, 0);
+       pscav(&new->trace_table_offset, 1, 0);
 #else
-      new->trace_table_offset = NIL; /* limit lifetime */
+        new->trace_table_offset = NIL; /* limit lifetime */
 #endif
 
     /* Scavenge the constants. */
@@ -745,13 +753,13 @@ ptrans_code(lispobj thing)
         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
         gc_assert(!dynamic_pointer_p(func));
 
-#ifdef __i386__
-       /* Temporarly convert the self pointer to a real function pointer. */
+#ifdef LISP_FEATURE_X86
+       /* Temporarily convert the self pointer to a real function pointer. */
        ((struct simple_fun *)native_pointer(func))->self
            -= FUN_RAW_ADDR_OFFSET;
 #endif
         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
        ((struct simple_fun *)native_pointer(func))->self
            += FUN_RAW_ADDR_OFFSET;
 #endif
@@ -774,8 +782,7 @@ ptrans_func(lispobj thing, lispobj header)
      * Otherwise we have to do something strange, 'cause it is buried
      * inside a code object. */
 
-    if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG ||
-        widetag_of(header) == CLOSURE_FUN_HEADER_WIDETAG) {
+    if (widetag_of(header) == SIMPLE_FUN_HEADER_WIDETAG) {
 
        /* We can only end up here if the code object has not been
          * scavenged, because if it had been scavenged, forwarding pointers
@@ -783,12 +790,13 @@ ptrans_func(lispobj thing, lispobj header)
 
         function = (struct simple_fun *)native_pointer(thing);
         code =
-           (native_pointer(thing) -
-            (HeaderValue(function->header)*sizeof(lispobj))) |
-            OTHER_POINTER_LOWTAG;
-
+           make_lispobj
+           ((native_pointer(thing) -
+             (HeaderValue(function->header))), OTHER_POINTER_LOWTAG);
+       
         /* This will cause the function's header to be replaced with a 
          * forwarding pointer. */
+
         ptrans_code(code);
 
         /* So we can just return that. */
@@ -799,24 +807,17 @@ ptrans_func(lispobj thing, lispobj header)
         nwords = 1 + HeaderValue(header);
         old = (lispobj *)native_pointer(thing);
 
-       /* Allocate the new one. */
-       if (widetag_of(header) == FUNCALLABLE_INSTANCE_HEADER_WIDETAG) {
-           /* FINs *must* not go in read_only space. */
-           new = static_free;
-           static_free += CEILING(nwords, 2);
-       }
-       else {
-           /* Closures can always go in read-only space, 'cause they
-            * never change. */
+       /* Allocate the new one.  FINs *must* not go in read_only
+        * space.  Closures can; they never change */
 
-           new = read_only_free;
-           read_only_free += CEILING(nwords, 2);
-       }
+       new = newspace_alloc
+           (nwords,(widetag_of(header)!=FUNCALLABLE_INSTANCE_HEADER_WIDETAG));
+            
         /* Copy it. */
         bcopy(old, new, nwords * sizeof(lispobj));
 
         /* Deposit forwarding pointer. */
-        result = (lispobj)new | lowtag_of(thing);
+        result = make_lispobj(new, lowtag_of(thing));
         *old = result;
 
         /* Scavenge it. */
@@ -851,30 +852,20 @@ ptrans_list(lispobj thing, boolean constant)
     struct cons *old, *new, *orig;
     int length;
 
-    if (constant)
-        orig = (struct cons *)read_only_free;
-    else
-        orig = (struct cons *)static_free;
+    orig = newspace_alloc(0,constant);
     length = 0;
 
     do {
         /* Allocate a new cons cell. */
         old = (struct cons *)native_pointer(thing);
-        if (constant) {
-            new = (struct cons *)read_only_free;
-            read_only_free += WORDS_PER_CONS;
-        }
-        else {
-            new = (struct cons *)static_free;
-            static_free += WORDS_PER_CONS;
-        }
+       new = (struct cons *) newspace_alloc(WORDS_PER_CONS,constant);
 
         /* Copy the cons cell and keep a pointer to the cdr. */
         new->car = old->car;
         thing = new->cdr = old->cdr;
 
         /* Set up the forwarding pointer. */
-        *(lispobj *)old = ((lispobj)new) | LIST_POINTER_LOWTAG;
+        *(lispobj *)old = make_lispobj(new, LIST_POINTER_LOWTAG);
 
         /* And count this cell. */
         length++;
@@ -885,13 +876,14 @@ ptrans_list(lispobj thing, boolean constant)
     /* Scavenge the list we just copied. */
     pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
 
-    return ((lispobj)orig) | LIST_POINTER_LOWTAG;
+    return make_lispobj(orig, LIST_POINTER_LOWTAG);
 }
 
 static lispobj
 ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 {
     switch (widetag_of(header)) {
+       /* FIXME: this needs a reindent */
       case BIGNUM_WIDETAG:
       case SINGLE_FLOAT_WIDETAG:
       case DOUBLE_FLOAT_WIDETAG:
@@ -908,12 +900,14 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
       case COMPLEX_LONG_FLOAT_WIDETAG:
 #endif
       case SAP_WIDETAG:
-        return ptrans_unboxed(thing, header);
+         return ptrans_unboxed(thing, header);
 
       case RATIO_WIDETAG:
       case COMPLEX_WIDETAG:
       case SIMPLE_ARRAY_WIDETAG:
-      case COMPLEX_STRING_WIDETAG:
+      case COMPLEX_BASE_STRING_WIDETAG:
+      case COMPLEX_BIT_VECTOR_WIDETAG:
+      case COMPLEX_VECTOR_NIL_WIDETAG:
       case COMPLEX_VECTOR_WIDETAG:
       case COMPLEX_ARRAY_WIDETAG:
         return ptrans_boxed(thing, header, constant);
@@ -925,7 +919,10 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
       case SYMBOL_HEADER_WIDETAG:
         return ptrans_boxed(thing, header, 0);
 
-      case SIMPLE_STRING_WIDETAG:
+      case SIMPLE_ARRAY_NIL_WIDETAG:
+        return ptrans_vector(thing, 0, 0, 0, constant);
+
+      case SIMPLE_BASE_STRING_WIDETAG:
         return ptrans_vector(thing, 8, 1, 0, constant);
 
       case SIMPLE_BIT_VECTOR_WIDETAG:
@@ -943,21 +940,25 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
       case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
       case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
+      case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
 #endif
         return ptrans_vector(thing, 8, 0, 0, constant);
 
       case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
       case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
+      case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
 #endif
         return ptrans_vector(thing, 16, 0, 0, constant);
 
       case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
       case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
+      case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
 #endif
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
       case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
+      case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
 #endif
         return ptrans_vector(thing, 32, 0, 0, constant);
 
@@ -969,7 +970,7 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 
 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
       case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
         return ptrans_vector(thing, 96, 0, 0, constant);
 #endif
 #ifdef sparc
@@ -989,7 +990,7 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 
 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
       case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
         return ptrans_vector(thing, 192, 0, 0, constant);
 #endif
 #ifdef sparc
@@ -1026,7 +1027,7 @@ pscav_fdefn(struct fdefn *fdefn)
     return sizeof(struct fdefn) / sizeof(lispobj);
 }
 
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
 /* now putting code objects in static space */
 static int
 pscav_code(struct code*code)
@@ -1049,14 +1050,14 @@ pscav_code(struct code*code)
         gc_assert(lowtag_of(func) == FUN_POINTER_LOWTAG);
         gc_assert(!dynamic_pointer_p(func));
 
-#ifdef __i386__
-       /* Temporarly convert the self pointer to a real function
+#ifdef LISP_FEATURE_X86
+       /* Temporarily convert the self pointer to a real function
         * pointer. */
        ((struct simple_fun *)native_pointer(func))->self
            -= FUN_RAW_ADDR_OFFSET;
 #endif
         pscav(&((struct simple_fun *)native_pointer(func))->self, 2, 1);
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
        ((struct simple_fun *)native_pointer(func))->self
            += FUN_RAW_ADDR_OFFSET;
 #endif
@@ -1113,7 +1114,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
             }
             count = 1;
         }
-        else if (thing & 3) {
+        else if (thing & 3) {  /* FIXME: 3?  not 2? */
             /* It's an other immediate. Maybe the header for an unboxed */
             /* object. */
             switch (widetag_of(thing)) {
@@ -1136,7 +1137,11 @@ pscav(lispobj *addr, int nwords, boolean constant)
                 count = 1;
                 break;
 
-              case SIMPLE_STRING_WIDETAG:
+             case SIMPLE_ARRAY_NIL_WIDETAG:
+               count = 2;
+               break;
+
+              case SIMPLE_BASE_STRING_WIDETAG:
                 vector = (struct vector *)addr;
                 count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2);
                 break;
@@ -1159,6 +1164,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
               case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
               case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
+              case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
 #endif
                 vector = (struct vector *)addr;
                 count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
@@ -1167,6 +1173,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
               case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
               case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
+              case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
 #endif
                 vector = (struct vector *)addr;
                 count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
@@ -1175,9 +1182,11 @@ pscav(lispobj *addr, int nwords, boolean constant)
               case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
               case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG:
+             case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
 #endif
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
               case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
+              case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
 #endif
                 vector = (struct vector *)addr;
                 count = CEILING(fixnum_value(vector->length)+2,2);
@@ -1199,7 +1208,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
               case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
                 vector = (struct vector *)addr;
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
                 count = fixnum_value(vector->length)*3+2;
 #endif
 #ifdef sparc
@@ -1218,7 +1227,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
               case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
                 vector = (struct vector *)addr;
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
                 count = fixnum_value(vector->length)*6+2;
 #endif
 #ifdef sparc
@@ -1228,7 +1237,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
 #endif
 
               case CODE_HEADER_WIDETAG:
-#ifndef __i386__
+#ifndef LISP_FEATURE_X86
                 gc_abort(); /* no code headers in static space */
 #else
                count = pscav_code((struct code*)addr);
@@ -1236,14 +1245,13 @@ pscav(lispobj *addr, int nwords, boolean constant)
                 break;
 
               case SIMPLE_FUN_HEADER_WIDETAG:
-              case CLOSURE_FUN_HEADER_WIDETAG:
               case RETURN_PC_HEADER_WIDETAG:
                 /* We should never hit any of these, 'cause they occur
                  * buried in the middle of code objects. */
                 gc_abort();
                break;
 
-#ifdef __i386__
+#ifdef LISP_FEATURE_X86
              case CLOSURE_HEADER_WIDETAG:
              case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
                /* The function self pointer needs special care on the
@@ -1294,13 +1302,25 @@ purify(lispobj static_roots, lispobj read_only_roots)
     lispobj *clean;
     int count, i;
     struct later *laters, *next;
+    struct thread *thread;
+
+    if(all_threads->next) {
+       /* FIXME: there should be _some_ sensible error reporting 
+        * convention.  See following comment too */
+       fprintf(stderr,"Can't purify when more than one thread exists\n");
+       fflush(stderr);
+       return 0;
+    }
 
 #ifdef PRINTNOISE
     printf("[doing purification:");
     fflush(stdout);
 #endif
-
-    if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
+#ifdef LISP_FEATURE_GENCGC
+    gc_alloc_update_all_page_tables();
+#endif
+    for_each_thread(thread)
+       if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
        /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
         * its error simply by a. printing a string b. to stdout instead
         * of stderr. */
@@ -1309,26 +1329,27 @@ purify(lispobj static_roots, lispobj read_only_roots)
         return 0;
     }
 
-#if defined(__i386__)
+#if defined(LISP_FEATURE_X86)
     dynamic_space_free_pointer =
-      (lispobj*)SymbolValue(ALLOCATION_POINTER);
+      (lispobj*)SymbolValue(ALLOCATION_POINTER,0);
 #endif
 
     read_only_end = read_only_free =
-        (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
+        (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
     static_end = static_free =
-        (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER);
+        (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
 
 #ifdef PRINTNOISE
     printf(" roots");
     fflush(stdout);
 #endif
 
-#ifdef GENCGC
-    gc_assert((lispobj *)CONTROL_STACK_END > ((&read_only_roots)+1));
-    setup_i386_stack_scav(((&static_roots)-2), (lispobj *)CONTROL_STACK_END);
-#endif
-
+    /* note this expects only one thread to be active.  We'd have to 
+     * stop all the others in the same way as GC does if we wanted 
+     * PURIFY to work when >1 thread exists */
+    setup_i386_stack_scav(((&static_roots)-2),
+                         ((void *)all_threads->control_stack_end));
+    
     pscav(&static_roots, 1, 0);
     pscav(&read_only_roots, 1, 1);
 
@@ -1336,20 +1357,22 @@ purify(lispobj static_roots, lispobj read_only_roots)
     printf(" handlers");
     fflush(stdout);
 #endif
-    pscav((lispobj *) interrupt_handlers,
-          sizeof(interrupt_handlers) / sizeof(lispobj),
+    pscav((lispobj *) all_threads->interrupt_data->interrupt_handlers,
+          sizeof(all_threads->interrupt_data->interrupt_handlers)
+         / sizeof(lispobj),
           0);
 
 #ifdef PRINTNOISE
     printf(" stack");
     fflush(stdout);
 #endif
-#ifndef __i386__
-    pscav((lispobj *)CONTROL_STACK_START,
-         current_control_stack_pointer - (lispobj *)CONTROL_STACK_START,
+#ifndef LISP_FEATURE_X86
+    pscav((lispobj *)all_threads->control_stack_start,
+         current_control_stack_pointer - 
+         all_threads->control_stack_start,
          0);
 #else
-#ifdef GENCGC
+#ifdef LISP_FEATURE_GENCGC
     pscav_i386_stack();
 #endif
 #endif
@@ -1358,15 +1381,24 @@ purify(lispobj static_roots, lispobj read_only_roots)
     printf(" bindings");
     fflush(stdout);
 #endif
-#if !defined(__i386__)
-    pscav( (lispobj *)BINDING_STACK_START,
-         (lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START,
+#if !defined(LISP_FEATURE_X86)
+    pscav( (lispobj *)all_threads->binding_stack_start,
+         (lispobj *)current_binding_stack_pointer -
+          all_threads->binding_stack_start,
          0);
 #else
-    pscav( (lispobj *)BINDING_STACK_START,
-         (lispobj *)SymbolValue(BINDING_STACK_POINTER) -
-         (lispobj *)BINDING_STACK_START,
+    for_each_thread(thread) {
+       pscav( (lispobj *)thread->binding_stack_start,
+              (lispobj *)SymbolValue(BINDING_STACK_POINTER,thread) -
+              (lispobj *)thread->binding_stack_start,
          0);
+       pscav( (lispobj *) (thread+1),
+              fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) -
+              (sizeof (struct thread))/(sizeof (lispobj)),
+         0);
+    }
+
+
 #endif
 
     /* The original CMU CL code had scavenge-read-only-space code
@@ -1429,23 +1461,23 @@ purify(lispobj static_roots, lispobj read_only_roots)
 
     /* Zero the stack. Note that the stack is also zeroed by SUB-GC
      * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
-#ifndef __i386__
+#ifndef LISP_FEATURE_X86
     os_zero((os_vm_address_t) current_control_stack_pointer,
-            (os_vm_size_t) (CONTROL_STACK_SIZE -
-                            ((current_control_stack_pointer -
-                             (lispobj *)CONTROL_STACK_START) *
-                             sizeof(lispobj))));
+            (os_vm_size_t)
+           ((all_threads->control_stack_end -
+             current_control_stack_pointer) * sizeof(lispobj)));
 #endif
 
     /* It helps to update the heap free pointers so that free_heap can
      * verify after it's done. */
-    SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free);
-    SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
+    SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
+    SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
 
-#if !defined(__i386__)
+#if !defined(LISP_FEATURE_X86)
     dynamic_space_free_pointer = current_dynamic_space;
+    set_auto_gc_trigger(bytes_consed_between_gcs);
 #else
-#if defined GENCGC
+#if defined LISP_FEATURE_GENCGC
     gc_free_heap();
 #else
 #error unsupported case /* in CMU CL, was "ibmrt using GC" */
@@ -1456,6 +1488,5 @@ purify(lispobj static_roots, lispobj read_only_roots)
     printf(" done]\n");
     fflush(stdout);
 #endif
-
     return 0;
 }