Changeset 12930

Timestamp:

Oct 8, 2009, 9:43:16 PM (15 years ago)

Author:

R. Matthew Emerson

Message:

Try to get cute and make WATCH a little more DWIM-y by automatically
watching the underlying data/hash table/slot vector when watching
arrays/hash tables/standard instances.

New function watched-object-and-location will try to show the "user-level"
watched object and the row-major array index/hash table key/slot name.

File:

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

branches/watchpoints/lib/misc.lisp

@@ -1044 +1044 @@
               (%ptr-to-int (%svref lock target::lock._value-cell)))))
 
+(defun primitive-watch (thing)
+  (check-type thing (or cons (satisfies uvectorp)))
+  (%watch thing))
+
+(defun all-watched-objects ()
+  (let (result)
+    (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
+    result))
+
+(defvar *watch-reverse-map* (make-hash-table))
+
+;;; DWIM-y interface to watching objects
 (defun watch (&optional thing)
-  (if thing
-    (progn
-      (require-type thing '(or cons (satisfies uvectorp)))
-      (%watch thing))
-    (let (result)
-      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
-      result)))
+  (cond
+    ((null thing)
+     (all-watched-objects))
+    ((hash-table-p thing)
+     (let ((vector (nhash.vector thing)))
+       (setf (gethash vector *watch-reverse-map*) thing)
+       (primitive-watch vector)))
+    ((arrayp thing)
+     (multiple-value-bind (data offset) (array-data-and-offset thing)
+       (declare (ignore offset))
+       (setf (gethash data *watch-reverse-map*) thing)
+       (primitive-watch data)))
+    ((standard-instance-p thing)
+     (let ((slots (instance-slots thing)))
+       (setf (gethash slots *watch-reverse-map*) thing)
+       (primitive-watch slots)))
+    (t
+     (primitive-watch thing))))
 
 (defun unwatch (thing)
+  (maphash #'(lambda (k v)
+               (when (eq v thing)
+                 (setq thing k)))
+           *watch-reverse-map*)
+  (remhash thing *watch-reverse-map*)
+  (check-type thing (or cons (satisfies uvectorp)))
   (%map-areas #'(lambda (x)
                   (when (eq x thing)
@@ -1068 +1097 @@
 ;;; These functions would seem to belong somewhere else.
       
-;; This will work only if the uvector is in a static gc area.
+;; This will work reliably only if the uvector is in a static gc area.
 (defun %uvector-index-for-address (uvector address)
   (let* ((size (uvsize uvector))
@@ -1080 +1109 @@
          (index (/ offset bytes-per-element)))
     index))
+
+(defun %array-index-for-address (array address)
+  (multiple-value-bind (data 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* ((v (nhash.vector hash-table))
+         (i (%uvector-index-for-address v address))
+         (key (uvref v (1- i))))
+    (values hash-table key)))
+
+(defun %slot-name-for-address (object address)
+  (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)))
+    (cond
+      ((hash-table-p user-object)
+       (%hash-table-key-for-address user-object address))
+      ((arrayp user-object)
+       (%array-index-for-address user-object address))
+      ((standard-instance-p user-object)
+       (%slot-name-for-address user-object address))
+      ((uvectorp user-object)
+       (%uvector-index-for-address user-object address))
+      ((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)))))
+      (t
+       (values user-object :unknown)))))
 
 (defun x86-imm-reg-p (reg-num)