Changeset 13009


Ignore:
Timestamp:
Oct 13, 2009, 2:13:35 PM (10 years ago)
Author:
gz
Message:

Watchpoint changes from trunk (r13001 to r13008)

Location:
branches/working-0711/ccl
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

    r12949 r13009  
    27582758      (out stream expr))))
    27592759
     2760(defun x86-print-bare-disassembled-instruction (ds instruction)
     2761  (dolist (p (x86-di-prefixes instruction))
     2762    (format t "~&  (~a)~%" p))
     2763  (format t "  (~a" (x86-di-mnemonic instruction))
     2764  (let* ((op0 (x86-di-op0 instruction))
     2765         (op1 (x86-di-op1 instruction))
     2766         (op2 (x86-di-op2 instruction)))
     2767    (when op0
     2768      (write-x86-lap-operand t op0 ds)
     2769      (when op1
     2770        (write-x86-lap-operand t op1 ds)
     2771        (when op2
     2772          (write-x86-lap-operand t op2 ds)))))
     2773  (format t ")"))
     2774
    27602775(defvar *previous-source-note*)
    27612776
     
    27772792      (setq seq 0))
    27782793    (format t "~&  [~D]~8T" pc)
    2779     (dolist (p (x86-di-prefixes instruction))
    2780       (format t "~&  (~a)~%" p))
    2781     (format t "  (~a" (x86-di-mnemonic instruction))
    2782     (let* ((op0 (x86-di-op0 instruction))
    2783            (op1 (x86-di-op1 instruction))
    2784            (op2 (x86-di-op2 instruction)))
    2785       (when op0
    2786         (write-x86-lap-operand t op0 ds)
    2787         (when op1
    2788         (write-x86-lap-operand t op1 ds)
    2789           (when op2
    2790             (write-x86-lap-operand t op2 ds)))))
    2791     (format t ")")
     2794    (x86-print-bare-disassembled-instruction ds instruction)
    27922795    (format t "~%")
    27932796    (1+ seq)))
  • branches/working-0711/ccl/level-0/X86/x86-utils.lisp

    r12994 r13009  
    449449  (movl ($ arch::watch-trap-function-watch) (%l imm0))
    450450  (uuo-watch-trap)
    451   (movl ($ nil) (%l arg_z))
    452451  (single-value-return))
    453452
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r12994 r13009  
    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)
  • branches/working-0711/ccl/level-1/x86-trap-support.lisp

    r12994 r13009  
    387387;;; may not be meaningful.
    388388(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
    389   (let* ((frame-ptr (macptr->fixnum xcf)))
     389  (let* ((frame-ptr (macptr->fixnum xcf))
     390         (skip 0))
    390391    (cond ((zerop signal)               ;thread interrupt
    391392           (cmain))
     
    431432             ((= code 2)
    432433              ;; Write to a watched object.
    433               (flet ((%int-to-object (i)
    434                        (rlet ((a :address))
    435                          (setf (%get-ptr a) (%int-to-ptr i))
    436                          (%get-object a 0))))
    437                 (let ((object (%int-to-object other)))
     434              (let* ((offset other)
     435                     ;; The kernel exception handler leaves the
     436                     ;; watched object on the lisp stack under the
     437                     ;; xcf.
     438                     (object (%get-object xcf target::xcf.size)))
     439                (multiple-value-bind (insn insn-length)
     440                    (ignore-errors (x86-faulting-instruction xp))
    438441                  (restart-case (%error (make-condition
    439442                                         'write-to-watched-object
    440                                          :address addr
    441                                          :object object)
     443                                         :offset offset
     444                                         :object object
     445                                         :instruction insn)
    442446                                        nil frame-ptr)
     447                    (skip ()
     448                      :test (lambda (c)
     449                              (declare (ignore c))
     450                              insn)
     451                      :report "Skip over this write instruction."
     452                      (setq skip insn-length))
    443453                    (unwatch ()
    444                       :report (lambda (s)
    445                                 (format s "Unwatch ~s and perform the write." object))
     454                      :report "Unwatch the object and retry the write."
    446455                      (unwatch object))))))))
    447456          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
     
    454463                                     :write-p (not (zerop code)))
    455464                     ()
    456                      frame-ptr)))))
    457   0)
     465                     frame-ptr))))
     466    skip))
     467
     468(defun x86-faulting-instruction (xp)
     469  (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8)))
     470         (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset
     471                                    #+x8664-target rip-register-offset)))
     472    (dotimes (i (length code-bytes))
     473      (setf (aref code-bytes i) (%get-unsigned-byte pc i)))
     474    (let* ((ds (make-x86-disassembly-state
     475                :mode-64 #+x8664-target t #+x8632-target nil
     476                :code-vector code-bytes
     477                :code-pointer 0))
     478           (insn (x86-disassemble-instruction ds nil))
     479           (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds))))
     480      (values insn len))))
  • branches/working-0711/ccl/lib/misc.lisp

    r12994 r13009  
    10521052              (%ptr-to-int (%svref lock target::lock._value-cell)))))
    10531053
     1054(defun all-watched-objects ()
     1055  (let (result)
     1056    (with-other-threads-suspended
     1057      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched))
     1058    result))
     1059   
    10541060(defun watch (&optional thing)
    10551061  (if thing
     
    10571063      (require-type thing '(or cons (satisfies uvectorp)))
    10581064      (%watch thing))
    1059     (let (result)
    1060       (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
    1061       result)))
     1065    (all-watched-objects)))
    10621066
    10631067(defun unwatch (thing)
    1064   (%map-areas #'(lambda (x)
    1065                   (when (eq x thing)
    1066                     ;; This is a rather questionable thing to do,
    1067                     ;; since we'll be unlinking an area from the area
    1068                     ;; list while %map-areas iterates over it, but I
    1069                     ;; think we'll get away with it.
    1070                     (let ((new (if (uvectorp thing)
    1071                                  (%alloc-misc (uvsize thing) (typecode thing))
    1072                                  (cons nil nil))))
    1073                       (return-from unwatch (%unwatch thing new)))))
    1074               area-watched area-watched))
     1068  (with-other-threads-suspended
     1069    (%map-areas #'(lambda (x)
     1070                    (when (eq x thing)
     1071                      (let ((new (if (uvectorp thing)
     1072                                   (%alloc-misc (uvsize thing)
     1073                                                (typecode thing))
     1074                                   (cons nil nil))))
     1075                        (return-from unwatch (%unwatch thing new)))))
     1076                area-watched area-watched)))
    10751077     
  • branches/working-0711/ccl/lisp-kernel/x86-exceptions.c

    r12994 r13009  
    842842          LispObj save_vsp = xpGPR(xp, Isp);
    843843          LispObj save_fp = xpGPR(xp, Ifp);
    844           LispObj xcf = create_exception_callback_frame(xp, tcr);
     844          LispObj xcf;
     845          natural offset = (LispObj)addr - obj;
    845846          int skip;
    846847
     848          push_on_lisp_stack(xp, obj);
     849          xcf = create_exception_callback_frame(xp, tcr);
     850
    847851          /* The magic 2 means this was a write to a watchd object */
    848           skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, (natural) addr, obj);
     852          skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2,
     853                                  (natural)addr, offset);
    849854          xpPC(xp) += skip;
    850855          xpGPR(xp, Ifp) = save_fp;
  • branches/working-0711/ccl/lisp-kernel/x86-gc.c

    r12994 r13009  
    28132813 */
    28142814
    2815 static inline void
     2815static inline int
    28162816wp_maybe_update(LispObj *p, LispObj old, LispObj new)
    28172817{
    28182818  if (*p == old) {
    28192819    *p = new;
    2820   }
     2820    return true;
     2821  }
     2822  return false;
    28212823}
    28222824
     
    28482850    } else if (nodeheader_tag_p(tag_n)) {
    28492851      nwords = header_element_count(node);
    2850      
    28512852      nwords += 1 - (nwords & 1);
    28522853
     
    28592860        nwords -= skip;
    28602861        while(skip--) {
    2861           if (*p == old) *p = new;
     2862          wp_maybe_update(p, old, new);
    28622863          p++;
    28632864        }
     
    28682869        nwords >>= 1;
    28692870        while(nwords--) {
    2870           if (*p == old && hashp) {
    2871             *p = new;
     2871          if (wp_maybe_update(p, old, new) && hashp) {
    28722872            hashp->flags |= nhash_key_moved_mask;
    28732873            hashp = NULL;
    28742874          }
    28752875          p++;
    2876           if (*p == old) *p = new;
     2876          wp_maybe_update(p, old, new);
    28772877          p++;
    28782878        }
     
    30573057    other_tcr = other_tcr->next;
    30583058  } while (other_tcr != tcr);
     3059  unprotect_watched_areas();
    30593060  wp_update_all_areas(old, new);
    3060 }
     3061  protect_watched_areas();
     3062}
Note: See TracChangeset for help on using the changeset viewer.