Changeset 13003


Ignore:
Timestamp:
Oct 13, 2009, 12:06:07 AM (10 years ago)
Author:
rme
Message:

Revise the definition of the write-to-watched-object condition.
Use an offset slot instead of an (absolute) address. Add an instruction
slot, which will contain the disassembled faulting instruction (or nil,
if something went wrong with the disassembly).

Provide a fancier report function.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-error-system.lisp

    r12940 r13003  
    105105
    106106(define-condition write-to-watched-object (storage-condition)
    107   ((address :initarg :address)
    108    (object :initform nil :initarg :object))
    109   (:report (lambda (c s)
    110              (with-slots (object address) c
    111                (if (uvectorp object)
    112                  ;; This is safe only because watched objects are in a
    113                  ;; static GC area and won't be moved around.
    114                  (let* ((size (uvsize object))
    115                         (nbytes (if (ivectorp object)
    116                                   (subtag-bytes (typecode object) size)
    117                                   (* size target::node-size)))
    118                         (bytes-per-element (/ nbytes size))
    119                         (noderef (logandc2 (%address-of object)
    120                                            target::fulltagmask))
    121                         (offset (- address (+ noderef target::node-size)))
    122                         (index (/ offset bytes-per-element)))
    123                    (format s "Write to watched object ~s at address #x~x (uvector index ~d)." object address index))
    124                  (format s "Write to watched object ~s at address #x~x" object address))))))
     107  ((object :initform nil :initarg :object
     108           :reader write-to-watched-object-object)
     109   (offset :initarg :offset
     110           :reader write-to-watched-object-offset)
     111   (instruction :initarg :instruction))
     112  (:report report-write-to-watched-object))
     113
     114(defun report-write-to-watched-object (c s)
     115  (with-slots (object offset instruction) c
     116    (cond
     117      ((uvectorp object)
     118       (let* ((count (uvsize object))
     119              (nbytes (if (ivectorp object)
     120                        (subtag-bytes (typecode object) count)
     121                        (* count target::node-size)))
     122              (bytes-per-element (/ nbytes count))
     123              (offset (- offset target::misc-data-offset))
     124              (index (/ offset bytes-per-element)))
     125         (format s "Write to watched uvector ~s at " object)
     126         (if (fixnump index)
     127           (format s "index ~s" index)
     128           (format s "an apparently unaligned byte offset ~s" offset))))
     129      ((consp object)
     130       (format s "Write to ~a watched cons cell ~s"
     131               (cond
     132                 ((= offset target::cons.cdr) "the CDR of")
     133                 ((= offset target::cons.car) "the CAR of")
     134                 (t
     135                  (format nil "an apparently unaligned byte offset (~s) into"
     136                          offset)))
     137               object))
     138      (t
     139       (format s "Write to a strange object ~s at byte offset ~s"
     140               object offset)))
     141    (when instruction
     142      (let* ((ds (make-x86-disassembly-state :mode-64 #+x8664-target t
     143                                                      #+x8632-target nil
     144                                             :code-vector nil
     145                                             :code-pointer 0))
     146             (str (with-output-to-string (*standard-output*)
     147                    (x86-print-bare-disassembled-instruction ds instruction))))
     148        (format s "~&Faulting instruction: ~a" (string-trim " " str))))))
    125149
    126150(define-condition type-error (error)
Note: See TracChangeset for help on using the changeset viewer.