Changeset 13043

Timestamp:

Oct 19, 2009, 8:47:26 AM (15 years ago)

Author:

gz

Message:

More WATCH updates from trunk (r13011-r13019, r13022, r13028)

Location:

branches/working-0711/ccl

Files:

• compiler/X86/x86-disassemble.lisp (modified) (3 diffs)
• level-1/l1-error-system.lisp (modified) (2 diffs)
• level-1/x86-trap-support.lisp (modified) (1 diff)
• lib/compile-ccl.lisp (modified) (1 diff)
• lib/misc.lisp (modified) (2 diffs)
• lib/systems.lisp (modified) (1 diff)
• lib/x86-watch.lisp (copied) (copied from trunk/source/lib/x86-watch.lisp )
• lisp-kernel/x86-exceptions.c (modified) (3 diffs)

branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

@@ -36 +36 @@
 (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 +2774 @@
       (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 +2793 @@
       (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)))

branches/working-0711/ccl/level-1/l1-error-system.lisp

@@ -109 +109 @@
    (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 +141 @@
                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)

branches/working-0711/ccl/level-1/x86-trap-support.lisp

@@ -445 +445 @@
                                          :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)

branches/working-0711/ccl/lib/compile-ccl.lisp

@@ -175 +175 @@
           (case target
             ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
-            ((:x8632 :x8664) '(x86-backtrace x86-disassemble)))))
+            ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch)))))
           
 

branches/working-0711/ccl/lib/misc.lisp

@@ -1057 +1057 @@
       (%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 +1084 @@
                         (return-from unwatch (%unwatch thing new)))))
                 area-watched area-watched)))
-      

branches/working-0711/ccl/lib/systems.lisp

@@ -161 +161 @@
     (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"))

branches/working-0711/ccl/lisp-kernel/x86-exceptions.c

@@ -3735 +3735 @@
     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 +3748 @@
     wp_update_references(tcr, old, new);
     check_all_areas(tcr);
+    return 1;
   }
   return 0;
@@ -3791 +3792 @@
   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: