Changeset 13004

Timestamp:

Oct 12, 2009, 5:10:09 PM (15 years ago)

Author:

R. Matthew Emerson

Message:

Get watched object from lisp stack instead of callback parameter. Use
new function X86-FAULTING-INSTRUCTION to initialize instruction slot
of WRITE-TO-WATCHED-OBJECT condition.

Add a "skip this write instruction" restart.

Instead of returning 0 as the value of the callback, return SKIP bytes.

File:

• trunk/source/level-1/x86-trap-support.lisp (modified) (3 diffs)

trunk/source/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))))