Changeset 12994

Timestamp:

Oct 10, 2009, 10:32:43 AM (15 years ago)

Author:

gz

Message:

Merge watchpoints from trunk

Location:

branches/working-0711/ccl

Files:

• compiler/X86/x86-asm.lisp (modified) (1 diff)
• compiler/arch.lisp (modified) (1 diff)
• level-0/X86/x86-utils.lisp (modified) (1 diff)
• level-1/l1-error-system.lisp (modified) (1 diff)
• level-1/x86-trap-support.lisp (modified) (3 diffs)
• lib/dumplisp.lisp (modified) (1 diff)
• lib/macros.lisp (modified) (1 diff)
• lib/misc.lisp (modified) (1 diff)
• library/lispequ.lisp (modified) (1 diff)
• lisp-kernel/area.h (modified) (1 diff)
• lisp-kernel/gc-common.c (modified) (6 diffs)
• lisp-kernel/memory.c (modified) (2 diffs)
• lisp-kernel/x86-exceptions.c (modified) (6 diffs)
• lisp-kernel/x86-exceptions.h (modified) (1 diff)
• lisp-kernel/x86-gc.c (modified) (7 diffs)

branches/working-0711/ccl/compiler/X86/x86-asm.lisp

@@ -3370 +3370 @@
    (def-x86-opcode uuo-error-debug-trap-with-string ()
      #xcdcd nil nil)
+
+   (def-x86-opcode uuo-watch-trap ()
+     #xcdce nil nil)
    
    (def-x86-opcode uuo-error-reg-not-tag ((:reg :insert-opcode-reg4) (:imm8 :insert-imm8))

branches/working-0711/ccl/compiler/arch.lisp

@@ -358 +358 @@
 (defconstant gc-trap-function-thaw 130)
 
-
+(defconstant watch-trap-function-watch 0)
+(defconstant watch-trap-function-unwatch 1)
 
 (provide "ARCH")

branches/working-0711/ccl/level-0/X86/x86-utils.lisp

@@ -445 +445 @@
   (jmp-subprim .SPmakeu64))
 
+(defx86lapfunction %watch ((thing arg_z))
+  (check-nargs 1)
+  (movl ($ arch::watch-trap-function-watch) (%l imm0))
+  (uuo-watch-trap)
+  (movl ($ nil) (%l arg_z))
+  (single-value-return))
+
+(defx86lapfunction %unwatch ((watched arg_y) (new arg_z))
+  (check-nargs 2)
+  (movl ($ arch::watch-trap-function-unwatch) (%l imm0))
+  (uuo-watch-trap)
+  (single-value-return))
+
 (defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
   (check-nargs 2)

branches/working-0711/ccl/level-1/l1-error-system.lisp

@@ -104 +104 @@
              (format s "Invalid memory operation."))))
 
