Changeset 12984

Timestamp:

Oct 9, 2009, 9:53:23 PM (15 years ago)

Author:

R. Matthew Emerson

Message:

When handling a write to a watched object, try to be more careful about
assuming that the object is in a static gc area. This is the idea behind
using offsets from the tagged object pointer, rather than an address passed
as an integer.

In lieu of using the passed in address to locate the watched object,
assume that the kernel will have pushed the watched object onto the lisp
stack immediately before the xcf.

Don't offer to emulate writes on Windows platforms, since they don't
have #_mprotect. (This is just laziness. Windows has #_VirtualProtect, so
it's just a matter of using it correctly and testing it.)

File:

• branches/watchpoints/level-1/x86-trap-support.lisp (modified) (5 diffs)

branches/watchpoints/level-1/x86-trap-support.lisp

@@ -432 +432 @@
              ((= code 2)
               ;; Write to a watched object.
-              ;; We somehow need to guard against another thread unwatching
-              ;; the object out from underneath us.
-              (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)))
+              ;;
+              ;; A potential problem here is that some other thread
+              ;; might unwatch the object while we're in here trying
+              ;; to figure out what happened.
+              (let* ((offset other)
+                     ;; The kernel exception handler has put the object
+                     ;; on the lisp stack under the xcf.
+                     (object (%get-object xcf target::xcf.size))
+                     (result nil))
                   (multiple-value-bind (insn insn-length)
                       (x86-faulting-instruction xp)
@@ -444 +446 @@
                                            'write-to-watched-object
                                            :instruction insn
-                                           :address addr
+                                           :offset offset
                                            :object object)
                                           nil frame-ptr)
-                      ;; This certainly has the potential to cause amusing
-                      ;; errors.
+                      #-windows-target
                       (allow ()
+                        ;; There may be subtle race conditions here.
                         :report "Allow this write."
                         :test (lambda (c)
@@ -455 +457 @@
                                 (string= (subseq (x86-di-mnemonic insn) 0 3)
                                          "mov"))
-                        (let ((result nil)
-                              (ptr (%int-to-ptr
-                                    (logandc2 addr (1- *host-page-size*)))))
+                        (flet ((watchedp (object)
+                                 (%map-areas #'(lambda (x)
+                                                 (when (eq object x)
+                                                   (return-from watchedp t)))
+                                             area-watched area-watched)))
                           (with-other-threads-suspended
-                            (#_mprotect ptr *host-page-size*
-                                        #$PROT_WRITE)
-                            (setq result (x86-emulate-write-instruction xp insn addr object))
-                            (#_mprotect ptr *host-page-size*
-                                        (logior #$PROT_READ #$PROT_EXEC)))
+                            (when (watchedp object)
+                              ;; We now trust that the object is in a
+                              ;; static gc area.
+                              (let* ((a (+ (%address-of object) offset))
+                                     (ptr (%int-to-ptr
+                                           (logandc2 a (1- *host-page-size*)))))
+                                (#_mprotect ptr *host-page-size* #$PROT_WRITE)
+                                (setq result (x86-emulate-write-instruction
+                                              xp insn offset object))
+                                (#_mprotect ptr *host-page-size*
+                                            (logior #$PROT_READ #$PROT_EXEC)))))
                           (if result
                             (setq skip insn-length)
@@ -472 +482 @@
                       (unwatch ()
                         :report (lambda (s)
-                                  (format s "Unwatch ~s and perform the write." object))
-                        (unwatch object)))))))))
+                                  (format s "Unwatch ~s and perform the write."
+                                          object))
+                        (unwatch object))))))))
           ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
            (if (= code -1)
@@ -488 +499 @@
 (defun x86-faulting-instruction (xp)
   (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
-         (pc (indexed-gpr-macptr xp rip-register-offset)))
+         (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)))