Index: /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp
===================================================================
--- /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp	(revision 13008)
+++ /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp	(revision 13009)
@@ -2758,4 +2758,19 @@
       (out stream expr))))
 
+(defun x86-print-bare-disassembled-instruction (ds instruction)
+  (dolist (p (x86-di-prefixes instruction))
+    (format t "~&  (~a)~%" p))
+  (format t "  (~a" (x86-di-mnemonic instruction))
+  (let* ((op0 (x86-di-op0 instruction))
+         (op1 (x86-di-op1 instruction))
+         (op2 (x86-di-op2 instruction)))
+    (when op0
+      (write-x86-lap-operand t op0 ds)
+      (when op1
+        (write-x86-lap-operand t op1 ds)
+        (when op2
+          (write-x86-lap-operand t op2 ds)))))
+  (format t ")"))
+
 (defvar *previous-source-note*)
 
@@ -2777,17 +2792,5 @@
       (setq seq 0))
     (format t "~&  [~D]~8T" pc)
-    (dolist (p (x86-di-prefixes instruction))
-      (format t "~&  (~a)~%" p))
-    (format t "  (~a" (x86-di-mnemonic instruction))
-    (let* ((op0 (x86-di-op0 instruction))
-           (op1 (x86-di-op1 instruction))
-           (op2 (x86-di-op2 instruction)))
-      (when op0
-        (write-x86-lap-operand t op0 ds)
-        (when op1
-        (write-x86-lap-operand t op1 ds)
-          (when op2
-            (write-x86-lap-operand t op2 ds)))))
-    (format t ")")
+    (x86-print-bare-disassembled-instruction ds instruction)
     (format t "~%")
     (1+ seq)))
Index: /branches/working-0711/ccl/level-0/X86/x86-utils.lisp
===================================================================
--- /branches/working-0711/ccl/level-0/X86/x86-utils.lisp	(revision 13008)
+++ /branches/working-0711/ccl/level-0/X86/x86-utils.lisp	(revision 13009)
@@ -449,5 +449,4 @@
   (movl ($ arch::watch-trap-function-watch) (%l imm0))
   (uuo-watch-trap)
-  (movl ($ nil) (%l arg_z))
   (single-value-return))
 
Index: /branches/working-0711/ccl/level-1/l1-error-system.lisp
===================================================================
--- /branches/working-0711/ccl/level-1/l1-error-system.lisp	(revision 13008)
+++ /branches/working-0711/ccl/level-1/l1-error-system.lisp	(revision 13009)
@@ -105,22 +105,46 @@
 
 (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))))))
+  ((object :initform nil :initarg :object
+	   :reader write-to-watched-object-object)
+   (offset :initarg :offset
+	   :reader write-to-watched-object-offset)
+   (instruction :initarg :instruction))
+  (:report report-write-to-watched-object))
+
+(defun report-write-to-watched-object (c s)
+  (with-slots (object offset instruction) c
+    (cond
+      ((uvectorp object)
+       (let* ((count (uvsize object))
+	      (nbytes (if (ivectorp object)
+			(subtag-bytes (typecode object) count)
+			(* count target::node-size)))
+	      (bytes-per-element (/ nbytes count))
+	      (offset (- offset target::misc-data-offset))
+	      (index (/ offset bytes-per-element)))
+	 (format s "Write to watched uvector ~s at " object)
+	 (if (fixnump index)
+	   (format s "index ~s" index)
+	   (format s "an apparently unaligned byte offset ~s" offset))))
+      ((consp object)
+       (format s "Write to ~a watched cons cell ~s"
+               (cond
+		 ((= offset target::cons.cdr) "the CDR of")
+		 ((= offset target::cons.car) "the CAR of")
+		 (t
+		  (format nil "an apparently unaligned byte offset (~s) into"
+			  offset)))
+               object))
+      (t
+       (format s "Write to a strange object ~s at byte offset ~s"
+	       object offset)))
+    (when instruction
+      (let* ((ds (make-x86-disassembly-state :mode-64 #+x8664-target t
+					              #+x8632-target nil
+					     :code-vector nil
+					     :code-pointer 0))
+	     (str (with-output-to-string (*standard-output*)
+		    (x86-print-bare-disassembled-instruction ds instruction))))
+	(format s "~&Faulting instruction: ~a" (string-trim " " str))))))
 
 (define-condition type-error (error)
Index: /branches/working-0711/ccl/level-1/x86-trap-support.lisp
===================================================================
--- /branches/working-0711/ccl/level-1/x86-trap-support.lisp	(revision 13008)
+++ /branches/working-0711/ccl/level-1/x86-trap-support.lisp	(revision 13009)
@@ -387,5 +387,6 @@
 ;;; may not be meaningful.
 (defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
-  (let* ((frame-ptr (macptr->fixnum xcf)))
+  (let* ((frame-ptr (macptr->fixnum xcf))
+	 (skip 0))
     (cond ((zerop signal)               ;thread interrupt
            (cmain))
@@ -431,17 +432,25 @@
 	     ((= 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)))
+	      (let* ((offset other)
+		     ;; The kernel exception handler leaves the
+		     ;; watched object on the lisp stack under the
+		     ;; xcf.
+		     (object (%get-object xcf target::xcf.size)))
+		(multiple-value-bind (insn insn-length)
+		    (ignore-errors (x86-faulting-instruction xp))
 		  (restart-case (%error (make-condition
 					 'write-to-watched-object
-					 :address addr
-					 :object object)
+					 :offset offset
+					 :object object
+					 :instruction insn)
 					nil frame-ptr)
+		    (skip ()
+		      :test (lambda (c)
+			      (declare (ignore c))
+			      insn)
+		      :report "Skip over this write instruction."
+		      (setq skip insn-length))
 		    (unwatch ()
-		      :report (lambda (s)
-				(format s "Unwatch ~s and perform the write." object))
+		      :report "Unwatch the object and retry the write."
 		      (unwatch object))))))))
           ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
