refactor GET-TOPLEVEL-FORM &co between debugger and disassembler

  * Merge the implementations in debug.lisp and target-disassembler.lisp.

  * Get rid of most of the cacheing.

  * Prefer the DEBUG-SOURCE-FORM if it exists: thanks to *SOURCE-NAMESTRING*
    we can have misleading namestrings for functions generated by calls to
    EVAL during LOAD, etc.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index a52925b..cd95792 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -464,6 +464,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "FRAME" "FRAME-CATCHES" "FRAME-CODE-LOCATION"
                "FRAME-DEBUG-FUN" "FRAME-DOWN"
                "FRAME-FUN-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP"
+               "GET-TOPLEVEL-FORM"
                "REPLACE-FRAME-CATCH-TAG"
                "FUN-DEBUG-FUN" "FUN-END-COOKIE-VALID-P"
                "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE"

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index df06188..fc38784 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -2525,6 +2525,70 @@ register."
                        (nconc (subseq form 0 n)
                               (cons res (nthcdr (1+ n) form))))))))
       (frob form path context))))
+
+;;; Given a code location, return the associated form-number
+;;; translations and the actual top level form.
+(defun get-toplevel-form (location)
+  (let ((d-source (code-location-debug-source location)))
+    (let* ((offset (code-location-toplevel-form-offset location))
+           (res
+             (cond ((debug-source-form d-source)
+                    (debug-source-form d-source))
+                   ((debug-source-namestring d-source)
+                    (get-file-toplevel-form location))
+                   (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+                               a namestring or a form.")))))
+      (values (form-number-translations res offset) res))))
+
+;;; To suppress the read-time evaluation #. macro during source read,
+;;; *READTABLE* is modified.
+;;;
+;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which
+;;; this code can use for side- effect free #. calls?
+;;;
+;;; FIXME: This also knows nothing of custom readtables. The assumption
+;;; is that the current readtable is a decent approximation for what
+;;; we want, but that's lossy.
+(defun safe-readtable ()
+  (let ((rt (copy-readtable)))
+    (set-dispatch-macro-character
+     #\# #\. (lambda (stream sub-char &rest rest)
+               (declare (ignore rest sub-char))
+               (let ((token (read stream t nil t)))
+                 (format nil "#.~S" token)))
+     rt)
+    rt))
+
+;;; Locate the source file (if it still exists) and grab the top level
+;;; form. If the file is modified, we use the top level form offset
+;;; instead of the recorded character offset.
+(defun get-file-toplevel-form (location)
+  (let* ((d-source (code-location-debug-source location))
+         (tlf-offset (code-location-toplevel-form-offset location))
+         (local-tlf-offset (- tlf-offset
+                              (debug-source-root-number d-source)))
+         (char-offset
+          (aref (or (sb!di:debug-source-start-positions d-source)
+                    (error "no start positions map"))
+                local-tlf-offset))
+         (namestring (debug-source-namestring d-source)))
+    ;; FIXME: External format?
+    (with-open-file (f namestring :if-does-not-exist nil)
+      (unless f
+        (error "The source file no longer exists:~%  ~A" namestring))
+      (format *debug-io* "~%; file: ~A~%" namestring)
+      (let ((*readtable* (safe-readtable)))
+        (cond ((eql (debug-source-created d-source) (file-write-date f))
+               (file-position f char-offset))
+              (t
+               (format *debug-io*
+                       "~%; File has been modified since compilation:~%;   ~A~@
+                          ; Using form offset instead of character position.~%"
+                       namestring)
+               (let ((*read-suppress* t))
+                 (loop repeat local-tlf-offset
+                       do (read f)))))
+        (read f)))))
 \f
 ;;;; PREPROCESS-FOR-EVAL
 

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 24f3106..69715ba 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -1346,124 +1346,25 @@ and LDB (the low-level debugger).  See also ENABLE-DEBUGGER."
 \f
 ;;;; source location printing
 
-;;; We cache a stream to the last valid file debug source so that we
-;;; won't have to repeatedly open the file.
-;;;
-;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
-;;; in the 1990s, so the benefit is negligible, less important than the
-;;; potential of extra confusion if someone changes the source during
-;;; a debug session and the change doesn't show up. And removing this
-;;; would simplify the system, which I like. -- WHN 19990903
-(defvar *cached-debug-source* nil)
-(declaim (type (or sb!di:debug-source null) *cached-debug-source*))
-(defvar *cached-source-stream* nil)
-(declaim (type (or stream null) *cached-source-stream*))
-
-;;; To suppress the read-time evaluation #. macro during source read,
-;;; *READTABLE* is modified. *READTABLE* is cached to avoid
-;;; copying it each time, and invalidated when the
-;;; *CACHED-DEBUG-SOURCE* has changed.
-(defvar *cached-readtable* nil)
-(declaim (type (or readtable null) *cached-readtable*))
-
 ;;; Stuff to clean up before saving a core
 (defun debug-deinit ()
-  (setf *cached-debug-source* nil
-        *cached-source-stream* nil
-        *cached-readtable* nil))
-
-;;; We also cache the last toplevel form that we printed a source for
-;;; so that we don't have to do repeated reads and calls to
-;;; FORM-NUMBER-TRANSLATIONS.
-(defvar *cached-toplevel-form-offset* nil)
-(declaim (type (or index null) *cached-toplevel-form-offset*))
-(defvar *cached-toplevel-form*)
-(defvar *cached-form-number-translations*)
-
-;;; Given a code location, return the associated form-number
-;;; translations and the actual top level form. We check our cache ---
-;;; if there is a miss, we dispatch on the kind of the debug source.
-(defun get-toplevel-form (location)
-  (let ((d-source (sb!di:code-location-debug-source location)))
-    (if (and (eq d-source *cached-debug-source*)
-             (eql (sb!di:code-location-toplevel-form-offset location)
-                  *cached-toplevel-form-offset*))
-        (values *cached-form-number-translations* *cached-toplevel-form*)
-        (let* ((offset (sb!di:code-location-toplevel-form-offset location))
-               (res
-                (cond ((sb!di:debug-source-namestring d-source)
-                       (get-file-toplevel-form location))
-                      ((sb!di:debug-source-form d-source)
-                       (sb!di:debug-source-form d-source))
-                      (t (bug "Don't know how to use a DEBUG-SOURCE without ~
-                               a namestring or a form.")))))
-          (setq *cached-toplevel-form-offset* offset)
-          (values (setq *cached-form-number-translations*
-                        (sb!di:form-number-translations res offset))
-                  (setq *cached-toplevel-form* res))))))
-
-;;; Locate the source file (if it still exists) and grab the top level
-;;; form. If the file is modified, we use the top level form offset
-;;; instead of the recorded character offset.
-(defun get-file-toplevel-form (location)
-  (let* ((d-source (sb!di:code-location-debug-source location))
-         (tlf-offset (sb!di:code-location-toplevel-form-offset location))
-         (local-tlf-offset (- tlf-offset
-                              (sb!di:debug-source-root-number d-source)))
-         (char-offset
-          (aref (or (sb!di:debug-source-start-positions d-source)
-                    (error "no start positions map"))
-                local-tlf-offset))
-         (name (sb!di:debug-source-namestring d-source)))
-    (unless (eq d-source *cached-debug-source*)
-      (unless (and *cached-source-stream*
-                   (equal (pathname *cached-source-stream*)
-                          (pathname name)))
-        (setq *cached-readtable* nil)
-        (when *cached-source-stream* (close *cached-source-stream*))
-        (setq *cached-source-stream* (open name :if-does-not-exist nil))
-        (unless *cached-source-stream*
-          (error "The source file no longer exists:~%  ~A" (namestring name)))
-        (format *debug-io* "~%; file: ~A~%" (namestring name)))
-
-        (setq *cached-debug-source*
-              (if (= (sb!di:debug-source-created d-source)
-                     (file-write-date name))
-                  d-source nil)))
-
-    (cond
-     ((eq *cached-debug-source* d-source)
-      (file-position *cached-source-stream* char-offset))
-     (t
-      (format *debug-io*
-              "~%; File has been modified since compilation:~%;   ~A~@
-                 ; Using form offset instead of character position.~%"
-              (namestring name))
-      (file-position *cached-source-stream* 0)
-      (let ((*read-suppress* t))
-        (dotimes (i local-tlf-offset)
-          (read *cached-source-stream*)))))
-    (unless *cached-readtable*
-      (setq *cached-readtable* (copy-readtable))
-      (set-dispatch-macro-character
-       #\# #\.
-       (lambda (stream sub-char &rest rest)
-         (declare (ignore rest sub-char))
-         (let ((token (read stream t nil t)))
-           (format nil "#.~S" token)))
-       *cached-readtable*))
-    (let ((*readtable* *cached-readtable*))
-      (read *cached-source-stream*))))
-
-(defun code-location-source-form (location context)
-  (let* ((location (maybe-block-start-location location))
-         (form-num (sb!di:code-location-form-number location)))
-    (multiple-value-bind (translations form) (get-toplevel-form location)
-      (unless (< form-num (length translations))
-        (error "The source path no longer exists."))
-      (sb!di:source-path-context form
-                                 (svref translations form-num)
-                                 context))))
+  ;; Nothing to do right now. Once there was, maybe once there
+  ;; will be again.
+  )
+
+(defun code-location-source-form (location context &optional (errorp t))
+  (let* ((start-location (maybe-block-start-location location))
+         (form-num (sb!di:code-location-form-number start-location)))
+    (multiple-value-bind (translations form)
+        (sb!di:get-toplevel-form start-location)
+      (cond ((< form-num (length translations))
+             (sb!di:source-path-context form
+                                        (svref translations form-num)
+                                        context))
+            (t
+             (funcall (if errorp #'error #'warn)
+                      "~@<Bogus form-number: the source file has ~
+                          probably changed too much to cope with.~:@>"))))))
 \f
 
 ;;; start single-stepping

diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 2ba6998..96065f6 100644 (file)
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -985,110 +985,30 @@
                               (:copier nil))
   (debug-source nil :type (or null sb!di:debug-source))
   (toplevel-form-index -1 :type fixnum)
-  (toplevel-form nil :type list)
-  (form-number-mapping-table nil :type (or null (vector list)))
   (last-location-retrieved nil :type (or null sb!di:code-location))
   (last-form-retrieved -1 :type fixnum))
 
-;;; OAOO note: this shares a lot of implementation with
-;;; SB-DEBUG::GET-FILE-TOPLEVEL-FORM.  Perhaps these should be merged
-;;; somehow.
-(defun get-toplevel-form (debug-source tlf-index)
-  (cond
-    ((sb!di:debug-source-namestring debug-source)
-     (let ((namestring (sb!di:debug-source-namestring debug-source)))
-       (cond ((not (probe-file namestring))
-              (warn "The source file ~S no longer seems to exist." namestring)
-              nil)
-             (t
-              (let ((start-positions
-                     (sb!di:debug-source-start-positions debug-source)))
-                (cond ((null start-positions)
-                       (warn "There is no start positions map.")
-                       nil)
-                      (t
-                       (let* ((local-tlf-index
-                               (- tlf-index
-                                  (sb!di:debug-source-root-number
-                                   debug-source)))
-                              (char-offset
-                               (aref start-positions local-tlf-index)))
-                         (with-open-file (f namestring)
-                           (cond ((= (sb!di:debug-source-created debug-source)
-                                     (file-write-date namestring))
-                                  (file-position f char-offset))
-                                 (t
-                                  (warn "Source file ~S has been modified; ~@
-                                         using form offset instead of ~
-                                         file index."
-                                        namestring)
-                                  (let ((*read-suppress* t))
-                                    (dotimes (i local-tlf-index) (read f)))))
-                           (let ((*readtable* (copy-readtable)))
-                             (set-dispatch-macro-character
-                              #\# #\.
-                              (lambda (stream sub-char &rest rest)
-                                (declare (ignore rest sub-char))
-                                (let ((token (read stream t nil t)))
-                                  (format nil "#.~S" token))))
-                             (read f)))))))))))
-    ((sb!di:debug-source-form debug-source)
-     (sb!di:debug-source-form debug-source))
-    (t (bug "Don't know how to use a DEBUG-SOURCE without ~
-             a namestring or a form."))))
-
-(defun cache-valid (loc cache)
-  (and cache
-       (and (eq (sb!di:code-location-debug-source loc)
-                (sfcache-debug-source cache))
-            (eq (sb!di:code-location-toplevel-form-offset loc)
-                (sfcache-toplevel-form-index cache)))))
-
-(defun get-source-form (loc context &optional cache)
-  (let* ((cache-valid (cache-valid loc cache))
-         (tlf-index (sb!di:code-location-toplevel-form-offset loc))
-         (form-number (sb!di:code-location-form-number loc))
-         (toplevel-form
-          (if cache-valid
-              (sfcache-toplevel-form cache)
-              (get-toplevel-form (sb!di:code-location-debug-source loc)
-                                  tlf-index)))
-         (mapping-table
-          (if cache-valid
-              (sfcache-form-number-mapping-table cache)
-              (sb!di:form-number-translations toplevel-form tlf-index))))
-    (when (and (not cache-valid) cache)
-      (setf (sfcache-debug-source cache) (sb!di:code-location-debug-source loc)
-            (sfcache-toplevel-form-index cache) tlf-index
-            (sfcache-toplevel-form cache) toplevel-form
-            (sfcache-form-number-mapping-table cache) mapping-table))
-    (cond ((null toplevel-form)
-           nil)
-          ((>= form-number (length mapping-table))
-           (warn "bogus form-number in form!  The source file has probably ~@
-                  been changed too much to cope with.")
-           (when cache
-             ;; Disable future warnings.
-             (setf (sfcache-toplevel-form cache) nil))
-           nil)
-          (t
-           (when cache
-             (setf (sfcache-last-location-retrieved cache) loc)
-             (setf (sfcache-last-form-retrieved cache) form-number))
-           (sb!di:source-path-context toplevel-form
-                                      (aref mapping-table form-number)
-                                      context)))))
-
 (defun get-different-source-form (loc context &optional cache)
-  (if (and (cache-valid loc cache)
-           (or (= (sb!di:code-location-form-number loc)
-                  (sfcache-last-form-retrieved cache))
-               (and (sfcache-last-location-retrieved cache)
-                    (sb!di:code-location=
-                     loc
-                     (sfcache-last-location-retrieved cache)))))
+  (if (and cache
+           (eq (sb!di:code-location-debug-source loc)
+               (sfcache-debug-source cache))
+           (eq (sb!di:code-location-toplevel-form-offset loc)
+               (sfcache-toplevel-form-index cache))
+           (or (eql (sb!di:code-location-form-number loc)
+                    (sfcache-last-form-retrieved cache))
+               (awhen (sfcache-last-location-retrieved cache)
+                 (sb!di:code-location= loc it))))
       (values nil nil)
-      (values (get-source-form loc context cache) t)))
+      (let ((form (sb!debug::code-location-source-form loc context nil)))
+        (when cache
+          (setf (sfcache-debug-source cache)
+                (sb!di:code-location-debug-source loc))
+          (setf (sfcache-toplevel-form-index cache)
+                (sb!di:code-location-toplevel-form-offset loc))
+          (setf (sfcache-last-form-retrieved cache)
+                (sb!di:code-location-form-number loc))
+          (setf (sfcache-last-location-retrieved cache)))
+        (values form t))))
 \f
 ;;;; stuff to use debugging info to augment the disassembly