Changeset 12885

Timestamp:

Sep 26, 2009, 8:39:26 PM (15 years ago)

Author:

R. Matthew Emerson

Message:

Support watching individual cons cells.

Location:

branches/watchpoints

Files:

• level-0/X86/x86-utils.lisp (modified) (1 diff)
• level-1/x86-trap-support.lisp (modified) (2 diffs)
• lib/misc.lisp (modified) (2 diffs)
• lisp-kernel/x86-exceptions.c (modified) (5 diffs)

branches/watchpoints/level-0/X86/x86-utils.lisp

@@ -445 +445 @@
   (jmp-subprim .SPmakeu64))
 
-(defx86lapfunction %watch ((uvector arg_z))
+(defx86lapfunction %watch ((thing arg_z))
   (check-nargs 1)
-  ;; This traps on symbols and functions, which have their own tags.
-  ;; This may be undesirable.
-  (trap-unless-lisptag= uvector x8664::tag-misc imm0)
   (movl ($ arch::watch-trap-function-watch) (%l imm0))
   (uuo-watch-trap)

branches/watchpoints/level-1/x86-trap-support.lisp

@@ -441 +441 @@
                                          :object object)
                                         nil frame-ptr)
-                  (unwatch ()
-                    :report (lambda (s)
-                              (format s "Unwatch ~s and perform the write." object))
-                    (unwatch (%int-to-object other)))))))))
+                    (unwatch ()
+                      :report (lambda (s)
+                                (format s "Unwatch ~s and perform the write." object))
+                      (unwatch object))))))))
           ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
            (if (= code -1)
@@ -456 +456 @@
                      frame-ptr)))))
   0)
-
-#||
-(defun analyze-faulting-instruction (xp)
-  (let* ((ds (make-x86-disassembly-state
-              :mode-64 #+x8664-target t #+x8632-target nil))
-         (insn (make-x86-disassembled-instruction
-                :address (indexed-gpr-integer xp rip-register-offset)
-||#

branches/watchpoints/lib/misc.lisp

@@ -1046 +1046 @@
 (defun watch (&optional thing)
   (if thing
-    ;; typecheck thing?
-    (%watch thing)
+    (progn
+      (require-type thing '(or cons (satisfies uvectorp)))
+      (%watch thing))
     (let (result)
       (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
@@ -1059 +1060 @@
                     ;; list while %map-areas iterates over it, but I
                     ;; think we'll get away with it.
-                    (let ((new (%alloc-misc (uvsize thing) (typecode thing))))
+                    (let ((new (if (uvectorp thing)
+                                 (%alloc-misc (uvsize thing) (typecode thing))
+                                 (cons nil nil))))
                       (return-from unwatch (%unwatch thing new)))))
               area-watched area-watched))

branches/watchpoints/lisp-kernel/x86-exceptions.c

@@ -827 +827 @@
       if (a && a->code == AREA_WATCHED && addr < a->high) {
         /* caught a write to a watched object */
+        LispObj *p = (LispObj *)a->low;
+        LispObj node = *p;
+        unsigned tag_n = fulltag_of(node);
         LispObj cmain = nrs_CMAIN.vcell;
-        LispObj obj = (LispObj)a->low + fulltag_misc; /* always uvectors */
+        LispObj obj;
+
+        if (immheader_tag_p(tag_n) || nodeheader_tag_p(tag_n))
+          obj = (LispObj)p + fulltag_misc;
+        else
+          obj = (LispObj)p + fulltag_cons;
 
         if ((fulltag_of(cmain) == fulltag_misc) &&
@@ -3706 +3714 @@
  * Other threads are suspended and pc-lusered.
  *
- * param contains a tagged pointer to a uvector.
+ * param contains a tagged pointer to a uvector or a cons cell
  */
 signed_natural
 watch_object(TCR *tcr, signed_natural param)
 {
-  LispObj uvector = (LispObj)param;
-  LispObj *noderef = (LispObj *)untag(uvector);
-  natural size = uvector_total_size_in_bytes(noderef);
-  area *uvector_area = area_containing((BytePtr)noderef);
-
-  if (uvector_area && uvector_area->code != AREA_WATCHED) {
+  LispObj object = (LispObj)param;
+  unsigned tag = fulltag_of(object);
+  LispObj *noderef = (LispObj *)untag(object);
+  area *object_area = area_containing((BytePtr)noderef);
+  natural size;
+
+  if (tag == fulltag_cons)
+    size = 2 * node_size;
+  else
+    size = uvector_total_size_in_bytes(noderef);
+
+  if (object_area && object_area->code != AREA_WATCHED) {
     area *a = new_watched_area(size);
-    LispObj old = uvector;
-    LispObj new = (LispObj)((natural)a->low + fulltag_misc);
+    LispObj old = object;
+    LispObj new = (LispObj)((natural)a->low + tag);
 
     add_area_holding_area_lock(a);
@@ -3742 +3756 @@
   ExceptionInformation *xp = tcr->xframe->curr;
   LispObj old = xpGPR(xp, Iarg_y);
+  unsigned tag = fulltag_of(old);
   LispObj new = xpGPR(xp, Iarg_z);
   LispObj *oldnode = (LispObj *)untag(old);
@@ -3748 +3763 @@
 
   if (a && a->code == AREA_WATCHED) {
-    natural size = uvector_total_size_in_bytes(oldnode);
+    natural size;
+
+    if (tag == fulltag_cons)
+      size = 2 * node_size;
+    else
+      size = uvector_total_size_in_bytes(oldnode);
 
     memcpy(newnode, oldnode, size);
@@ -3765 +3785 @@
 {
   LispObj selector = xpGPR(xp,Iimm0);
-  LispObj uvector = xpGPR(xp, Iarg_z);
+  LispObj object = xpGPR(xp, Iarg_z);
   
   switch (selector) {
     case WATCH_TRAP_FUNCTION_WATCH:
-      gc_like_from_xp(xp, watch_object, uvector);
+      gc_like_from_xp(xp, watch_object, object);
       break;
     case WATCH_TRAP_FUNCTION_UNWATCH: