Changeset 12930


Ignore:
Timestamp:
Oct 9, 2009, 4:43:16 AM (10 years ago)
Author:
rme
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:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/watchpoints/lib/misc.lisp

    r12906 r12930  
    10441044              (%ptr-to-int (%svref lock target::lock._value-cell)))))
    10451045
     1046(defun primitive-watch (thing)
     1047  (check-type thing (or cons (satisfies uvectorp)))
     1048  (%watch thing))
     1049
     1050(defun all-watched-objects ()
     1051  (let (result)
     1052    (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
     1053    result))
     1054
     1055(defvar *watch-reverse-map* (make-hash-table))
     1056
     1057;;; DWIM-y interface to watching objects
    10461058(defun watch (&optional thing)
    1047   (if thing
    1048     (progn
    1049       (require-type thing '(or cons (satisfies uvectorp)))
    1050       (%watch thing))
    1051     (let (result)
    1052       (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
    1053       result)))
     1059  (cond
     1060    ((null thing)
     1061     (all-watched-objects))
     1062    ((hash-table-p thing)
     1063     (let ((vector (nhash.vector thing)))
     1064       (setf (gethash vector *watch-reverse-map*) thing)
     1065       (primitive-watch vector)))
     1066    ((arrayp thing)
     1067     (multiple-value-bind (data offset) (array-data-and-offset thing)
     1068       (declare (ignore offset))
     1069       (setf (gethash data *watch-reverse-map*) thing)
     1070       (primitive-watch data)))
     1071    ((standard-instance-p thing)
     1072     (let ((slots (instance-slots thing)))
     1073       (setf (gethash slots *watch-reverse-map*) thing)
     1074       (primitive-watch slots)))
     1075    (t
     1076     (primitive-watch thing))))
    10541077
    10551078(defun unwatch (thing)
     1079  (maphash #'(lambda (k v)
     1080               (when (eq v thing)
     1081                 (setq thing k)))
     1082           *watch-reverse-map*)
     1083  (remhash thing *watch-reverse-map*)
     1084  (check-type thing (or cons (satisfies uvectorp)))
    10561085  (%map-areas #'(lambda (x)
    10571086                  (when (eq x thing)
     
    10681097;;; These functions would seem to belong somewhere else.
    10691098     
    1070 ;; This will work only if the uvector is in a static gc area.
     1099;; This will work reliably only if the uvector is in a static gc area.
    10711100(defun %uvector-index-for-address (uvector address)
    10721101  (let* ((size (uvsize uvector))
     
    10801109         (index (/ offset bytes-per-element)))
    10811110    index))
     1111
     1112(defun %array-index-for-address (array address)
     1113  (multiple-value-bind (data offset)
     1114      (array-data-and-offset array)
     1115    (let* ((i (%uvector-index-for-address data address)))
     1116      (values array (+ i offset)))))
     1117
     1118(defun %hash-table-key-for-address (hash-table address)
     1119  (let* ((v (nhash.vector hash-table))
     1120         (i (%uvector-index-for-address v address))
     1121         (key (uvref v (1- i))))
     1122    (values hash-table key)))
     1123
     1124(defun %slot-name-for-address (object address)
     1125  (let* ((wrapper (instance-class-wrapper object))
     1126         (slot-names (%wrapper-instance-slots wrapper))
     1127         (slots (instance.slots object))
     1128         (i (%uvector-index-for-address slots address)))
     1129    (values object (svref slot-names i))))
     1130
     1131(defun watched-object-and-location (condition)
     1132  (let* ((watched-object (slot-value condition 'object))
     1133         (address (slot-value condition 'address))
     1134         (user-object (or (gethash watched-object *watch-reverse-map*)
     1135                          watched-object)))
     1136    (cond
     1137      ((hash-table-p user-object)
     1138       (%hash-table-key-for-address user-object address))
     1139      ((arrayp user-object)
     1140       (%array-index-for-address user-object address))
     1141      ((standard-instance-p user-object)
     1142       (%slot-name-for-address user-object address))
     1143      ((uvectorp user-object)
     1144       (%uvector-index-for-address user-object address))
     1145      ((consp user-object)
     1146       (let* ((node (%address-of user-object)))
     1147         (if (= address (+ node target::cons.cdr))
     1148           (values user-object (cdr user-object))
     1149           (values user-object (car user-object)))))
     1150      (t
     1151       (values user-object :unknown)))))
    10821152
    10831153(defun x86-imm-reg-p (reg-num)
Note: See TracChangeset for help on using the changeset viewer.