Index: /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 13042) +++ /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 13043) @@ -36,5 +36,21 @@ (defmethod print-object ((xdi x86-disassembled-instruction) stream) (print-unreadable-object (xdi stream :type t :identity t) - (format stream "~a" (x86-di-mnemonic xdi)))) + (dolist (p (x86-di-prefixes xdi)) + (format stream "(~a) " p)) + (format stream "(~a" (x86-di-mnemonic xdi)) + (let* ((op0 (x86-di-op0 xdi)) + (op1 (x86-di-op1 xdi)) + (op2 (x86-di-op2 xdi)) + (ds (make-x86-disassembly-state :mode-64 #+x8664-target t + #+x8632-target nil + :code-vector nil + :code-pointer 0))) + (when op0 + (write-x86-lap-operand stream op0 ds) + (when op1 + (write-x86-lap-operand stream op1 ds) + (when op2 + (write-x86-lap-operand stream op2 ds))))) + (format stream ")"))) (defstruct (x86-disassembly-state (:conc-name x86-ds-)) @@ -2758,19 +2774,4 @@ (out stream expr)))) -(defun x86-print-bare-disassembled-instruction (ds instruction) - (dolist (p (x86-di-prefixes instruction)) - (format t "~& (~a)~%" p)) - (format t " (~a" (x86-di-mnemonic instruction)) - (let* ((op0 (x86-di-op0 instruction)) - (op1 (x86-di-op1 instruction)) - (op2 (x86-di-op2 instruction))) - (when op0 - (write-x86-lap-operand t op0 ds) - (when op1 - (write-x86-lap-operand t op1 ds) - (when op2 - (write-x86-lap-operand t op2 ds))))) - (format t ")")) - (defvar *previous-source-note*) @@ -2792,5 +2793,17 @@ (setq seq 0)) (format t "~& [~D]~8T" pc) - (x86-print-bare-disassembled-instruction ds instruction) + (dolist (p (x86-di-prefixes instruction)) + (format t "~& (~a)~%" p)) + (format t " (~a" (x86-di-mnemonic instruction)) + (let* ((op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when op0 + (write-x86-lap-operand t op0 ds) + (when op1 + (write-x86-lap-operand t op1 ds) + (when op2 + (write-x86-lap-operand t op2 ds))))) + (format t ")") (format t "~%") (1+ seq))) Index: /branches/working-0711/ccl/level-1/l1-error-system.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-error-system.lisp (revision 13042) +++ /branches/working-0711/ccl/level-1/l1-error-system.lisp (revision 13043) @@ -109,5 +109,6 @@ (offset :initarg :offset :reader write-to-watched-object-offset) - (instruction :initarg :instruction)) + (instruction :initarg :instruction + :reader write-to-watched-object-instruction)) (:report report-write-to-watched-object)) @@ -140,11 +141,5 @@ object offset))) (when instruction - (let* ((ds (make-x86-disassembly-state :mode-64 #+x8664-target t - #+x8632-target nil - :code-vector nil - :code-pointer 0)) - (str (with-output-to-string (*standard-output*) - (x86-print-bare-disassembled-instruction ds instruction)))) - (format s "~&Faulting instruction: ~a" (string-trim " " str)))))) + (format s "~&Faulting instruction: ~s" instruction)))) (define-condition type-error (error) Index: /branches/working-0711/ccl/level-1/x86-trap-support.lisp =================================================================== --- /branches/working-0711/ccl/level-1/x86-trap-support.lisp (revision 13042) +++ /branches/working-0711/ccl/level-1/x86-trap-support.lisp (revision 13043) @@ -445,4 +445,31 @@ :instruction insn) nil frame-ptr) + #-windows-target + (emulate () + :test (lambda (c) + (declare (ignore c)) + (x86-can-emulate-instruction insn)) + :report + "Emulate this instruction, leaving the object watched." + (flet ((watchedp (object) + (%map-areas #'(lambda (x) + (when (eq object x) + (return-from watchedp t))) + area-watched area-watched))) + (let ((result nil)) + (with-other-threads-suspended + (when (watchedp object) + ;; We now trust that the object is in a + ;; static gc area. + (let* ((a (+ (%address-of object) offset)) + (ptr (%int-to-ptr + (logandc2 a (1- *host-page-size*))))) + (#_mprotect ptr *host-page-size* #$PROT_WRITE) + (setq result (x86-emulate-instruction xp insn)) + (#_mprotect ptr *host-page-size* + (logior #$PROT_READ #$PROT_EXEC))))) + (if result + (setq skip insn-length) + (error "could not emulate the instrution"))))) (skip () :test (lambda (c) Index: /branches/working-0711/ccl/lib/compile-ccl.lisp =================================================================== --- /branches/working-0711/ccl/lib/compile-ccl.lisp (revision 13042) +++ /branches/working-0711/ccl/lib/compile-ccl.lisp (revision 13043) @@ -175,5 +175,5 @@ (case target ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble)) - ((:x8632 :x8664) '(x86-backtrace x86-disassemble))))) + ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch))))) Index: /branches/working-0711/ccl/lib/misc.lisp =================================================================== --- /branches/working-0711/ccl/lib/misc.lisp (revision 13042) +++ /branches/working-0711/ccl/lib/misc.lisp (revision 13043) @@ -1057,11 +1057,20 @@ (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)) result)) - + +(defun primitive-watch (thing) + (require-type thing '(or cons (satisfies uvectorp))) + (%watch thing)) + (defun watch (&optional thing) - (if thing - (progn - (require-type thing '(or cons (satisfies uvectorp))) - (%watch thing)) - (all-watched-objects))) + (cond ((null thing) + (all-watched-objects)) + ((arrayp thing) + (primitive-watch (array-data-and-offset thing))) + ((hash-table-p thing) + (primitive-watch (nhash.vector thing))) + ((standard-instance-p thing) + (primitive-watch (instance-slots thing))) + (t + (primitive-watch thing)))) (defun unwatch (thing) @@ -1075,3 +1084,2 @@ (return-from unwatch (%unwatch thing new))))) area-watched area-watched))) - Index: /branches/working-0711/ccl/lib/systems.lisp =================================================================== --- /branches/working-0711/ccl/lib/systems.lisp (revision 13042) +++ /branches/working-0711/ccl/lib/systems.lisp (revision 13043) @@ -161,4 +161,5 @@ (ppc-backtrace "ccl:bin;ppc-backtrace" ("ccl:lib;ppc-backtrace.lisp")) (x86-backtrace "ccl:bin;x86-backtrace" ("ccl:lib;x86-backtrace.lisp")) + (x86-watch "ccl:bin;x86-watch" ("ccl:lib;x86-watch.lisp")) (backtrace-lds "ccl:bin;backtrace-lds" ("ccl:lib;backtrace-lds.lisp")) (apropos "ccl:bin;apropos" ("ccl:lib;apropos.lisp")) Index: /branches/working-0711/ccl/lib/x86-watch.lisp =================================================================== --- /branches/working-0711/ccl/lib/x86-watch.lisp (revision 13043) +++ /branches/working-0711/ccl/lib/x86-watch.lisp (revision 13043) @@ -0,0 +1,73 @@ +(in-package "CCL") + +;;; Return the effective address of a memory operand by using the +;;; register state in xp, or NIL if we can't figure it out. +;;; Needs to run inside a without-gcing form. +(defun x86-memory-operand-ea (xp op) + (let* ((seg (x86::x86-memory-operand-seg op)) + (disp (x86::x86-memory-operand-disp op)) + (base (x86::x86-memory-operand-base op)) + (index (x86::x86-memory-operand-index op)) + (scale (x86::x86-memory-operand-scale op))) + (cond + ((and base index (not seg)) + (let* ((base-re (x86::x86-register-operand-entry base)) + (index-re (x86::x86-register-operand-entry index)) + (base-num (x86::reg-entry-reg-num base-re)) + (index-num (x86::reg-entry-reg-num index-re)) + (base-val nil) + (index-val nil)) + (when (logtest (x86::reg-entry-reg-flags base-re) x86::+regrex+) + (incf base-num 8)) + (setq base-val (encoded-gpr-integer xp base-num)) + (when (logtest (x86::reg-entry-reg-flags index-re) x86::+regrex+) + (incf index-num 8)) + (setq index-val (encoded-gpr-integer xp index-num)) + (when scale + (setq index-val (ash index-val scale))) + (+ (or disp 0) base-val index-val)))))) + +;;; Try to emulate the disassembled instruction using the +;;; register state in xp. Return NIL if we couldn't do it. +;;; This will run with other threads suspended. +(defun x86-emulate-instruction (xp instruction) + (let* ((mnemonic (x86-di-mnemonic instruction)) + (op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when (and op0 op1 (not op2) + (typep op0 'x86::x86-register-operand) + (typep op1 'x86::x86-memory-operand)) + (without-gcing + (let* ((src-re (x86::x86-register-operand-entry op0)) + (src-num (x86::reg-entry-reg-num src-re)) + (src-val nil) + (ea (x86-memory-operand-ea xp op1))) + (when (logtest (x86::reg-entry-reg-flags src-re) x86::+regrex+) + (incf src-num 8)) + (setq src-val (encoded-gpr-integer xp src-num)) + (when ea + (with-macptrs ((p (%int-to-ptr ea))) + (cond + ((string= mnemonic "movb") + (setf (%get-signed-byte p) (ldb (byte 8 0) src-val))) + ((string= mnemonic "movw") + (setf (%get-signed-word p) (ldb (byte 16 0) src-val))) + ((string= mnemonic "movl") + (setf (%get-signed-long p) (ldb (byte 32 0) src-val))) + ((string= mnemonic "movq") + (setf (%%get-signed-longlong p 0) (ldb (byte 64 0) src-val))))))))))) + +(defun x86-can-emulate-instruction (instruction) + (let* ((mnemonic (x86-di-mnemonic instruction)) + (op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when (and op0 op1 (not op2) + (typep op0 'x86::x86-register-operand) + (typep op1 'x86::x86-memory-operand) + (member mnemonic '("movb" "movw" "movl" "movq") :test 'string=)) + (let* ((seg (x86::x86-memory-operand-seg op1)) + (base (x86::x86-memory-operand-base op1)) + (index (x86::x86-memory-operand-index op1))) + (and base index (not seg)))))) Index: /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c =================================================================== --- /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c (revision 13042) +++ /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c (revision 13043) @@ -3735,5 +3735,5 @@ size = uvector_total_size_in_bytes(noderef); - if (object_area && object_area->code != AREA_WATCHED) { + if (object_area && object_area->code == AREA_DYNAMIC) { area *a = new_watched_area(size); LispObj old = object; @@ -3748,4 +3748,5 @@ wp_update_references(tcr, old, new); check_all_areas(tcr); + return 1; } return 0; @@ -3791,8 +3792,11 @@ LispObj selector = xpGPR(xp,Iimm0); LispObj object = xpGPR(xp, Iarg_z); + signed_natural result; switch (selector) { case WATCH_TRAP_FUNCTION_WATCH: - gc_like_from_xp(xp, watch_object, object); + result = gc_like_from_xp(xp, watch_object, object); + if (result == 0) + xpGPR(xp,Iarg_z) = lisp_nil; break; case WATCH_TRAP_FUNCTION_UNWATCH: