Changeset 12888

Timestamp:

Sep 28, 2009, 7:31:03 AM (15 years ago)

Author:

R. Matthew Emerson

Message:

Support watching individual cons cells; add "unwatch and contiune" restart.
(r12874 through r12887 from watchpoints branch)

Location:

trunk/source

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) (6 diffs)

trunk/source/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)

trunk/source/level-1/x86-trap-support.lisp

@@ -435 +435 @@
                          (setf (%get-ptr a) (%int-to-ptr i))
                          (%get-object a 0))))
-                (%error (make-condition
-                         'write-to-watched-object
-                         :address addr
-                         :object (%int-to-object other))
-                        nil frame-ptr)))))
+                (let ((object (%int-to-object other)))
+                  (restart-case (%error (make-condition
+                                         'write-to-watched-object
+                                         :address addr
+                                         :object object)
+                                        nil frame-ptr)
+                    (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)
@@ -451 +456 @@
                      frame-ptr)))))
   0)
-

trunk/source/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))

trunk/source/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) &&
             (header_subtag(header_of(cmain)) == subtag_macptr)) {
+          LispObj save_vsp = xpGPR(xp, Isp);
+          LispObj save_fp = xpGPR(xp, Ifp);
           LispObj xcf = create_exception_callback_frame(xp, tcr);
           int skip;
@@ -838 +848 @@
           skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, (natural) addr, obj);
           xpPC(xp) += skip;
+          xpGPR(xp, Ifp) = save_fp;
+          xpGPR(xp, Isp) = save_vsp;
           return true;
         }
@@ -3702 +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);
@@ -3738 +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);
@@ -3744 +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);
@@ -3761 +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: