Changeset 13009

Timestamp:

Oct 13, 2009, 7:13:35 AM (15 years ago)

Author:

gz

Message:

Watchpoint changes from trunk (r13001 to r13008)

Location:

branches/working-0711/ccl

Files:

• compiler/X86/x86-disassemble.lisp (modified) (2 diffs)
• 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/misc.lisp (modified) (2 diffs)
• lisp-kernel/x86-exceptions.c (modified) (1 diff)
• lisp-kernel/x86-gc.c (modified) (5 diffs)

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

@@ -2758 +2758 @@
       (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 +2792 @@
       (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)))

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

@@ -449 +449 @@
   (movl ($ arch::watch-trap-function-watch) (%l imm0))
   (uuo-watch-trap)
-  (movl ($ nil) (%l arg_z))
   (single-value-return))
 

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

@@ -105 +105 @@
 
 (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)

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

@@ -387 +387 @@
 ;;; 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 +432 @@
              ((= 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 +463 @@
                                      :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))))

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

@@ -1052 +1052 @@
               (%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 +1063 @@
       (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)))
       

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

@@ -842 +842 @@
           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;

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

@@ -2813 +2813 @@
  */
 
-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 +2850 @@
     } else if (nodeheader_tag_p(tag_n)) {
       nwords = header_element_count(node);
-      
       nwords += 1 - (nwords & 1);
 
@@ -2859 +2860 @@
         nwords -= skip;
         while(skip--) {
-          if (*p == old) *p = new;
+          wp_maybe_update(p, old, new);
           p++;
         }
@@ -2868 +2869 @@
         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 +3057 @@
     other_tcr = other_tcr->next;
   } while (other_tcr != tcr);
+  unprotect_watched_areas();
   wp_update_all_areas(old, new);
-}
+  protect_watched_areas();
+}