From: Nikodemus Siivola Date: Sat, 4 Jun 2005 09:54:42 +0000 (+0000) Subject: 0.9.1.25: source-plist & related X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=97106bb159710a2e816bf4e72669d6a3818d08aa;p=sbcl.git 0.9.1.25: source-plist & related * add :SOURCE-PLIST option to WITH-COMPILATION-UNIT for attaching arbitrary source information to compiled code, accessible as SB-INTROSPECT:DEFINITION-SOURCE-PLIST. * COMPILED-DEBUG-INFO-SOURCE was always a list of one element, make it just the element. * rename DEBUG-SOURCE-INFO to DEBUG-SOURCE-FUNCTION for clarity. Caveat updater: this breaks current Slime. --- diff --git a/NEWS b/NEWS index 48249b2..f478b76 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,9 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: initargs, making them be a list of (INITARG INITFORM INITFUNCTION) as per the MOP, rather than the historical (INITARG INITFUNCTION INITFORM). (reported by Bruno Haible) + * new feature: WITH-COMPILATION-UNIT now accepts a non-standard + :SOURCE-PLIST option. See (DOCUMENTATION #'WITH-COMPILATION-UNIT T) + for more information. * SB-SPROF now works (more) reliably on non-GENCGC platforms. * fixed some lockups due to gc/thread interaction * dynamic space size on PPC has been increased to 768Mb. (thanks to diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 61fe935..963ac0f 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -28,16 +28,19 @@ (defpackage :sb-introspect (:use "CL") - (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P" + (:export "FUNCTION-ARGLIST" + "VALID-FUNCTION-NAME-P" "FIND-DEFINITION-SOURCE" - "DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME" - "DEFINITION-NOT-FOUND" "DEFINITION-NAME" + "DEFINITION-SOURCE" + "DEFINITION-SOURCE-PATHNAME" "DEFINITION-SOURCE-FORM-PATH" "DEFINITION-SOURCE-CHARACTER-OFFSET" "DEFINITION-SOURCE-FILE-WRITE-DATE" + "DEFINITION-SOURCE-PLIST" + "DEFINITION-NOT-FOUND" "DEFINITION-NAME" "FIND-FUNCTION-CALLEES" - "FIND-FUNCTION-CALLERS" - )) + "FIND-FUNCTION-CALLERS")) + (in-package :sb-introspect) ;;;; Internal interface for SBCL debug info @@ -74,13 +77,7 @@ include the pathname of the file and the position of the definition." (declaim (ftype (function (debug-info) debug-source) debug-info-source)) (defun debug-info-source (debug-info) - (destructuring-bind (debug-source &rest other-debug-sources) - (sb-c::compiled-debug-info-source debug-info) - ;; COMPILED-DEBUG-INFO-SOURCES can return a list but we expect - ;; this to always contain exactly one element in SBCL. The list - ;; interface is inherited from CMUCL. -luke (12/Mar/2005) - (assert (null other-debug-sources)) - debug-source)) + (sb-c::debug-info-source debug-info)) (declaim (ftype (function (debug-info) debug-function) debug-info-debug-function)) (defun debug-info-debug-function (debug-info) @@ -105,7 +102,9 @@ include the pathname of the file and the position of the definition." (character-offset nil :type (or null integer)) ;; File-write-date of the source file when compiled. ;; Null if not compiled from a file. - (file-write-date nil :type (or null integer))) + (file-write-date nil :type (or null integer)) + ;; plist from WITH-COMPILATION-UNIT + (plist nil)) (defun find-definition-source (object) (etypecase object @@ -145,7 +144,8 @@ include the pathname of the file and the position of the definition." ;; debug-source. FIXME: We could use sb-di:code-locations to get ;; a full source path. -luke (12/Mar/2005) :form-path (if tlf (list tlf)) - :file-write-date (sb-c::debug-source-created debug-source)))) + :file-write-date (sb-c::debug-source-created debug-source) + :plist (sb-c::debug-source-plist debug-source)))) ;;; This is kludgey. We expect these functions (the underlying functions, ;;; not the closures) to be in static space and so not move ever. diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index 334b489..d14d627 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -4,15 +4,23 @@ (:use "SB-INTROSPECT" "CL")) (in-package :sb-introspect-test) -(load (compile-file (merge-pathnames "test.lisp" *load-pathname*))) +(with-compilation-unit (:source-plist (list :test-outer "OUT")) + (load (compile-file (merge-pathnames "test.lisp" *load-pathname*)))) (assert (equal (function-arglist 'cl-user::one) '(cl-user::a cl-user::b cl-user::c))) (assert (equal (function-arglist 'the) '(type sb-c::value))) -(assert (= (definition-source-file-write-date - (find-definition-source 'cl-user::one)) - (file-write-date (merge-pathnames "test.lisp" *load-pathname*)))) + +(let ((source (find-definition-source 'cl-user::one))) + (assert (= (definition-source-file-write-date source) + (file-write-date (merge-pathnames "test.lisp" *load-pathname*)))) + (assert (equal (getf (definition-source-plist source) :test-outer) + "OUT"))) + +(let ((plist (definition-source-plist (find-definition-source 'cl-user::four)))) + (assert (equal (getf plist :test-outer) "OUT")) + (assert (equal (getf plist :test-inner) "IN"))) (defun matchp (object form-number) (let ((ds (sb-introspect:find-definition-source object))) diff --git a/contrib/sb-introspect/test.lisp b/contrib/sb-introspect/test.lisp index 50e3161..0afafe5 100644 --- a/contrib/sb-introspect/test.lisp +++ b/contrib/sb-introspect/test.lisp @@ -10,5 +10,5 @@ (defstruct three four five) - - \ No newline at end of file +(with-compilation-unit (:source-plist (list :test-inner "IN")) + (eval '(defun four () 4))) diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index 1eb5038..3ca15e0 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -232,8 +232,10 @@ ;;; to at least know which function is an XEP for the real function ;;; (which would be useful info anyway). -;;;; debug source +;;;; DEBUG SOURCE +;;; 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) @@ -257,7 +259,9 @@ ;; :DEBUG-SOURCE-FORM is :LISP. (start-positions nil :type (or (simple-array * (*)) null)) ;; If from :LISP, this is the function whose source is form 0. - (info nil)) + (function nil) + ;; Additional information from (WITH-COMPILATION-UNIT (:SOURCE-PLIST ...)) + (plist *source-plist*)) ;;;; DEBUG-INFO structures @@ -271,7 +275,7 @@ ;; *** NOTE: the offset of this slot is wired into the fasl dumper ;; *** so that it can backpatch the source info when compilation ;; *** is complete. - (source nil :type list)) + (source nil)) (def!struct (compiled-debug-info (:include debug-info) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index fa67ca8..d8f4d72 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1750,27 +1750,11 @@ register." ;;; Return the CODE-LOCATION's DEBUG-SOURCE. (defun code-location-debug-source (code-location) - (etypecase code-location - (compiled-code-location - (let* ((info (compiled-debug-fun-debug-info - (code-location-debug-fun code-location))) - (sources (sb!c::compiled-debug-info-source info)) - (len (length sources))) - (declare (list sources)) - (when (zerop len) - (debug-signal 'no-debug-blocks :debug-fun - (code-location-debug-fun code-location))) - (if (= len 1) - (car sources) - (do ((prev sources src) - (src (cdr sources) (cdr src)) - (offset (code-location-toplevel-form-offset code-location))) - ((null src) (car prev)) - (when (< offset (sb!c::debug-source-source-root (car src))) - (return (car prev))))))) - ;; (There used to be more cases back before sbcl-0.7.0, when we - ;; did special tricks to debug the IR1 interpreter.) - )) + (let ((info (compiled-debug-fun-debug-info + (code-location-debug-fun code-location)))) + (or (sb!c::debug-info-source info) + (debug-signal 'no-debug-blocks :debug-fun + (code-location-debug-fun code-location))))) ;;; Returns the number of top level forms before the one containing ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A diff --git a/src/code/describe.lisp b/src/code/describe.lisp index ca2ab73..f36be45 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -153,24 +153,20 @@ (declare (type stream s)) (let ((info (sb-kernel:%code-debug-info code-obj))) (when info - (let ((sources (sb-c::debug-info-source info))) - (when sources + (let ((source (sb-c::debug-info-source info))) + (when source (format s "~&On ~A it was compiled from:" ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system ;; should become more consistent, probably not using ;; any nondefault options. - (format-universal-time nil - (sb-c::debug-source-compiled - (first sources)) + (format-universal-time nil (sb-c::debug-source-compiled source) :style :abbreviated)) - (dolist (source sources) - (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" name)))))))))) + (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" name))))))))) ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index fb151f1..05386fd 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -29,9 +29,9 @@ (code (sb!di::fun-code-header fun)) (info (sb!kernel:%code-debug-info code))) (if info - (let ((source (first (sb!c::compiled-debug-info-source info)))) + (let ((source (sb!c::debug-info-source info))) (cond ((and (eq (sb!c::debug-source-from source) :lisp) - (eq (sb!c::debug-source-info source) fun)) + (eq (sb!c::debug-source-function source) fun)) (values (svref (sb!c::debug-source-name source) 0) nil name)) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index af7d67f..0dc56c3 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -237,10 +237,8 @@ (values (copy-seq *byte-buffer*) tlf-num))) -;;; Return a list of DEBUG-SOURCE structures containing information -;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always -;;; dump the START-POSITIONS, since it is too hard figure out whether -;;; we need them or not. +;;; Return DEBUG-SOURCE structure containing information derived from +;;; INFO. (defun debug-source-for-info (info) (declare (type source-info info)) (let* ((file-info (source-info-file-info info)) @@ -254,9 +252,8 @@ (name (file-info-name file-info))) (etypecase name ((member :lisp) - (setf (debug-source-from res) name) - (setf (debug-source-name res) - (coerce (file-info-forms file-info) 'simple-vector))) + (setf (debug-source-from res) name + (debug-source-name res) (file-info-forms file-info))) (pathname (let* ((untruename (file-info-untruename file-info)) (dir (pathname-directory untruename))) @@ -273,7 +270,7 @@ (if (and dir (eq (first dir) :absolute)) untruename name)))))) - (list res))) + res)) ;;; 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 890263e..e135136 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -92,15 +92,15 @@ (error "Unresolved forward reference.")))) ;;; Backpatch all the DEBUG-INFOs dumped so far with the specified -;;; SOURCE-INFO list. We also check that there are no outstanding forward -;;; references to functions. -(defun fix-core-source-info (info object &optional source-info) - (declare (type source-info info) (type core-object object)) +;;; SOURCE-INFO list. We also check that there are no outstanding +;;; forward references to functions. +(defun fix-core-source-info (info object &optional function) + (declare (type core-object object) + (type (or null function) function)) (aver (zerop (hash-table-count (core-object-patch-table object)))) - (let ((res (debug-source-for-info info))) - (dolist (sinfo res) - (setf (debug-source-info sinfo) source-info)) + (let ((source (debug-source-for-info info))) + (setf (debug-source-function source) function) (dolist (info (core-object-debug-info object)) - (setf (compiled-debug-info-source info) res)) - (setf (core-object-debug-info object) ())) + (setf (debug-info-source info) source))) + (setf (core-object-debug-info object) nil) (values)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 124b33e..33555ef 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -123,18 +123,31 @@ This form affects compilations that take place within its dynamic extent. It is intended to be wrapped around the compilation of all files in the same system. These keywords are defined: + :OVERRIDE Boolean-Form One of the effects of this form is to delay undefined warnings until the end of the form, instead of giving them at the end of each compilation. If OVERRIDE is NIL (the default), then the outermost WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying OVERRIDE true causes that form to grab any enclosed warnings, even if - it is enclosed by another WITH-COMPILATION-UNIT." + it is enclosed by another WITH-COMPILATION-UNIT. + + :SOURCE-PLIST Plist-Form + Attaches the value returned by the Plist-Form to internal debug-source + information of functions compiled in within the dynamic contour. + Primarily for use by development environments, in order to eg. associate + function definitions with editor-buffers. Can be accessed as + SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested + WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended + togather, innermost left. If Unaffected by :OVERRIDE." `(%with-compilation-unit (lambda () ,@body) ,@options)) -(defun %with-compilation-unit (fn &key override) +(defvar *source-plist* nil) + +(defun %with-compilation-unit (fn &key override source-plist) (declare (type function fn)) - (let ((succeeded-p nil)) + (let ((succeeded-p nil) + (*source-plist* (append source-plist *source-plist*))) (if (and *in-compilation-unit* (not override)) ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is ;; ordinarily (unless OVERRIDE) basically a no-op. diff --git a/version.lisp-expr b/version.lisp-expr index 51adca7..c4c517d 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".) -"0.9.1.24" +"0.9.1.25"