+(define-condition write-to-watched-object (storage-condition)
+  ((address :initarg :address)
+   (object :initform nil :initarg :object))
+  (:report (lambda (c s)
+             (with-slots (object address) c
+               (if (uvectorp object)
+                 ;; This is safe only because watched objects are in a
+                 ;; static GC area and won't be moved around.
+                 (let* ((size (uvsize object))
+                        (nbytes (if (ivectorp object)
+                                  (subtag-bytes (typecode object) size)
+                                  (* size target::node-size)))
+                        (bytes-per-element (/ nbytes size))
+                        (noderef (logandc2 (%address-of object)
+                                           target::fulltagmask))
+                        (offset (- address (+ noderef target::node-size)))
+                        (index (/ offset bytes-per-element)))
+                   (format s "Write to watched object ~s at address #x~x (uvector index ~d)." object address index))
+                 (format s "Write to watched object ~s at address #x~x" object address))))))
 
 (define-condition type-error (error)

branches/working-0711/ccl/level-1/x86-trap-support.lisp

@@ -386 +386 @@
 ;;; If the signal number is 0, other arguments (besides the exception context XP)
 ;;; may not be meaningful.
-(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr  :int)
+(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
   (let* ((frame-ptr (macptr->fixnum xcf)))
     (cond ((zerop signal)               ;thread interrupt
@@ -415 +415 @@
                        frame-ptr))))
           ((= signal #$SIGSEGV)
-           ;; Stack overflow.
-           (let* ((on-tsp (not (eql 0 code))))
-             (unwind-protect
-                  (%error
-                   (make-condition
-                    'stack-overflow-condition 
-                    :format-control "Stack overflow on ~a stack."
-                    :format-arguments (list
-                                       (if on-tsp "temp" "value"))
-                    )
-                   nil frame-ptr)
-               (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
-                        :unsigned-fullword code
-                        :void))))
+           (cond
+             ((or (= code 0) (= code 1))
+              ;; Stack overflow.
+              (let* ((on-tsp (= code 1)))
+                (unwind-protect
+                     (%error
+                      (make-condition
+                       'stack-overflow-condition 
+                       :format-control "Stack overflow on ~a stack."
+                       :format-arguments (list (if on-tsp "temp" "value")))
+                      nil frame-ptr)
+                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
+                           :unsigned-fullword code
+                           :void))))
+             ((= code 2)
+              ;; Write to a watched object.
+              (flet ((%int-to-object (i)
+                       (rlet ((a :address))
+                         (setf (%get-ptr a) (%int-to-ptr i))
+                         (%get-object a 0))))
+                (let ((object (%int-to-object other)))
+                  (restart-case (%error (make-condition
+                                         'write-to-watched-object
+                                         :address addr
+                                         :object object)
+                                        nil frame-ptr)
+                    (unwatch ()
+                      :report (lambda (s)
+                                (format s "Unwatch ~s and perform the write." object))
+                      (unwatch object))))))))
           ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
            (if (= code -1)
@@ -440 +456 @@
                      frame-ptr)))))
   0)
-

branches/working-0711/ccl/lib/dumplisp.lisp

@@ -83 +83 @@
     (when (and kind (not (eq kind :file )))
       (error "~S is not a regular file." filename)))
+  (let* ((watched (watch)))
+    (when watched
+      (cerror "Un-watch them." "There are watched objects.")
+      (mapc #'unwatch watched)))
   (let* ((ip *initial-process*)
          (cp *current-process*))

branches/working-0711/ccl/lib/macros.lisp

@@ -3550 +3550 @@
      (let ((,code (%fixnum-ref ,area  (area-code))))
        (when (or (eql ,code area-readonly)
+                 (eql ,code area-watched)
                  (eql ,code area-managed-static)
                  (eql ,code area-static)

branches/working-0711/ccl/lib/misc.lisp

@@ -1051 +1051 @@
               (lock-name lock)
               (%ptr-to-int (%svref lock target::lock._value-cell)))))
+
+(defun watch (&optional thing)
+  (if thing
+    (progn
+      (require-type thing '(or cons (satisfies uvectorp)))
+      (%watch thing))
+    (let (result)
+      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
+      result)))
+
+(defun unwatch (thing)
+  (%map-areas #'(lambda (x)
+                  (when (eq x thing)
+                    ;; This is a rather questionable thing to do,
+                    ;; since we'll be unlinking an area from the area
+                    ;; list while %map-areas iterates over it, but I
+                    ;; think we'll get away with it.
+                    (let ((new (if (uvectorp thing)
+                                 (%alloc-misc (uvsize thing) (typecode thing))
+                                 (cons nil nil))))
+                      (return-from unwatch (%unwatch thing new)))))
+              area-watched area-watched))
+      

branches/working-0711/ccl/library/lispequ.lisp

@@ -1285 +1285 @@
   tstack                                ; (dynamic-extent) temp stack
   readonly                              ; readonly section
+  watched                               ; static area containing a single object
   managed-static                        ; growable static area
   static                                ; static data in application

branches/working-0711/ccl/lisp-kernel/area.h

@@ -30 +30 @@
   AREA_TSTACK = 3<<fixnumshift, /* A temp stack.  It -is- doubleword-aligned */
   AREA_READONLY = 4<<fixnumshift, /* A (cfm) read-only section. */
-  AREA_MANAGED_STATIC = 5<<fixnumshift, /* A resizable static area */
-  AREA_STATIC = 6<<fixnumshift, /* A  static section: contains
+  AREA_WATCHED = 5<<fixnumshift, /* A static area containing a single object. */
+  AREA_MANAGED_STATIC = 6<<fixnumshift, /* A resizable static area */
+  AREA_STATIC = 7<<fixnumshift, /* A  static section: contains
                                  roots, but not GCed */
-  AREA_DYNAMIC = 7<<fixnumshift /* A heap. Only one such area is "the heap."*/
+  AREA_DYNAMIC = 8<<fixnumshift /* A heap. Only one such area is "the heap."*/
 } area_code;
 

branches/working-0711/ccl/lisp-kernel/gc-common.c

@@ -1101 +1101 @@
 
   install_weak_mark_functions(lisp_global(WEAK_GC_METHOD) >> fixnumshift);
-
-
-
+  
 #ifndef FORCE_DWS_MARK
   if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
@@ -1163 +1161 @@
 
   get_time(start);
+
+  /* The link-inverting marker might need to write to watched areas */
+  unprotect_watched_areas();
+
   lisp_global(IN_GC) = (1<<fixnumshift);
 
@@ -1238 +1240 @@
 
         case AREA_STATIC:
+        case AREA_WATCHED:
         case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
           /* In both of these cases, we -could- use the area's "markbits"
@@ -1373 +1376 @@
 
         case AREA_STATIC:
+        case AREA_WATCHED:
         case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
           if (next_area->younger == NULL) {
@@ -1384 +1388 @@
       }
     }
-  
+
     if (GCephemeral_low) {
       forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
@@ -1428 +1432 @@
   
   lisp_global(IN_GC) = 0;
+  
+  protect_watched_areas();
 
   nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;

branches/working-0711/ccl/lisp-kernel/memory.c

@@ -290 +290 @@
   return VirtualAlloc(addr, nbytes, MEM_RESERVE|MEM_COMMIT, MEMPROTECT_RWX);
 #else
-  return mmap(addr, nbytes, protection, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0);
+  {
+    int flags = MAP_PRIVATE|MAP_ANON;
+
+    if (addr > 0) flags |= MAP_FIXED;
+    return mmap(addr, nbytes, protection, flags, -1, 0);
+  }
 #endif
 }
@@ -948 +953 @@
   pure_space_active = pure_space_start;
 }
+
+void
+protect_watched_areas()
+{
+  area *a = active_dynamic_area;
+  natural code = a->code;
+
+  while (code != AREA_VOID) {
+    if (code == AREA_WATCHED) {
+      natural size = a->high - a->low;
+      
+      ProtectMemory(a->low, size);
+    }
+    a = a->succ;
+    code = a->code;
+  }
+}
+
+void
+unprotect_watched_areas()
+{
+  area *a = active_dynamic_area;
+  natural code = a->code;
+
+  while (code != AREA_VOID) {
+    if (code == AREA_WATCHED) {
+      natural size = a->high - a->low;
+      
+      UnProtectMemory(a->low, size);
+    }
+    a = a->succ;
+    code = a->code;
+  }
+}

branches/working-0711/ccl/lisp-kernel/x86-exceptions.c

@@ -499 +499 @@
     return true;
   }
-  update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr);
+  update_bytes_allocated(tcr, (void *)tcr->save_allocptr);
   if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) {
     tcr->save_allocptr -= fulltag_cons;
@@ -803 +803 @@
       xpPC(xp) = xpGPR(xp,Ira0);
       return true;
-    } else {
+    }
+    
+    {
       protected_area *a = find_protected_area(addr);
       protection_handler *handler;
@@ -810 +812 @@
         handler = protection_handlers[a->why];
         return handler(xp, a, addr);
-      } else {
-        if ((addr >= readonly_area->low) &&
-            (addr < readonly_area->active)) {
-          UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
-                          page_size);
-          return true;
-        }
       }
     }
-  }
+
+    if ((addr >= readonly_area->low) &&
+        (addr < readonly_area->active)) {
+      UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
+                      page_size);
+      return true;
+    }
+
+    {
+      area *a = area_containing(addr);
+
+      if (a && a->code == AREA_WATCHED && addr < a->high) {
+        /* caught a write to a watched object */
+        LispObj *p = (LispObj *)a->low;
+        LispObj node = *p;
+        unsigned tag_n = fulltag_of(node);
+        LispObj cmain = nrs_CMAIN.vcell;
+        LispObj obj;
+
+        if (immheader_tag_p(tag_n) || nodeheader_tag_p(tag_n))
+          obj = (LispObj)p + fulltag_misc;
+        else
+          obj = (LispObj)p + fulltag_cons;
+
+        if ((fulltag_of(cmain) == fulltag_misc) &&
+            (header_subtag(header_of(cmain)) == subtag_macptr)) {
+          LispObj save_vsp = xpGPR(xp, Isp);
+          LispObj save_fp = xpGPR(xp, Ifp);
+          LispObj xcf = create_exception_callback_frame(xp, tcr);
+          int skip;
+
+          /* The magic 2 means this was a write to a watchd object */
+          skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, (natural) addr, obj);
+          xpPC(xp) += skip;
+          xpGPR(xp, Ifp) = save_fp;
+          xpGPR(xp, Isp) = save_vsp;
+          return true;
+        }
+      }
+    }
+  }
+
   if (old_valence == TCR_STATE_LISP) {
     LispObj cmain = nrs_CMAIN.vcell,
@@ -993 +1029 @@
           }
           break;
-            
+        case UUO_WATCH_TRAP:
+          /* add or remove watched object */
+          if (handle_watch_trap(context, tcr)) {
+            xpPC(context) += 2;
+            return true;
+          }
+          break;
         case UUO_DEBUG_TRAP:
           xpPC(context) = (natural) (program_counter+1);
@@ -2268 +2310 @@
   case 0x77: return ID_branch_around_alloc_trap_instruction;
   case 0x48: return ID_set_allocptr_header_instruction;
-#ifdef WINDOWS
+#ifdef TCR_IN_GPR
   case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
   case 0x49:
@@ -3585 +3627 @@
 
 #endif
+
+/* watchpoint stuff */
+
+area *
+new_watched_area(natural size)
+{
+  void *p;
+
+  p = MapMemory(NULL, size, MEMPROTECT_RWX);
+  if ((signed_natural)p == -1) {
+    allocation_failure(true, size);
+  }
+  return new_area(p, p + size, AREA_WATCHED);
+}
+
+void
+delete_watched_area(area *a, TCR *tcr)
+{
+  natural nbytes = a->high - a->low;
+  char *base = a->low;
+
+  condemn_area_holding_area_lock(a);
+
+  if (nbytes) {
+    int err;
+
+/* can't use UnMapMemory() beacuse it only uses MEM_DECOMMIT */
+#ifdef WINDOWS
+    err = VirtualFree(base, nbytes, MEM_RELEASE);
+#else
+    err = munmap(base, nbytes);
+#endif
+    if (err != 0)
+      Fatal("munmap in delete_watched_area", "");
+  }
+}
+
+natural
+uvector_total_size_in_bytes(LispObj *u)
+{
+  LispObj header = header_of(u);
+  natural header_tag = fulltag_of(header);
+  natural subtag = header_subtag(header);
+  natural element_count = header_element_count(header);
+  natural nbytes = 0;
+
+#ifdef X8632
+  if ((nodeheader_tag_p(header_tag)) ||
+      (subtag <= max_32_bit_ivector_subtag)) {
+    nbytes = element_count << 2;
+  } else if (subtag <= max_8_bit_ivector_subtag) {
+    nbytes = element_count;
+  } else if (subtag <= max_16_bit_ivector_subtag) {
+    nbytes = element_count << 1;
+  } else if (subtag == subtag_double_float_vector) {
+    nbytes = element_count << 3;
+  } else {
+    nbytes = (element_count + 7) >> 3;
+  }
+  /* add 4 byte header and round up to multiple of 8 bytes */
+  return ~7 & (4 + nbytes + 7);
+#endif
+#ifdef X8664
+  if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) {
+    nbytes = element_count << 3;
+  } else if (header_tag == ivector_class_32_bit) {
+    nbytes = element_count << 2;
+  } else {
+    /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */
+    if (subtag == subtag_bit_vector) {
+      nbytes = (element_count + 7) >> 3;
+    } else if (subtag >= min_8_bit_ivector_subtag) {
+      nbytes = element_count;
+    } else {
+      nbytes = element_count << 1;
+    }
+  }
+  /* add 8 byte header and round up to multiple of 16 bytes */
+  return ~15 & (8 + nbytes + 15);
+#endif
+}
+
+extern void wp_update_references(TCR *, LispObj, LispObj);
+
+/*
+ * Other threads are suspended and pc-lusered.
+ *
+ * param contains a tagged pointer to a uvector or a cons cell
+ */
+signed_natural
+watch_object(TCR *tcr, signed_natural param)
+{
+  LispObj object = (LispObj)param;
+  unsigned tag = fulltag_of(object);
+  LispObj *noderef = (LispObj *)untag(object);
+  area *object_area = area_containing((BytePtr)noderef);
+  natural size;
+
+  if (tag == fulltag_cons)
+    size = 2 * node_size;
+  else
+    size = uvector_total_size_in_bytes(noderef);
+
+  if (object_area && object_area->code != AREA_WATCHED) {
+    area *a = new_watched_area(size);
+    LispObj old = object;
+    LispObj new = (LispObj)((natural)a->low + tag);
+
+    add_area_holding_area_lock(a);
+
+    /* move object to watched area */
+    memcpy(a->low, noderef, size);
+    ProtectMemory(a->low, size);
+    memset(noderef, 0, size);
+    wp_update_references(tcr, old, new);
+    check_all_areas(tcr);
+  }
+  return 0;
+}
+
+/*
+ * We expect the watched object in arg_y, and the new uninitialized
+ * object (which is just zeroed) in arg_z.
+ */
+signed_natural
+unwatch_object(TCR *tcr, signed_natural param)
+{
+  ExceptionInformation *xp = tcr->xframe->curr;
+  LispObj old = xpGPR(xp, Iarg_y);
+  unsigned tag = fulltag_of(old);
+  LispObj new = xpGPR(xp, Iarg_z);
+  LispObj *oldnode = (LispObj *)untag(old);
+  LispObj *newnode = (LispObj *)untag(new);
+  area *a = area_containing((BytePtr)old);
+
+  if (a && a->code == AREA_WATCHED) {
+    natural size;
+
+    if (tag == fulltag_cons)
+      size = 2 * node_size;
+    else
+      size = uvector_total_size_in_bytes(oldnode);
+
+    memcpy(newnode, oldnode, size);
+    delete_watched_area(a, tcr);
+    wp_update_references(tcr, old, new);
+    /* because wp_update_references doesn't update refbits */
+    tenure_to_area(tenured_area);
+    check_all_areas(tcr);
+    xpGPR(xp, Iarg_z) = new;
+  }
+  return 0;
+}
+
+Boolean
+handle_watch_trap(ExceptionInformation *xp, TCR *tcr)
+{
+  LispObj selector = xpGPR(xp,Iimm0);
+  LispObj object = xpGPR(xp, Iarg_z);
+  
+  switch (selector) {
+    case WATCH_TRAP_FUNCTION_WATCH:
+      gc_like_from_xp(xp, watch_object, object);
+      break;
+    case WATCH_TRAP_FUNCTION_UNWATCH:
+      gc_like_from_xp(xp, unwatch_object, 0);
+      break;
+    default:
+      break;
+  }
+  return true;
+}
+

