Changeset 12986

Timestamp:

Oct 9, 2009, 10:00:01 PM (15 years ago)

Author:

R. Matthew Emerson

Message:

Update watched-object-related functions to use an offset rather than
an absolute address.

In ALL-WATCHED-OBJECTS and UNWATCH, use WITH-OTHER-THREADS-SUSPENDED in
an attempt to prevent other threads from changing the number of watched
areas while we map over them.

File:

• branches/watchpoints/lib/misc.lisp (modified) (4 diffs)

branches/watchpoints/lib/misc.lisp

@@ -1050 +1050 @@
 (defun all-watched-objects ()
   (let (result)
-    (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
+    (with-other-threads-suspended
+      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched))
     result))
 
@@ -1077 +1078 @@
 
 (defun unwatch (thing)
-  (maphash #'(lambda (k v)
-               (when (eq v thing)
-                 (setq thing k)))
-           *watch-reverse-map*)
+  (block search
+    (maphash #'(lambda (k v)
+                 (when (eq v thing)
+                   (setq thing k)
+                   (return-from search)))
+             *watch-reverse-map*))
   (remhash thing *watch-reverse-map*)
   (check-type thing (or cons (satisfies uvectorp)))
-  (%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))
-
-;;; These functions would seem to belong somewhere else.
-      
-;; This will work reliably only if the uvector is in a static gc area.
-(defun %uvector-index-for-address (uvector address)
+  (with-other-threads-suspended
+    (%map-areas #'(lambda (x)
+                    (when (eq x thing)
+                      ;; Note that we'll be unlinking an area from the
+                      ;; area list while %map-areas iterates over 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)))
+
+;; offset is byte offset from tagged uvector pointer
+(defun %uvector-index-for-offset (uvector offset)
   (let* ((size (uvsize uvector))
          (nbytes (if (ivectorp uvector)
@@ -1104 +1105 @@
                    (* size target::node-size)))
          (bytes-per-element (/ nbytes size))
-         (noderef (logandc2 (%address-of uvector)
-                            target::fulltagmask))
-         (offset (- address (+ noderef target::node-size)))
+         ;; account for tag, header
+         (offset (- offset target::misc-data-offset))
          (index (/ offset bytes-per-element)))
-    index))
-
-(defun %array-index-for-address (array address)
-  (multiple-value-bind (data offset)
+    (if (fixnump index)
+      index
+      (error "offset corresponds to non-integral index"))))
+
+(defun %array-index-for-offset (array offset)
+  (multiple-value-bind (array-data array-offset)
       (array-data-and-offset array)
-    (let* ((i (%uvector-index-for-address data address)))
-      (values array (+ i offset)))))
-
-(defun %hash-table-key-for-address (hash-table address)
+    (let* ((i (%uvector-index-for-offset array-data offset)))
+      (- i array-offset))))
+
+(defun %hash-table-key-for-offset (hash-table offset)
   (let* ((v (nhash.vector hash-table))
-         (i (%uvector-index-for-address v address))
+         (i (%uvector-index-for-offset v offset))
          (key (uvref v (1- i))))
-    (values hash-table key)))
-
-(defun %slot-name-for-address (object address)
+    key))
+
+(defun %slot-name-for-offset (object offset)
   (let* ((wrapper (instance-class-wrapper object))
          (slot-names (%wrapper-instance-slots wrapper))
          (slots (instance.slots object))
-         (i (%uvector-index-for-address slots address)))
-    (values object (svref slot-names i))))
-
-(defun watched-object-and-location (condition)
-  (let* ((watched-object (slot-value condition 'object))
-         (address (slot-value condition 'address))
-         (user-object (or (gethash watched-object *watch-reverse-map*)
-                          watched-object)))
+         (i (%uvector-index-for-offset slots offset)))
+    ;; slot-vectors have their corresponding instance in element 0
+    (decf i)
+    (svref slot-names i)))
+
+(defun watched-object-container (object)
+  (or (gethash object *watch-reverse-map*) object))
+
+(defun watched-object-write-location (condition)
+  (let* ((object (slot-value condition 'object))
+         (offset (slot-value condition 'offset))
+         (user-object (watched-object-container object)))
     (cond
       ((hash-table-p user-object)
-       (%hash-table-key-for-address user-object address))
+       (%hash-table-key-for-offset user-object offset))
       ((arrayp user-object)
-       (%array-index-for-address user-object address))
+       (%array-index-for-offset user-object offset))
       ((standard-instance-p user-object)
-       (%slot-name-for-address user-object address))
+       (%slot-name-for-offset user-object offset))
       ((uvectorp user-object)
-       (%uvector-index-for-address user-object address))
+       (%uvector-index-for-offset user-object offset))
       ((consp user-object)
-       (let* ((node (%address-of user-object)))
-         (if (= address (+ node target::cons.cdr))
-           (values user-object (cdr user-object))
-           (values user-object (car user-object)))))
+       (if (= offset target::cons.cdr)
+         (cdr user-object)
+         (car user-object)))
       (t
-       (values user-object :unknown)))))
-
-(defun x86-imm-reg-p (reg-num)
-  (member reg-num (list x8664::imm0 x8664::imm1 x8664::imm2
-                        x8664::imm0.l x8664::imm0.l x8664::imm2.l
-                        x8664::imm0.w x8664::imm0.w x8664::imm2.w
-                        x8664::imm0.b x8664::imm0.b x8664::imm2.b)))
+       nil))))
 
 ;;; Try to emulate the instruction.  Returns true on success,
-;;; NIL on failure.  If dest isn't in a static area, we will lose...
-(defun x86-emulate-write-instruction (xp insn addr dest)
+;;; NIL on failure.
+(defun x86-emulate-write-instruction (xp insn offset dest)
   (let ((op0 (x86-di-op0 insn)))
     (unless (and (typep op0 'x86::x86-register-operand)
@@ -1169 +1168 @@
         (cond ((gvectorp dest)
                (let* ((src (encoded-gpr-lisp xp reg-num))
-                      (index (%uvector-index-for-address dest addr)))
-                 (if (fixnump index)
-                   (setf (uvref dest index) src))))
+                      (index (%uvector-index-for-offset dest offset)))
+                 (setf (uvref dest index) src)))
               ((ivectorp dest)
-               (let* ((src (if (x86-imm-reg-p reg-num)
-                             (encoded-gpr-integer xp reg-num)
-                             (encoded-gpr-lisp xp reg-num)))
-                      (index (%uvector-index-for-address dest addr)))
-                 (if (fixnump index)
-                   (setf (uvref dest index) src))
-               (setq src (encoded-gpr-lisp xp reg-num)))))
+               (let* ((src (encoded-gpr-integer xp reg-num))
+                      (index (%uvector-index-for-offset dest offset)))
+                 (setf (uvref dest index) src))))
         (if (consp dest)
           (let* ((src (encoded-gpr-lisp xp reg-num)))
-            (if (= addr (+ (%address-of dest) target::cons.cdr))
+            (if (= offset target::cons.cdr)
               (rplacd dest src)
-              (if (= addr (+ (%address-of dest) target::cons.car))
+              (if (= offset target::cons.car)
                 (rplaca dest src)))))))))