From: Richard M Kreuter Date: Thu, 3 Jul 2008 19:24:49 +0000 (+0000) Subject: 1.0.18.10: Record filenames in DEBUG-SOURCEs during EVAL-WHEN, LOAD. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f22ad70037030c07074327cf239bd84dc17b44b6;p=sbcl.git 1.0.18.10: Record filenames in DEBUG-SOURCEs during EVAL-WHEN, LOAD. * During EVAL-WHEN (:COMPILE-TOPLEVEL) and LOAD, record both the filename and the S-expression in the DEBUG-SOURCE. * Change clients of the DEBUG-SOURCE structure to use the new slots. (This also affects SLIME.) --- diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 5a36bf4..45b1784 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -353,8 +353,14 @@ If an unsupported TYPE is requested, the function will return NIL. (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) (make-definition-source :pathname - (if (eql (sb-c::debug-source-from debug-source) :file) - (parse-namestring (sb-c::debug-source-name debug-source))) + ;; KLUDGE: at the moment, we don't record the correct toplevel + ;; form number for forms processed by EVAL (including EVAL-WHEN + ;; :COMPILE-TOPLEVEL). Until that's fixed, don't return a + ;; DEFINITION-SOURCE with a pathname. (When that's fixed, take + ;; out the (not (debug-source-form ...)) test. + (if (and (sb-c::debug-source-namestring debug-source) + (not (sb-c::debug-source-form debug-source))) + (parse-namestring (sb-c::debug-source-namestring debug-source))) :character-offset (if tlf (elt (sb-c::debug-source-start-positions debug-source) tlf)) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1f0f388..9174aca 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -408,12 +408,12 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." :doc "private: primitives used to write debuggers" :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL" "SB!SYS" "SB!VM") :import-from (("SB!C" - "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME" + "DEBUG-SOURCE-FORM" "DEBUG-SOURCE-NAMESTRING" "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-START-POSITIONS" "MAKE-DEBUG-SOURCE" "DEBUG-SOURCE" "DEBUG-SOURCE-P")) - :reexport ("DEBUG-SOURCE-FROM" - "DEBUG-SOURCE-NAME" + :reexport ("DEBUG-SOURCE-FORM" + "DEBUG-SOURCE-NAMESTRING" "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-COMPILED" "DEBUG-SOURCE-START-POSITIONS" "DEBUG-SOURCE" "DEBUG-SOURCE-P") diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index cab930c..2e02456 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -238,29 +238,36 @@ ;;; There is one per compiled file and one per function compiled at ;;; toplevel or loaded from source. (def!struct (debug-source #-sb-xc-host (:pure t)) - ;; This slot indicates where the definition came from: - ;; :FILE - from a file (i.e. COMPILE-FILE) - ;; :LISP - from Lisp (i.e. COMPILE) - (from (missing-arg) :type (member :file :lisp)) - ;; If :FILE, the file name, if :LISP or :STREAM, then a vector of - ;; the top level forms. When from COMPILE, form 0 is #'(LAMBDA ...). - (name nil) + ;; (This is one of those structures where IWBNI we had multiple + ;; inheritance. The first four slots describe compilation of a + ;; file, the fifth and sixth compilation of a form processed by + ;; EVAL, and the seventh and eigth all compilation units; and these + ;; are orthogonal concerns that can combine independently.) + + ;; When the DEBUG-SOURCE describes a file, the file's namestring. + ;; Otherwise, NIL. + (namestring nil :type (or null string)) ;; the universal time that the source was written, or NIL if ;; unavailable (created nil :type (or unsigned-byte null)) - ;; the universal time that the source was compiled - (compiled (missing-arg) :type unsigned-byte) ;; the source path root number of the first form read from this ;; source (i.e. the total number of forms converted previously in - ;; this compilation) + ;; this compilation). (Note: this will always be 0 so long as the + ;; SOURCE-INFO structure has exactly one FILE-INFO.) (source-root 0 :type index) ;; The FILE-POSITIONs of the truly top level forms read from this ;; file (if applicable). The vector element type will be chosen to - ;; hold the largest element. May be null to save space, or if - ;; :DEBUG-SOURCE-FORM is :LISP. + ;; hold the largest element. (start-positions nil :type (or (simple-array * (*)) null)) - ;; If from :LISP, this is the function whose source is form 0. + + ;; For functions processed by EVAL (including EVAL-WHEN and LOAD on + ;; a source file), the source form. + (form nil :type list) + ;; This is the function whose source is the form. (function nil) + + ;; the universal time that the source was compiled + (compiled (missing-arg) :type unsigned-byte) ;; Additional information from (WITH-COMPILATION-UNIT (:SOURCE-PLIST ...)) (plist *source-plist*)) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index c7f6d58..ecbf3e8 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -1271,9 +1271,12 @@ reset to ~S." (values *cached-form-number-translations* *cached-toplevel-form*) (let* ((offset (sb!di:code-location-toplevel-form-offset location)) (res - (ecase (sb!di:debug-source-from d-source) - (:file (get-file-toplevel-form location)) - (:lisp (svref (sb!di:debug-source-name d-source) offset))))) + (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)) @@ -1291,7 +1294,7 @@ reset to ~S." (aref (or (sb!di:debug-source-start-positions d-source) (error "no start positions map")) local-tlf-offset)) - (name (sb!di:debug-source-name d-source))) + (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*) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 79de2f8..47a8af2 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -161,12 +161,14 @@ ;; any nondefault options. (format-universal-time nil (sb-c::debug-source-compiled source) :style :abbreviated)) - (let ((name (sb-c::debug-source-name source))) - (ecase (sb-c::debug-source-from source) - (:file - (format s "~&~A~@:_ Created: " (namestring name)) - (format-universal-time s (sb-c::debug-source-created source))) - (:lisp (format s "~& ~S" (aref name 0)))))))))) + (let ((name (sb-c::debug-source-namestring source))) + (cond (name + (format s "~&~A~@:_ Created: " name) + (format-universal-time s (sb-c::debug-source-created source))) + ((sb-di:debug-source-form source) + (format s "~& ~S" (sb-di:debug-source-form source))) + (t (bug "Don't know how to use a DEBUG-SOURCE without ~ + a namestring or a form."))))))))) ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index b20c4e4..219aba0 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -27,18 +27,32 @@ ;;;; LOAD-AS-SOURCE -;;; Load a text file. (Note that load-as-fasl is in another file.) +;;; Load a text stream. (Note that load-as-fasl is in another file.) (defun load-as-source (stream verbose print) (maybe-announce-load stream verbose) - (do ((sexpr (read stream nil *eof-object*) - (read stream nil *eof-object*))) - ((eq sexpr *eof-object*) - t) - (if print - (let ((results (multiple-value-list (eval sexpr)))) - (load-fresh-line) - (format t "~{~S~^, ~}~%" results)) - (eval sexpr)))) + (macrolet ((do-sexprs ((sexpr stream) &body body) + (aver (symbolp sexpr)) + (with-unique-names (source-info) + (once-only ((stream stream)) + `(if (handler-case (pathname stream) + (error () nil)) + (let ((,source-info (sb!c::make-file-source-info + (pathname ,stream) + (stream-external-format ,stream)))) + (setf (sb!c::source-info-stream ,source-info) ,stream) + (sb!c::do-forms-from-info ((,sexpr) ,source-info) + ,@body)) + (do ((,sexpr (read ,stream nil *eof-object*) + (read ,stream nil *eof-object*))) + ((eq ,sexpr *eof-object*)) + ,@body)))))) + (do-sexprs (sexpr stream) + (if print + (let ((results (multiple-value-list (eval sexpr)))) + (load-fresh-line) + (format t "~{~S~^, ~}~%" results)) + (eval sexpr))) + t)) ;;;; LOAD itself diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index feb1cf5..0f65c71 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -17,6 +17,13 @@ ;;;; function names and documentation ;;;; the ANSI interface to function names (and to other stuff too) +;;; Note: this function gets called by the compiler (as of 1.0.17.x, +;;; in MAYBE-INLINE-SYNTACTIC-CLOSURE), and so although ANSI says +;;; we're allowed to return NIL here freely, it seems plausible that +;;; small changes to the circumstances under which this function +;;; returns non-NIL might have subtle consequences on the compiler. +;;; So it might be desirable to have the compiler not rely on this +;;; function, eventually. (defun function-lambda-expression (fun) "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument @@ -39,9 +46,9 @@ (info (sb!kernel:%code-debug-info code))) (if info (let ((source (sb!c::debug-info-source info))) - (cond ((and (eq (sb!c::debug-source-from source) :lisp) + (cond ((and (sb!c::debug-source-form source) (eq (sb!c::debug-source-function source) fun)) - (values (svref (sb!c::debug-source-name source) 0) + (values (sb!c::debug-source-form source) nil name)) ((legal-fun-name-p name) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index a2288b8..93dc016 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -250,25 +250,25 @@ ;;; Return DEBUG-SOURCE structure containing information derived from ;;; INFO. -(defun debug-source-for-info (info) +(defun debug-source-for-info (info &key function) (declare (type source-info info)) - (let* ((file-info (source-info-file-info info)) - (res (make-debug-source - :from :file - :created (file-info-write-date file-info) - :compiled (source-info-start-time info) - :source-root (file-info-source-root file-info) - :start-positions (coerce-to-smallest-eltype - (file-info-positions file-info)))) - (name (file-info-name file-info))) - (etypecase name - ((member :lisp) - (setf (debug-source-from res) name - (debug-source-name res) (file-info-forms file-info))) - (pathname - (setf (debug-source-name res) - (make-file-info-namestring name file-info)))) - res)) + (let ((file-info (get-toplevelish-file-info info))) + (make-debug-source + :compiled (source-info-start-time info) + + :namestring (make-file-info-namestring + (if (pathnamep (file-info-name file-info)) + (file-info-name file-info)) + file-info) + :created (file-info-write-date file-info) + :source-root (file-info-source-root file-info) + :start-positions (coerce-to-smallest-eltype + (file-info-positions file-info)) + + :form (let ((direct-file-info (source-info-file-info info))) + (if (eq :lisp (file-info-name direct-file-info)) + (elt (file-info-forms direct-file-info) 0))) + :function function))) ;;; Given an arbitrary sequence, coerce it to an unsigned vector if ;;; possible. Ordinarily we coerce it to the smallest specialized diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index c5d9411..8488eee 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -98,8 +98,7 @@ (declare (type core-object object) (type (or null function) function)) (aver (zerop (hash-table-count (core-object-patch-table object)))) - (let ((source (debug-source-for-info info))) - (setf (debug-source-function source) function) + (let ((source (debug-source-for-info info :function function))) (dolist (info (core-object-debug-info object)) (setf (debug-info-source info) source))) (setf (core-object-debug-info object) nil) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 576b188..6a75cf0 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -720,10 +720,15 @@ ;;; A FILE-INFO structure holds all the source information for a ;;; given file. -(def!struct (file-info (:copier nil)) +(def!struct (file-info + (:copier nil) + #-no-ansi-print-object + (:print-object (lambda (s stream) + (print-unreadable-object (s stream :type t) + (princ (file-info-name s) stream))))) ;; If a file, the truename of the corresponding source file. If from ;; a Lisp form, :LISP. If from a stream, :STREAM. - (name (missing-arg) :type (or pathname (member :lisp :stream))) + (name (missing-arg) :type (or pathname (eql :lisp))) ;; the external format that we'll call OPEN with, if NAME is a file. (external-format nil) ;; the defaulted, but not necessarily absolute file name (i.e. prior @@ -756,29 +761,39 @@ (file-info nil :type (or file-info null)) ;; the stream that we are using to read the FILE-INFO, or NIL if ;; no stream has been opened yet - (stream nil :type (or stream null))) + (stream nil :type (or stream null)) + ;; if the current compilation is recursive (e.g., due to EVAL-WHEN + ;; processing at compile-time), the invoking compilation's + ;; source-info. + (parent nil :type (or source-info null))) ;;; Given a pathname, return a SOURCE-INFO structure. (defun make-file-source-info (file external-format) - (let ((file-info (make-file-info :name (truename file) - :untruename (merge-pathnames file) - :external-format external-format - :write-date (file-write-date file)))) - - (make-source-info :file-info file-info))) + (make-source-info + :file-info (make-file-info :name (truename file) + :untruename (merge-pathnames file) + :external-format external-format + :write-date (file-write-date file)))) ;;; Return a SOURCE-INFO to describe the incremental compilation of FORM. -(defun make-lisp-source-info (form) - (make-source-info :start-time (get-universal-time) - :file-info (make-file-info :name :lisp - :forms (vector form) - :positions '#(0)))) - -;;; Return a SOURCE-INFO which will read from STREAM. -(defun make-stream-source-info (stream) - (let ((file-info (make-file-info :name :stream))) - (make-source-info :file-info file-info - :stream stream))) +(defun make-lisp-source-info (form &key parent) + (make-source-info + :file-info (make-file-info :name :lisp + :forms (vector form) + :positions '#(0)) + :parent parent)) + +;;; Walk up the SOURCE-INFO list until we either reach a SOURCE-INFO +;;; with no parent (e.g., from a REPL evaluation) or until we reach a +;;; SOURCE-INFO whose FILE-INFO denotes a file. +(defun get-toplevelish-file-info (&optional (source-info *source-info*)) + (if source-info + (do* ((sinfo source-info (source-info-parent sinfo)) + (finfo (source-info-file-info sinfo) + (source-info-file-info sinfo))) + ((or (not (source-info-p (source-info-parent sinfo))) + (pathnamep (file-info-name finfo))) + finfo)))) ;;; Return a form read from STREAM; or for EOF use the trick, ;;; popularized by Kent Pitman, of returning STREAM itself. If an @@ -835,24 +850,37 @@ (setf (source-info-stream info) nil) (values)) +;;; Loop over FORMS retrieved from INFO. Used by COMPILE-FILE and +;;; LOAD when loading from a FILE-STREAM associated with a source +;;; file. +(defmacro do-forms-from-info (((form &rest keys) info) + &body body) + (aver (symbolp form)) + (once-only ((info info)) + `(let ((*source-info* ,info)) + (loop (destructuring-bind (,form &key ,@keys &allow-other-keys) + (let* ((file-info (source-info-file-info ,info)) + (stream (get-source-stream ,info)) + (pos (file-position stream)) + (form (read-for-compile-file stream pos))) + (if (eq form stream) ; i.e., if EOF + (return) + (let* ((forms (file-info-forms file-info)) + (current-idx (+ (fill-pointer forms) + (file-info-source-root + file-info)))) + (vector-push-extend form forms) + (vector-push-extend pos (file-info-positions + file-info)) + (list form :current-index current-idx)))) + ,@body))))) + ;;; Read and compile the source file. (defun sub-sub-compile-file (info) - (let* ((file-info (source-info-file-info info)) - (stream (get-source-stream info))) - (loop - (let* ((pos (file-position stream)) - (form (read-for-compile-file stream pos))) - (if (eq form stream) ; i.e., if EOF - (return) - (let* ((forms (file-info-forms file-info)) - (current-idx (+ (fill-pointer forms) - (file-info-source-root file-info)))) - (vector-push-extend form forms) - (vector-push-extend pos (file-info-positions file-info)) - (find-source-paths form current-idx) - (process-toplevel-form form - `(original-source-start 0 ,current-idx) - nil))))))) + (do-forms-from-info ((form current-index) info) + (find-source-paths form current-index) + (process-toplevel-form + form `(original-source-start 0 ,current-index) nil))) ;;; Return the INDEX'th source form read from INFO and the position ;;; where it was read. @@ -1496,7 +1524,6 @@ (*disabled-package-locks* *disabled-package-locks*) (*lexenv* (make-null-lexenv)) (*block-compile* *block-compile-arg*) - (*source-info* info) (*toplevel-lambdas* ()) (*fun-names-in-this-file* ()) (*allow-instrumenting* nil) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index fb27f29..49400c5 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -371,9 +371,6 @@ ;; on me (e.g. by using me as *CURRENT-COMPONENT*, or by pushing ;; LAMBDAs onto my NEW-FUNCTIONALS, as in sbcl-0.pre7.115). (info :no-ir2-yet :type (or ir2-component (member :no-ir2-yet :dead))) - ;; the SOURCE-INFO structure describing where this component was - ;; compiled from - (source-info *source-info* :type source-info) ;; count of the number of inline expansions we have done while ;; compiling this component, to detect infinite or exponential ;; blowups diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index ae62e1a..1c3d4b2 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -947,12 +947,15 @@ (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) - (let ((name (sb!di:debug-source-name debug-source))) - (ecase (sb!di:debug-source-from debug-source) - (:file - (cond ((not (probe-file name)) - (warn "The source file ~S no longer seems to exist." name) + (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 @@ -967,15 +970,15 @@ debug-source))) (char-offset (aref start-positions local-tlf-index))) - (with-open-file (f name) + (with-open-file (f namestring) (cond ((= (sb!di:debug-source-created debug-source) - (file-write-date name)) + (file-write-date namestring)) (file-position f char-offset)) (t (warn "Source file ~S has been modified; ~@ using form offset instead of ~ file index." - name) + namestring) (let ((*read-suppress* t)) (dotimes (i local-tlf-index) (read f))))) (let ((*readtable* (copy-readtable))) @@ -985,10 +988,11 @@ (declare (ignore rest sub-char)) (let ((token (read stream t nil t))) (format nil "#.~S" token)))) - (read f)) - )))))))) - (:lisp - (aref name tlf-index))))) + (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 diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 51c34c6..aa011e1 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -45,7 +45,7 @@ ;; need *BACKEND-INFO-ENVIRONMENT*. (*info-environment* *info-environment*) (form (get-lambda-to-compile definition)) - (*source-info* (make-lisp-source-info form)) + (*source-info* (make-lisp-source-info form :parent *source-info*)) (*toplevel-lambdas* ()) (*block-compile* nil) (*allow-instrumenting* nil) diff --git a/version.lisp-expr b/version.lisp-expr index 6257d10..c4c1bc4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.18.9" +"1.0.18.10"