branches/working-0711/ccl/lisp-kernel/x86-exceptions.h

@@ -138 +138 @@
 #define UUO_DEBUG_TRAP 0xca
 #define UUO_DEBUG_TRAP_WITH_STRING 0xcd
+#define UUO_WATCH_TRAP 0xce
+  #define WATCH_TRAP_FUNCTION_WATCH 0
+  #define WATCH_TRAP_FUNCTION_UNWATCH 1
 
 #define XUUO_OPCODE_0 0x0f

branches/working-0711/ccl/lisp-kernel/x86-gc.c

@@ -26 +26 @@
 #include <sys/time.h>
 
+#ifdef X8632
+static inline natural
+imm_word_count(LispObj fn)
+{
+  natural w = ((unsigned short *)fn)[-1];
+
+  if (w & 0x8000) {
+    /* 
+     * The low 15 bits encode the number of contants.
+     * Compute and return the immediate word count.
+     */
+    LispObj header = header_of(fn);
+    natural element_count = header_element_count(header);
+
+    return element_count - (w & 0x7fff);
+  } else {
+    /* The immediate word count is encoded directly. */
+    return w;
+  }
+}
+#endif
 
 /* Heap sanity checking. */
@@ -318 +339 @@
     switch (code) {
     case AREA_DYNAMIC:
+    case AREA_WATCHED:
     case AREA_STATIC:
     case AREA_MANAGED_STATIC:
@@ -959 +981 @@
       header = *(natural *)base;
       subtag = header_subtag(header);
-      boundary = base + (unsigned short)base[1];
-
-      /* XXX bootstrapping */
-      {
-        natural word_count = (unsigned short)base[1];
-        natural element_count = header_element_count(header);
-
-        if (word_count & 0x8000)
-          boundary = base + element_count - (word_count & 0x7fff);
-      }
+      boundary = base + imm_word_count(fn);
 
       /*
@@ -991 +1004 @@
       subtag = header_subtag(header);
       if (subtag == subtag_function) {
-        boundary = base + (unsigned short)base[1];
-        /* XXX bootstrapping */
-        {
-          natural word_count = (unsigned short)base[1];
-          natural element_count = header_element_count(header);
-
-          if (word_count & 0x8000)
-            boundary = base + element_count - (word_count & 0x7fff);
-        }
+        boundary = base + imm_word_count(this);
 
         *((int *)boundary) &= 0xff;
@@ -1902 +1907 @@
   LispObj fn = fulltag_misc + (LispObj)node;
   unsigned char *p = (unsigned char *)node;
-  natural i, offset;
-  LispObj header = *node;
-
-  i = ((unsigned short *)node)[2];
+  natural i = imm_word_count(fn);
+
   if (i) {
-    /* XXX bootstrapping for new scheme */
-    if (i & 0x8000) {
-      i = header_element_count(header) - (i & 0x7fff);
-    }
-    offset = node[--i];
+    natural offset = node[--i];
 
     while (offset) {
@@ -1983 +1982 @@
           if (header_subtag(node) == subtag_function) {
 #ifdef X8632
-            int skip = *((unsigned short *)src);
             LispObj *f = dest;
-
-            /* XXX bootstrapping for new scheme */
-            if (skip & 0x8000)
-              skip = elements - (skip & 0x7fff);
+            int skip = imm_word_count(fulltag_misc + (LispObj)current);
 #else
             int skip = *((int *)src);
@@ -2811 +2806 @@
   return -1;
 }
+
+/*
+ * This stuff is all adapted from the forward_xxx functions for use by
+ * the watchpoint code.  It's a lot of duplicated code, and it would
+ * be nice to generalize it somehow.
+ */
+
+static inline void
+wp_maybe_update(LispObj *p, LispObj old, LispObj new)
+{
+  if (*p == old) {
+    *p = new;
+  }
+}
+
+static void
+wp_update_headerless_range(LispObj *start, LispObj *end,
+                           LispObj old, LispObj new)
+{
+  LispObj *p = start;
+
+  while (p < end) {
+    wp_maybe_update(p, old, new);
+    p++;
+  }
+}
+
+static void
+wp_update_range(LispObj *start, LispObj *end, LispObj old, LispObj new)
+{
+  LispObj *p = start, node;
+  int tag_n;
+  natural nwords;
+
+  while (p < end) {
+    node = *p;
+    tag_n = fulltag_of(node);
+
+    if (immheader_tag_p(tag_n)) {
+      p = (LispObj *)skip_over_ivector(ptr_to_lispobj(p), node);
+    } else if (nodeheader_tag_p(tag_n)) {
+      nwords = header_element_count(node);
+      
+      nwords += 1 - (nwords & 1);
+
+      if ((header_subtag(node) == subtag_hash_vector) &&
+          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
+        natural skip = hash_table_vector_header_count - 1;
+        hash_table_vector_header *hashp = (hash_table_vector_header *)p;
+
+        p++;
+        nwords -= skip;
+        while(skip--) {
+          if (*p == old) *p = new;
+          p++;
+        }
+        /* "nwords" is odd at this point: there are (floor nwords 2)
+           key/value pairs to look at, and then an extra word for
+           alignment.  Process them two at a time, then bump "p"
+           past the alignment word. */
+        nwords >>= 1;
+        while(nwords--) {
+          if (*p == old && hashp) {
+            *p = new;
+            hashp->flags |= nhash_key_moved_mask;
+            hashp = NULL;
+          }
+          p++;
+          if (*p == old) *p = new;
+          p++;
+        }
+        *p++ = 0;
+      } else {
+        if (header_subtag(node) == subtag_function) {
+#ifdef X8632
+          int skip = (unsigned short)(p[1]);
+
+          /* XXX bootstrapping */
+          if (skip & 0x8000)
+            skip = header_element_count(node) - (skip & 0x7fff);
+
+#else
+          int skip = (int)(p[1]);
+#endif
+          p += skip;
+          nwords -= skip;
+        }
+        p++;
+        while(nwords--) {
+          wp_maybe_update(p, old, new);
+          p++;
+        }
+      }
+    } else {
+      /* a cons cell */
+      wp_maybe_update(p, old, new);
+      p++;
+      wp_maybe_update(p, old, new);
+      p++;
+    }
+  }
+}
+
+#ifdef X8664
+static void
+wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new)
+{
+  natural *regs = (natural *)xpGPRvector(xp);
+
+  wp_maybe_update(&regs[Iarg_z], old, new);
+  wp_maybe_update(&regs[Iarg_y], old, new);
+  wp_maybe_update(&regs[Iarg_x], old, new);
+  wp_maybe_update(&regs[Isave3], old, new);
+  wp_maybe_update(&regs[Isave2], old, new);
+  wp_maybe_update(&regs[Isave1], old, new);
+  wp_maybe_update(&regs[Isave0], old, new);
+  wp_maybe_update(&regs[Ifn], old, new);
+  wp_maybe_update(&regs[Itemp0], old, new);
+  wp_maybe_update(&regs[Itemp1], old, new);
+  wp_maybe_update(&regs[Itemp2], old, new);
+
+#if 0
+  /* 
+   * We don't allow watching functions, so this presumably doesn't
+   * matter.
+   */
+  update_locref(&(regs[Iip]));
+#endif
+}
+#else
+static void
+wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new, natural node_regs_mask)
+{
+  natural *regs = (natural *)xpGPRvector(xp);
+
+  if (node_regs_mask & (1<<0)) wp_maybe_update(&regs[REG_EAX], old, new);
+  if (node_regs_mask & (1<<1)) wp_maybe_update(&regs[REG_ECX], old, new);
+
+  if (regs[REG_EFL] & EFL_DF) {
+    /* then EDX is an imm reg */
+    ;
+  } else
+    if (node_regs_mask & (1<<2)) wp_maybe_update(&regs[REG_EDX], old, new);
+
+  if (node_regs_mask & (1<<3)) wp_maybe_update(&regs[REG_EBX], old, new);
+  if (node_regs_mask & (1<<4)) wp_maybe_update(&regs[REG_ESP], old, new);
+  if (node_regs_mask & (1<<5)) wp_maybe_update(&regs[REG_EBP], old, new);
+  if (node_regs_mask & (1<<6)) wp_maybe_update(&regs[REG_ESI], old, new);
+  if (node_regs_mask & (1<<7)) wp_maybe_update(&regs[REG_EDI], old, new);
+  /* we shouldn't watch functions, so no need to update PC */
+}
+#endif
+
+static void
+wp_update_tcr_xframes(TCR *tcr, LispObj old, LispObj new)
+{
+  xframe_list *xframes;
+  ExceptionInformation *xp;
+
+  xp = tcr->gc_context;
+  if (xp) {
+#ifdef X8664
+    wp_update_xp(xp, old, new);
+#else
+    wp_update_xp(xp, old, new, tcr->node_regs_mask);
+    wp_maybe_update(&tcr->save0, old, new);
+    wp_maybe_update(&tcr->save1, old, new);
+    wp_maybe_update(&tcr->save2, old, new);
+    wp_maybe_update(&tcr->save3, old, new);
+    wp_maybe_update(&tcr->next_method_context, old, new);
+#endif
+  }
+  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
+#ifdef X8664
+    wp_update_xp(xframes->curr, old, new);
+#else
+    wp_update_xp(xframes->curr, old, new, xframes->node_regs_mask);
+#endif
+  }
+}
+
+/*
+ * Scan all pointer-bearing areas, updating all references to
+ * "old" to "new".
+ */
+static void
+wp_update_all_areas(LispObj old, LispObj new)
+{
+  area *a = active_dynamic_area;
+  natural code = a->code;
+
+  while (code != AREA_VOID) {
+    switch (code) {
+      case AREA_DYNAMIC:
+      case AREA_STATIC:
+      case AREA_MANAGED_STATIC:
+      case AREA_WATCHED:
+        wp_update_range((LispObj *)a->low, (LispObj *)a->active, old, new);
+        break;
+      case AREA_VSTACK:
+      {
+        LispObj *low = (LispObj *)a->active;
+        LispObj *high = (LispObj *)a->high;
+        
+        wp_update_headerless_range(low, high, old, new);
+      }
+      break;
+      case AREA_TSTACK:
+      {
+        LispObj *current, *next;
+        LispObj *start = (LispObj *)a->active, *end = start;
+        LispObj *limit = (LispObj *)a->high;
+        
+        for (current = start; end != limit; current = next) {
+          next = ptr_from_lispobj(*current);
+          end = ((next >= start) && (next < limit)) ? next : limit;
+          wp_update_range(current+2, end, old, new);
+        }
+      break;
+      }
+      default:
+        break;
+    }
+    a = a->succ;
+    code = a->code;
+  }
+}
+
+static void
+wp_update_tcr_tlb(TCR *tcr, LispObj old, LispObj new)
+{
+  natural n = tcr->tlb_limit;
+  LispObj *start = tcr->tlb_pointer;
+  LispObj *end = start + (n >> fixnumshift);
+
+  while (start < end) {
+    wp_maybe_update(start, old, new);
+    start++;
+  }
+}
+
+void
+wp_update_references(TCR *tcr, LispObj old, LispObj new)
+{
+  TCR *other_tcr = tcr;
+
+  do {
+    wp_update_tcr_xframes(other_tcr, old, new);
+    wp_update_tcr_tlb(other_tcr, old, new);
+    other_tcr = other_tcr->next;
+  } while (other_tcr != tcr);
+  wp_update_all_areas(old, new);
+}