Changeset 12932

Timestamp:

Oct 8, 2009, 9:44:56 PM (15 years ago)

Author:

R. Matthew Emerson

Message:

Add target and location slots to write-to-watched-object condition and fill
them in at initialization time; do a little clean-up.

File:

• branches/watchpoints/level-1/l1-error-system.lisp (modified) (1 diff)

branches/watchpoints/level-1/l1-error-system.lisp

@@ -106 +106 @@
   ((address :initarg :address)
    (instruction :initform nil :initarg :instruction)
-   (object :initform nil :initarg :object))
-  (:report (lambda (c s)
-             (with-slots (object address instruction) 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))
-               (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-one-disassembled-instruction ds instruction))))
-                 (format s "~&Faulting instruction: ~a" (string-trim " " str)))))))
+   (object :initform nil :initarg :object)
+   (target :reader write-to-watched-object-target)
+   (location :reader write-to-watched-object-location))
+  (:report report-write-to-watched-object))
+
+(defmethod initialize-instance :after ((condition write-to-watched-object)
+                                       &key &allow-other-keys)
+  (multiple-value-bind (what where)
+      (watched-object-and-location condition)
+    (setf (slot-value condition 'target) what
+          (slot-value condition 'location) where)))
+
+(defun report-write-to-watched-object (c s)
+  (with-slots (object address instruction) c
+    ;; This is safe only because watched objects are in a
+    ;; static GC area and (we hope) won't be moved around.
+    (with-slots (target location) c
+      (format s "Write to watched object ~s, key/index ~s~%"
+              target location))
+    (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-one-disassembled-instruction ds instruction))))
+      (format s "~&Faulting instruction: ~a" (string-trim " " str)))))
 
 (define-condition type-error (error)