From a80a02aec71e15e1ae7bebd502399ab2b824d08b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 9 May 2011 19:47:03 +0000 Subject: [PATCH] 1.0.48.3: source-locations from LOAD of source files, and EVAL-WHEN :COMPILE-TOPLEVEL * Bind *SOURCE-INFO* and bind and populate *SOURCE-PATHS* in LOAD-AS-SOURCE. * EVAL-TLF provides a way to evaluate things while providing the toplevel form number. It also captures the current *SOURCE-INFO* and passes it onwards to be reused by ACTUALLY-COMPILE. * In ACTUALLY-COMPILE, when asked to reuse a source-info object, also retain the old *SOURCE-PATHS*. --- NEWS | 4 + contrib/sb-introspect/introspect.lisp | 5 +- contrib/sb-introspect/sb-introspect.asd | 11 ++- contrib/sb-introspect/test-driver.lisp | 8 ++ contrib/sb-introspect/test.lisp | 4 + package-data-list.lisp-expr | 4 + src/code/eval.lisp | 15 +++- src/code/target-load.lisp | 46 ++++++---- src/compiler/early-c.lisp | 1 + src/compiler/main.lisp | 6 +- src/compiler/target-main.lisp | 147 +++++++++++++++++-------------- version.lisp-expr | 2 +- 12 files changed, 156 insertions(+), 97 deletions(-) diff --git a/NEWS b/NEWS index 3aa1c01..15c4775 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.48: + * enhancement: functions from files loaded as source now have source + locations. + * enhancement: functions from compile-time-too evaluation now have source + locations. * enhancement: WITH-COMPILATION-UNIT :SOURCE-NAMESTRING allows providing virtual source-file information, eg. overriding input-file of COMPILE-FILE when a temporary file is used for compilation. diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index 3399502..bf14546 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -376,9 +376,8 @@ If an unsupported TYPE is requested, the function will return NIL. ;; :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))) + (when (stringp (sb-c::debug-source-namestring 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/contrib/sb-introspect/sb-introspect.asd b/contrib/sb-introspect/sb-introspect.asd index bb1cbaa..a9587df 100644 --- a/contrib/sb-introspect/sb-introspect.asd +++ b/contrib/sb-introspect/sb-introspect.asd @@ -38,12 +38,21 @@ (with-compilation-unit (:source-plist (plist-file-source-plist com)) (call-next-method))) +(defclass source-only-file (cl-source-file) + ()) + +(defmethod perform ((op compile-op) (com source-only-file))) + +(defmethod output-files ((op compile-op) (com source-only-file)) + (list (component-pathname com))) + (defsystem :sb-introspect-tests :depends-on (:sb-introspect :sb-rt) :components ((:file "xref-test-data") (:file "xref-test" :depends-on ("xref-test-data")) (:plist-file "test" :source-plist (:test-outer "OUT")) - (:file "test-driver" :depends-on ("test")))) + (:source-only-file "load-test") + (:file "test-driver" :depends-on ("test" "load-test")))) (defmethod perform ((op test-op) (com (eql (find-system :sb-introspect-tests)))) ;; N.b. At least DEFINITION-SOURCE-PLIST.1 assumes that CWD is the diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index 0ce7187..a444769 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -188,6 +188,14 @@ (not (find-definition-sources-by-name 'fboundp :type)) t) +(deftest find-source-stuff.31 + (matchp-name :function 'cl-user::compile-time-too-fun 28) + t) + +(deftest find-source-stuff.32 + (matchp-name :function 'cl-user::loaded-as-source-fun 3) + t) + ;;; Check wrt. interplay of generic functions and their methods. (defgeneric xuuq (gf.a gf.b &rest gf.rest &key gf.k-X)) diff --git a/contrib/sb-introspect/test.lisp b/contrib/sb-introspect/test.lisp index 064e262..cd100c5 100644 --- a/contrib/sb-introspect/test.lisp +++ b/contrib/sb-introspect/test.lisp @@ -70,3 +70,7 @@ (define-setf-expander s (a b) (format t "~a ~a~%" a b)) + +(eval-when (:compile-toplevel) + (defun compile-time-too-fun () + :foo)) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 16ddd97..651ba3d 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -708,6 +708,10 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; to hide it from them.. "INTERACTIVE-EVAL" + ;; Used by LOAD and EVAL-WHEN to pass toplevel indexes + ;; to compiler. + "EVAL-TLF" + ;; weak pointers and finalization "CANCEL-FINALIZATION" "FINALIZE" diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 7f5c4f5..4687ebd 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -22,6 +22,9 @@ (defvar *eval-source-context* nil) +(defvar *eval-tlf-index* nil) +(defvar *eval-source-info* nil) + (defun make-eval-lambda (expr) `(named-lambda ;; This name is used to communicate the original context @@ -61,7 +64,8 @@ ;; As of 1.0.21.6 we muffle compiler notes lexically here, which seems ;; always safe. --NS (let* ((lambda (make-eval-lambda expr)) - (fun (sb!c:compile-in-lexenv nil lambda lexenv))) + (fun (sb!c:compile-in-lexenv + nil lambda lexenv *eval-source-info* *eval-tlf-index*))) (funcall fun))) ;;; Handle PROGN and implicit PROGN. @@ -298,9 +302,16 @@ #!+sb-doc "Evaluate the argument in a null lexical environment, returning the result or results." - (let ((*eval-source-context* original-exp)) + (let ((*eval-source-context* original-exp) + (*eval-tlf-index* nil) + (*eval-source-info* nil)) (eval-in-lexenv original-exp (make-null-lexenv)))) +(defun eval-tlf (original-exp tlf-index &optional (lexenv (make-null-lexenv))) + (let ((*eval-source-context* original-exp) + (*eval-tlf-index* tlf-index) + (*eval-source-info* sb!c::*source-info*)) + (eval-in-lexenv original-exp lexenv))) ;;; miscellaneous full function definitions of things which are ;;; ordinarily handled magically by the compiler diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 55a585d..6f2912e 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -30,28 +30,36 @@ ;;; 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) - (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) + (macrolet + ((do-sexprs (((sexpr index) 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))) + (sb!c::*source-info* ,source-info) + (sb!c::*source-paths* (make-hash-table :test 'eq))) + (setf (sb!c::source-info-stream ,source-info) ,stream) + (sb!c::do-forms-from-info ((,sexpr current-index) + ,source-info) + (sb!c::find-source-paths ,sexpr current-index) + (let ((,index current-index)) + ,@body))) + (let ((sb!c::*source-info* nil) + (,index nil)) + (do ((,sexpr (read ,stream nil *eof-object*) + (read ,stream nil *eof-object*))) + ((eq ,sexpr *eof-object*)) + ,@body))))))) + (do-sexprs ((sexpr tlf-index) stream) (if print - (let ((results (multiple-value-list (eval sexpr)))) + (let ((results (multiple-value-list (eval-tlf sexpr tlf-index)))) (load-fresh-line) (format t "~{~S~^, ~}~%" results)) - (eval sexpr))) + (eval-tlf sexpr tlf-index))) t)) ;;;; LOAD itself diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index c1715dd..9d19a78 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -93,6 +93,7 @@ (defvar *current-path*) (defvar *current-component*) (defvar *delayed-ir1-transforms*) +(defvar *eval-tlf-index*) (defvar *handled-conditions*) (defvar *disabled-package-locks*) (defvar *policy*) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index c9fc000..eae1bd6 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1281,7 +1281,7 @@ Examples: ;;; compilation. Normally just evaluate in the appropriate ;;; environment, but also compile if outputting a CFASL. (defun eval-compile-toplevel (body path) - (eval-in-lexenv `(progn ,@body) *lexenv*) + (eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*) (when *compile-toplevel-object* (let ((*compile-object* *compile-toplevel-object*)) (convert-and-maybe-compile `(progn ,@body) path)))) @@ -2050,6 +2050,6 @@ SPEED and COMPILATION-SPEED optimization values, and the (compile name lambda)) #+sb-xc-host -(defun eval-in-lexenv (form lexenv) - (declare (ignore lexenv)) +(defun eval-tlf (form index &optional lexenv) + (declare (ignore index lexenv)) (eval form)) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index aa011e1..6614c67 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -28,83 +28,94 @@ definition))) ;;; Handle the nontrivial case of CL:COMPILE. -(defun actually-compile (name definition *lexenv*) - (with-compilation-values - (sb!xc:with-compilation-unit () - ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with - ;; few changes. Once things are stable, the shared bindings - ;; probably be merged back together into some shared utility - ;; macro, or perhaps both merged into one of the existing utility - ;; macros SB-C::WITH-COMPILATION-VALUES or - ;; CL:WITH-COMPILATION-UNIT. - (let* (;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding - ;; here? It's a literal translation of the old CMU CL - ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT* - ;; *INFO-ENVIRONMENT*), and it's not obvious whether the - ;; rebinding to itself is needed now that SBCL doesn't - ;; need *BACKEND-INFO-ENVIRONMENT*. - (*info-environment* *info-environment*) - (form (get-lambda-to-compile definition)) - (*source-info* (make-lisp-source-info form :parent *source-info*)) - (*toplevel-lambdas* ()) - (*block-compile* nil) - (*allow-instrumenting* nil) - (*code-coverage-records* nil) - (*code-coverage-blocks* nil) - (*compiler-error-bailout* - (lambda (&optional error) - (declare (ignore error)) - (compiler-mumble - "~2&fatal error, aborting compilation~%") - (return-from actually-compile (values nil t nil)))) - (*current-path* nil) - (*last-source-context* nil) - (*last-original-source* nil) - (*last-source-form* nil) - (*last-format-string* nil) - (*last-format-args* nil) - (*last-message-count* 0) - (*last-error-context* nil) - (*gensym-counter* 0) - ;; KLUDGE: This rebinding of policy is necessary so that - ;; forms such as LOCALLY at the REPL actually extend the - ;; compilation policy correctly. However, there is an - ;; invariant that is potentially violated: future - ;; refactoring must not allow this to be done in the file - ;; compiler. At the moment we're clearly alright, as we - ;; call %COMPILE with a core-object, not a fasl-stream, - ;; but caveat future maintainers. -- CSR, 2002-10-27 - (*policy* (lexenv-policy *lexenv*)) - ;; see above - (*handled-conditions* (lexenv-handled-conditions *lexenv*)) - ;; ditto - (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) - ;; FIXME: ANSI doesn't say anything about CL:COMPILE - ;; interacting with these variables, so we shouldn't. As - ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by - ;; binding these variables, so as a quick hack we do so - ;; too. But a proper implementation would have verbosity - ;; controlled by function arguments and lexical variables. - (*compile-verbose* nil) - (*compile-print* nil)) - (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) - (clear-stuff) - (find-source-paths form 0) - (%compile form (make-core-object) - :name name - :path '(original-source-start 0 0))))))) +(defun actually-compile (name definition *lexenv* source-info tlf) + (let ((source-paths (when source-info *source-paths*))) + (with-compilation-values + (sb!xc:with-compilation-unit () + ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with + ;; few changes. Once things are stable, the shared bindings + ;; probably be merged back together into some shared utility + ;; macro, or perhaps both merged into one of the existing utility + ;; macros SB-C::WITH-COMPILATION-VALUES or + ;; CL:WITH-COMPILATION-UNIT. + (let* ((tlf (or tlf 0)) + ;; If we have a source-info from LOAD, we will + ;; also have a source-paths already set up -- so drop + ;; the ones from WITH-COMPILATION-VALUES. + (*source-paths* (or source-paths *source-paths*)) + ;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding + ;; here? It's a literal translation of the old CMU CL + ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT* + ;; *INFO-ENVIRONMENT*), and it's not obvious whether the + ;; rebinding to itself is needed now that SBCL doesn't + ;; need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*) + (form (get-lambda-to-compile definition)) + (*source-info* (or source-info + (make-lisp-source-info + form :parent *source-info*))) + (*toplevel-lambdas* ()) + (*block-compile* nil) + (*allow-instrumenting* nil) + (*code-coverage-records* nil) + (*code-coverage-blocks* nil) + (*compiler-error-bailout* + (lambda (&optional error) + (declare (ignore error)) + (compiler-mumble + "~2&fatal error, aborting compilation~%") + (return-from actually-compile (values nil t nil)))) + (*current-path* nil) + (*last-source-context* nil) + (*last-original-source* nil) + (*last-source-form* nil) + (*last-format-string* nil) + (*last-format-args* nil) + (*last-message-count* 0) + (*last-error-context* nil) + (*gensym-counter* 0) + ;; KLUDGE: This rebinding of policy is necessary so that + ;; forms such as LOCALLY at the REPL actually extend the + ;; compilation policy correctly. However, there is an + ;; invariant that is potentially violated: future + ;; refactoring must not allow this to be done in the file + ;; compiler. At the moment we're clearly alright, as we + ;; call %COMPILE with a core-object, not a fasl-stream, + ;; but caveat future maintainers. -- CSR, 2002-10-27 + (*policy* (lexenv-policy *lexenv*)) + ;; see above + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) + ;; FIXME: ANSI doesn't say anything about CL:COMPILE + ;; interacting with these variables, so we shouldn't. As + ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by + ;; binding these variables, so as a quick hack we do so + ;; too. But a proper implementation would have verbosity + ;; controlled by function arguments and lexical variables. + (*compile-verbose* nil) + (*compile-print* nil)) + (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) + (clear-stuff) + (unless source-paths + (find-source-paths form tlf)) + (%compile form (make-core-object) + :name name + :path `(original-source-start 0 ,tlf)))))))) -(defun compile-in-lexenv (name definition lexenv) +(defun compile-in-lexenv (name definition lexenv + &optional source-info tlf) (multiple-value-bind (compiled-definition warnings-p failure-p) (cond #!+sb-eval ((sb!eval:interpreted-function-p definition) (multiple-value-bind (definition lexenv) (sb!eval:prepare-for-compile definition) - (actually-compile name definition lexenv))) + (actually-compile name definition lexenv source-info tlf))) ((compiled-function-p definition) (values definition nil nil)) - (t (actually-compile name definition lexenv))) + (t + (actually-compile name definition lexenv source-info tlf))) (cond (name (if (and (symbolp name) (macro-function name)) diff --git a/version.lisp-expr b/version.lisp-expr index 16fa6bc..22da1e0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,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.48.2" +"1.0.48.3" -- 1.7.10.4