teach debugger about &MORE arguments

  LIST-LOCALS displays SB-DEBUG::MORE = (...list of more args...)
  in addition to the more-context and count.

  EVAL-IN-FRAME bindss SB-DEBUG::MORE when appropriate.

diff --git a/NEWS b/NEWS
index 1df6936..8f6c15c 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,7 @@ changes relative to sbcl-1.0.49:
   * enhancement: constraint propagation is simplified (and sped up) when
     COMPILATION-SPEED > SPEED.
   * enhancement: SB-ALIEN exports alien type specifiers SIZE-T and OFF-T.
+  * enhancement: debugger understands &MORE arguments better.
   * optimization: extracting bits of a single-float on x86-64 has been
     optimized. (lp#555201)
   * optimization: MAP and MAP-INTO are more efficient for non-simple vectors,

diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp
index bc09934..82ebf9d 100644 (file)
--- a/src/code/debug-info.lisp
+++ b/src/code/debug-info.lisp
@@ -32,9 +32,8 @@
 ;;;    SC-Offset of primary location (as var-length integer)
 ;;;    [If has save SC, SC-OFFSET of save location (as var-length integer)]
 
-;;; FIXME: The first two are no longer used in SBCL.
-;;;(defconstant compiled-debug-var-uninterned           #b00000001)
-;;;(defconstant compiled-debug-var-packaged             #b00000010)
+(def!constant compiled-debug-var-more-context-p         #b00000001)
+(def!constant compiled-debug-var-more-count-p           #b00000010)
 (def!constant compiled-debug-var-environment-live       #b00000100)
 (def!constant compiled-debug-var-save-loc-p             #b00001000)
 (def!constant compiled-debug-var-id-p                   #b00010000)

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 9b973c0..f0e34f8 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -205,12 +205,13 @@
 (defstruct (compiled-debug-var
             (:include debug-var)
             (:constructor make-compiled-debug-var
-                          (symbol id alive-p sc-offset save-sc-offset))
+                (symbol id alive-p sc-offset save-sc-offset info))
             (:copier nil))
   ;; storage class and offset (unexported)
   (sc-offset nil :type sb!c:sc-offset)
   ;; storage class and offset when saved somewhere
-  (save-sc-offset nil :type (or sb!c:sc-offset null)))
+  (save-sc-offset nil :type (or sb!c:sc-offset null))
+  (info nil))
 
 ;;;; frames
 
@@ -1636,6 +1637,8 @@ register."
           (let* ((flags (geti))
                  (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
                  (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
+                 (more-context-p (logtest sb!c::compiled-debug-var-more-context-p flags))
+                 (more-count-p (logtest sb!c::compiled-debug-var-more-count-p flags))
                  (live (logtest sb!c::compiled-debug-var-environment-live
                                 flags))
                  (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
@@ -1650,7 +1653,9 @@ register."
                                                          id
                                                          live
                                                          sc-offset
-                                                         save-sc-offset)
+                                                         save-sc-offset
+                                                         (cond (more-context-p :more-context)
+                                                               (more-count-p :more-count)))
                                 buffer)))))))
 \f
 ;;;; CODE-LOCATIONs
@@ -2374,12 +2379,10 @@ register."
 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
 ;;; live-set information has been cached in the code-location.
 (defun debug-var-validity (debug-var basic-code-location)
-  (etypecase debug-var
-    (compiled-debug-var
-     (compiled-debug-var-validity debug-var basic-code-location))
-    ;; (There used to be more cases back before sbcl-0.7.0, when
-    ;; we did special tricks to debug the IR1 interpreter.)
-    ))
+  (compiled-debug-var-validity debug-var basic-code-location))
+
+(defun debug-var-info (debug-var)
+  (compiled-debug-var-info debug-var))
 
 ;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
 ;;; For safety, make sure basic-code-location is what we think.
@@ -2514,7 +2517,9 @@ register."
 (defun preprocess-for-eval (form loc)
   (declare (type code-location loc))
   (let ((n-frame (gensym))
-        (fun (code-location-debug-fun loc)))
+        (fun (code-location-debug-fun loc))
+        (more-context nil)
+        (more-count nil))
     (unless (debug-var-info-available fun)
       (debug-signal 'no-debug-vars :debug-fun fun))
     (sb!int:collect ((binds)
@@ -2522,17 +2527,33 @@ register."
       (do-debug-fun-vars (var fun)
         (let ((validity (debug-var-validity var loc)))
           (unless (eq validity :invalid)
+            (case (debug-var-info var)
+              (:more-context
+               (setf more-context var))
+              (:more-count
+               (setf more-count var)))
             (let* ((sym (debug-var-symbol var))
                    (found (assoc sym (binds))))
               (if found
                   (setf (second found) :ambiguous)
                   (binds (list sym validity var)))))))
+      (when (and more-context more-count)
+        (let ((more (assoc 'sb!debug::more (binds))))
+          (if more
+              (setf (second more) :ambiguous)
+              (binds (list 'sb!debug::more :more more-context more-count)))))
       (dolist (bind (binds))
         (let ((name (first bind))
               (var (third bind)))
           (ecase (second bind)
             (:valid
              (specs `(,name (debug-var-value ',var ,n-frame))))
+            (:more
+             (let ((count-var (fourth bind)))
+               (specs `(,name (multiple-value-list
+                               (sb!c:%more-arg-values (debug-var-value ',var ,n-frame)
+                                                      0
+                                                      (debug-var-value ',count-var ,n-frame)))))))
             (:unknown
              (specs `(,name (debug-signal 'invalid-value
                                           :debug-var ',var

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index deb0be9..5a5b0f3 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -1267,19 +1267,29 @@ and LDB (the low-level debugger).  See also ENABLE-DEBUGGER."
               (location (sb!di:frame-code-location *current-frame*))
               (prefix (read-if-available nil))
               (any-p nil)
-              (any-valid-p nil))
+              (any-valid-p nil)
+              (more-context nil)
+              (more-count nil))
           (dolist (v (sb!di:ambiguous-debug-vars
-                        d-fun
-                        (if prefix (string prefix) "")))
+                      d-fun
+                      (if prefix (string prefix) "")))
             (setf any-p t)
             (when (eq (sb!di:debug-var-validity v location) :valid)
               (setf any-valid-p t)
+              (case (sb!di::debug-var-info v)
+                (:more-context
+                 (setf more-context (sb!di:debug-var-value v *current-frame*)))
+                (:more-count
+                 (setf more-count (sb!di:debug-var-value v *current-frame*))))
               (format *debug-io* "~S~:[#~W~;~*~]  =  ~S~%"
                       (sb!di:debug-var-symbol v)
                       (zerop (sb!di:debug-var-id v))
                       (sb!di:debug-var-id v)
                       (sb!di:debug-var-value v *current-frame*))))
-
+          (when (and more-context more-count)
+            (format *debug-io* "~S  =  ~S~%"
+                    'more
+                    (multiple-value-list (sb!c:%more-arg-values more-context 0 more-count))))
           (cond
            ((not any-p)
             (format *debug-io*

diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index 6633b3f..2b3d604 100644 (file)
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -352,7 +352,8 @@
   (let* ((name (leaf-debug-name var))
          (save-tn (and tn (tn-save-tn tn)))
          (kind (and tn (tn-kind tn)))
-         (flags 0))
+         (flags 0)
+         (info (lambda-var-arg-info var)))
     (declare (type index flags))
     (when minimal
       (setq flags (logior flags compiled-debug-var-minimal-p))
@@ -369,6 +370,12 @@
       (setq flags (logior flags compiled-debug-var-save-loc-p)))
     (unless (or (zerop id) minimal)
       (setq flags (logior flags compiled-debug-var-id-p)))
+    (when info
+      (case (arg-info-kind info)
+        (:more-context
+         (setq flags (logior flags compiled-debug-var-more-context-p)))
+        (:more-count
+         (setq flags (logior flags compiled-debug-var-more-count-p)))))
     (vector-push-extend flags buffer)
     (unless minimal
       (vector-push-extend name buffer)