@@ -454,4 +463,18 @@
                                      :write-p (not (zerop code)))
                      ()
-                     frame-ptr)))))
-  0)
+                     frame-ptr))))
+    skip))
+
+(defun x86-faulting-instruction (xp)
+  (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
+         (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
+                                    #+x8664-target rip-register-offset)))
+    (dotimes (i (length code-bytes))
+      (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
+    (let* ((ds (make-x86-disassembly-state
+                :mode-64 #+x8664-target t #+x8632-target nil
+                :code-vector code-bytes
+                :code-pointer 0))
+           (insn (x86-disassemble-instruction ds nil))
+           (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
+      (values insn len))))
Index: /branches/working-0711/ccl/lib/misc.lisp
===================================================================
--- /branches/working-0711/ccl/lib/misc.lisp	(revision 13008)
+++ /branches/working-0711/ccl/lib/misc.lisp	(revision 13009)
@@ -1052,4 +1052,10 @@
               (%ptr-to-int (%svref lock target::lock._value-cell)))))
 
+(defun all-watched-objects ()
+  (let (result)
+    (with-other-threads-suspended
+      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched))
+    result))
+    
 (defun watch (&optional thing)
   (if thing
@@ -1057,19 +1063,15 @@
       (require-type thing '(or cons (satisfies uvectorp)))
       (%watch thing))
-    (let (result)
-      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
-      result)))
+    (all-watched-objects)))
 
 (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))
+  (with-other-threads-suspended
+    (%map-areas #'(lambda (x)
+		    (when (eq x thing)
+		      (let ((new (if (uvectorp thing)
+				   (%alloc-misc (uvsize thing)
+						(typecode thing))
+				   (cons nil nil))))
+			(return-from unwatch (%unwatch thing new)))))
+		area-watched area-watched)))
       
Index: /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c
===================================================================
--- /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c	(revision 13008)
+++ /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c	(revision 13009)
@@ -842,9 +842,14 @@
 	  LispObj save_vsp = xpGPR(xp, Isp);
 	  LispObj save_fp = xpGPR(xp, Ifp);
-	  LispObj xcf = create_exception_callback_frame(xp, tcr);
+	  LispObj xcf;
+	  natural offset = (LispObj)addr - obj;
 	  int skip;
 
+	  push_on_lisp_stack(xp, obj);
+	  xcf = create_exception_callback_frame(xp, tcr);
+
 	  /* 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);
+	  skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2,
+				  (natural)addr, offset);
 	  xpPC(xp) += skip;
 	  xpGPR(xp, Ifp) = save_fp;
Index: /branches/working-0711/ccl/lisp-kernel/x86-gc.c
===================================================================
--- /branches/working-0711/ccl/lisp-kernel/x86-gc.c	(revision 13008)
+++ /branches/working-0711/ccl/lisp-kernel/x86-gc.c	(revision 13009)
@@ -2813,10 +2813,12 @@
  */
 
-static inline void
+static inline int
 wp_maybe_update(LispObj *p, LispObj old, LispObj new)
 {
   if (*p == old) {
     *p = new;
-  }
+    return true;
+  }
+  return false;
 }
 
@@ -2848,5 +2850,4 @@
     } else if (nodeheader_tag_p(tag_n)) {
       nwords = header_element_count(node);
-      
       nwords += 1 - (nwords & 1);
 
@@ -2859,5 +2860,5 @@
         nwords -= skip;
         while(skip--) {
-	  if (*p == old) *p = new;
+	  wp_maybe_update(p, old, new);
           p++;
         }
@@ -2868,11 +2869,10 @@
         nwords >>= 1;
         while(nwords--) {
-          if (*p == old && hashp) {
-	    *p = new;
+          if (wp_maybe_update(p, old, new) && hashp) {
             hashp->flags |= nhash_key_moved_mask;
             hashp = NULL;
           }
           p++;
-	  if (*p == old) *p = new;
+	  wp_maybe_update(p, old, new);
           p++;
         }
@@ -3057,4 +3057,6 @@
     other_tcr = other_tcr->next;
   } while (other_tcr != tcr);
+  unprotect_watched_areas();
   wp_update_all_areas(old, new);
-}
+  protect_watched_areas();
+}