Changeset 12986


Ignore:
Timestamp:
Oct 10, 2009, 5:00:01 AM (10 years ago)
Author:
rme
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:
1 edited

Legend:

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

    r12930 r12986  
    10501050(defun all-watched-objects ()
    10511051  (let (result)
    1052     (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
     1052    (with-other-threads-suspended
     1053      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched))
    10531054    result))
    10541055
     
    10771078
    10781079(defun unwatch (thing)
    1079   (maphash #'(lambda (k v)
    1080                (when (eq v thing)
    1081                  (setq thing k)))
    1082            *watch-reverse-map*)
     1080  (block search
     1081    (maphash #'(lambda (k v)
     1082                 (when (eq v thing)
     1083                   (setq thing k)
     1084                   (return-from search)))
     1085             *watch-reverse-map*))
    10831086  (remhash thing *watch-reverse-map*)
    10841087  (check-type thing (or cons (satisfies uvectorp)))
    1085   (%map-areas #'(lambda (x)
    1086                   (when (eq x thing)
    1087                     ;; This is a rather questionable thing to do,
    1088                     ;; since we'll be unlinking an area from the area
    1089                     ;; list while %map-areas iterates over it, but I
    1090                     ;; think we'll get away with it.
    1091                     (let ((new (if (uvectorp thing)
    1092                                  (%alloc-misc (uvsize thing) (typecode thing))
    1093                                  (cons nil nil))))
    1094                       (return-from unwatch (%unwatch thing new)))))
    1095               area-watched area-watched))
    1096 
    1097 ;;; These functions would seem to belong somewhere else.
    1098      
    1099 ;; This will work reliably only if the uvector is in a static gc area.
    1100 (defun %uvector-index-for-address (uvector address)
     1088  (with-other-threads-suspended
     1089    (%map-areas #'(lambda (x)
     1090                    (when (eq x thing)
     1091                      ;; Note that we'll be unlinking an area from the
     1092                      ;; area list while %map-areas iterates over it.
     1093                      (let ((new (if (uvectorp thing)
     1094                                   (%alloc-misc (uvsize thing)
     1095                                                (typecode thing))
     1096                                   (cons nil nil))))
     1097                        (return-from unwatch (%unwatch thing new)))))
     1098                area-watched area-watched)))
     1099
     1100;; offset is byte offset from tagged uvector pointer
     1101(defun %uvector-index-for-offset (uvector offset)
    11011102  (let* ((size (uvsize uvector))
    11021103         (nbytes (if (ivectorp uvector)
     
    11041105                   (* size target::node-size)))
    11051106         (bytes-per-element (/ nbytes size))
    1106          (noderef (logandc2 (%address-of uvector)
    1107                             target::fulltagmask))
    1108          (offset (- address (+ noderef target::node-size)))
     1107         ;; account for tag, header
     1108         (offset (- offset target::misc-data-offset))
    11091109         (index (/ offset bytes-per-element)))
    1110     index))
    1111 
    1112 (defun %array-index-for-address (array address)
    1113   (multiple-value-bind (data offset)
     1110    (if (fixnump index)
     1111      index
     1112      (error "offset corresponds to non-integral index"))))
     1113
     1114(defun %array-index-for-offset (array offset)
     1115  (multiple-value-bind (array-data array-offset)
    11141116      (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)
     1117    (let* ((i (%uvector-index-for-offset array-data offset)))
     1118      (- i array-offset))))
     1119
     1120(defun %hash-table-key-for-offset (hash-table offset)
    11191121  (let* ((v (nhash.vector hash-table))
    1120          (i (%uvector-index-for-address v address))
     1122         (i (%uvector-index-for-offset v offset))
    11211123         (key (uvref v (1- i))))
    1122     (values hash-table key)))
    1123 
    1124 (defun %slot-name-for-address (object address)
     1124    key))
     1125
     1126(defun %slot-name-for-offset (object offset)
    11251127  (let* ((wrapper (instance-class-wrapper object))
    11261128         (slot-names (%wrapper-instance-slots wrapper))
    11271129         (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)))
     1130         (i (%uvector-index-for-offset slots offset)))
     1131    ;; slot-vectors have their corresponding instance in element 0
     1132    (decf i)
     1133    (svref slot-names i)))
     1134
     1135(defun watched-object-container (object)
     1136  (or (gethash object *watch-reverse-map*) object))
     1137
     1138(defun watched-object-write-location (condition)
     1139  (let* ((object (slot-value condition 'object))
     1140         (offset (slot-value condition 'offset))
     1141         (user-object (watched-object-container object)))
    11361142    (cond
    11371143      ((hash-table-p user-object)
    1138        (%hash-table-key-for-address user-object address))
     1144       (%hash-table-key-for-offset user-object offset))
    11391145      ((arrayp user-object)
    1140        (%array-index-for-address user-object address))
     1146       (%array-index-for-offset user-object offset))
    11411147      ((standard-instance-p user-object)
    1142        (%slot-name-for-address user-object address))
     1148       (%slot-name-for-offset user-object offset))
    11431149      ((uvectorp user-object)
    1144        (%uvector-index-for-address user-object address))
     1150       (%uvector-index-for-offset user-object offset))
    11451151      ((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)))))
     1152       (if (= offset target::cons.cdr)
     1153         (cdr user-object)
     1154         (car user-object)))
    11501155      (t
    1151        (values user-object :unknown)))))
    1152 
    1153 (defun x86-imm-reg-p (reg-num)
    1154   (member reg-num (list x8664::imm0 x8664::imm1 x8664::imm2
    1155                         x8664::imm0.l x8664::imm0.l x8664::imm2.l
    1156                         x8664::imm0.w x8664::imm0.w x8664::imm2.w
    1157                         x8664::imm0.b x8664::imm0.b x8664::imm2.b)))
     1156       nil))))
    11581157
    11591158;;; Try to emulate the instruction.  Returns true on success,
    1160 ;;; NIL on failure.  If dest isn't in a static area, we will lose...
    1161 (defun x86-emulate-write-instruction (xp insn addr dest)
     1159;;; NIL on failure.
     1160(defun x86-emulate-write-instruction (xp insn offset dest)
    11621161  (let ((op0 (x86-di-op0 insn)))
    11631162    (unless (and (typep op0 'x86::x86-register-operand)
     
    11691168        (cond ((gvectorp dest)
    11701169               (let* ((src (encoded-gpr-lisp xp reg-num))
    1171                       (index (%uvector-index-for-address dest addr)))
    1172                  (if (fixnump index)
    1173                    (setf (uvref dest index) src))))
     1170                      (index (%uvector-index-for-offset dest offset)))
     1171                 (setf (uvref dest index) src)))
    11741172              ((ivectorp dest)
    1175                (let* ((src (if (x86-imm-reg-p reg-num)
    1176                              (encoded-gpr-integer xp reg-num)
    1177                              (encoded-gpr-lisp xp reg-num)))
    1178                       (index (%uvector-index-for-address dest addr)))
    1179                  (if (fixnump index)
    1180                    (setf (uvref dest index) src))
    1181                (setq src (encoded-gpr-lisp xp reg-num)))))
     1173               (let* ((src (encoded-gpr-integer xp reg-num))
     1174                      (index (%uvector-index-for-offset dest offset)))
     1175                 (setf (uvref dest index) src))))
    11821176        (if (consp dest)
    11831177          (let* ((src (encoded-gpr-lisp xp reg-num)))
    1184             (if (= addr (+ (%address-of dest) target::cons.cdr))
     1178            (if (= offset target::cons.cdr)
    11851179              (rplacd dest src)
    1186               (if (= addr (+ (%address-of dest) target::cons.car))
     1180              (if (= offset target::cons.car)
    11871181                (rplaca dest src)))))))))
Note: See TracChangeset for help on using the changeset viewer.