From b1cd84e0503ff29d72a860ea1709c87f721412ed Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 20 Nov 2007 14:50:40 +0000 Subject: [PATCH] 1.0.11.35: fixed bug 417 * Don't store non-unique objects like symbols, fixnums, or characters in *SOURCE-PATHS*. * For future refactoring ease, always access *SOURCE-PATHS* via GET-SOURCE-PATH and NOTE-SOURCE-PATH. --- BUGS | 17 -------------- NEWS | 1 + src/code/macros.lisp | 2 +- src/compiler/ir1-translators.lisp | 2 +- src/compiler/ir1tran.lisp | 49 +++++++++++++++++++++++++-------------- src/compiler/main.lisp | 2 +- tests/bug-417.lisp | 6 +++++ tests/compiler.impure.lisp | 6 +++++ version.lisp-expr | 2 +- 9 files changed, 48 insertions(+), 39 deletions(-) create mode 100644 tests/bug-417.lisp diff --git a/BUGS b/BUGS index a375a314b..55d9b4fcb 100644 --- a/BUGS +++ b/BUGS @@ -1838,23 +1838,6 @@ WORKAROUND: 1: (SB-KERNEL:FDEFINITION-OBJECT 13 NIL) as the second frame. -417: Toplevel NIL expressions mess up unreachable code reporting. - In sbcl-1.0.10.7, COMPILE-FILE on the file - nil - (defmethod frob ((package package) stream) - (if (string= (package-name package) "FOO") - (pprint-logical-block (stream nil)) - (print-unreadable-object (package stream)))) - causes complaints like - ; in: SOME SB-C::STRANGE SB-C::PLACE - ; (SB-C::UNABLE SB-C::TO SB-C::LOCATE SB-C::SOURCE) - ; - ; note: deleting unreachable code - ; - ; note: deleting unreachable code - Deleting the toplevel NIL, or even replacing it with 3, - causes the system not to complain. - 418: SUBSEQ on lists doesn't support bignum indexes LIST-SUBSEQ* now has all the works necessary to support bignum indexes, diff --git a/NEWS b/NEWS index 87f44f2e8..76e2308fd 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,7 @@ changes in sbcl-1.0.12 relative to sbcl-1.0.11: * optimization: CONCATENATE on strings is an order of magnitue faster in code compiled with (> SPEED SPACE). * optimization: SUBSEQ is ~50% faster on lists. + * bug fix: bug 417 fixed -- source location reporting is now more robust. * bug fix: SUBSEQ on a list will now correctly signal an error if if END is smaller then START. * bug fix: SB-PROFILE will no longer report extra consing for nested diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 3da5529a3..ebddde6f3 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -216,7 +216,7 @@ invoked. In that case it will store into PLACE and start over." do (when existing (let ((sb!c::*current-path* (when (boundp 'sb!c::*source-paths*) - (or (gethash case sb!c::*source-paths*) + (or (sb!c::get-source-path case) sb!c::*current-path*)))) (warn 'duplicate-case-key-warning :key k diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index e4c4d62cf..affa00fc8 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -74,7 +74,7 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL." (if (policy *lexenv* (= store-coverage-data 0)) nil (labels ((sub (form) - (or (gethash form *source-paths*) + (or (get-source-path form) (and (consp form) (some #'sub form))))) (or (sub form))))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 15ac812a8..f19f44529 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -14,15 +14,40 @@ (declaim (special *compiler-error-bailout*)) +;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the +;;; form number to associate with a source path. This should be bound +;;; to an initial value of 0 before the processing of each truly +;;; top level form. +(declaim (type index *current-form-number*)) +(defvar *current-form-number*) + ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path ;;; taken through the source to reach the form. This provides a way to ;;; keep track of the location of original source forms, even when ;;; macroexpansions and other arbitary permutations of the code ;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on ;;; the original source. +;;; +;;; It is fairly useless to store symbols, characters, or fixnums in +;;; this table, as 42 is EQ to 42 no matter where in the source it +;;; appears. GET-SOURCE-PATH and NOTE-SOURCE-PATH functions should be +;;; always used to access this table. (declaim (hash-table *source-paths*)) (defvar *source-paths*) +(declaim (inline source-form-hash-path-p)) +(defun source-form-has-path-p (form) + (not (typep form '(or symbol fixnum character)))) + +(defun get-source-path (form) + (when (source-form-has-path-p form) + (gethash form *source-paths*))) + +(defun note-source-path (form &rest arguments) + (when (source-form-has-path-p form) + (setf (gethash form *source-paths*) + (apply #'list* 'original-source-start *current-form-number* arguments)))) + ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph @@ -410,13 +435,6 @@ (functional-kind res) :toplevel) res))) -;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the -;;; form number to associate with a source path. This should be bound -;;; to an initial value of 0 before the processing of each truly -;;; top level form. -(declaim (type index *current-form-number*)) -(defvar *current-form-number*) - ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to ;;; find the paths in, and TLF-NUM is the top level form number of the @@ -430,9 +448,8 @@ (sub-find-source-paths form (list tlf-num))) (values)) (defun sub-find-source-paths (form path) - (unless (gethash form *source-paths*) - (setf (gethash form *source-paths*) - (list* 'original-source-start *current-form-number* path)) + (unless (get-source-path form) + (note-source-path form path) (incf *current-form-number*) (let ((pos 0) (subform form) @@ -448,11 +465,7 @@ ;; Otherwise store the containing form. It's ;; not perfect, but better than nothing. (unless (zerop pos) - (setf (gethash subform *source-paths*) - (list* 'original-source-start - *current-form-number* - pos - path)))) + (note-source-path subform pos path))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) @@ -494,7 +507,7 @@ ;; namespace. (defun ir1-convert (start next result form) (ir1-error-bailout (start next result form) - (let* ((*current-path* (or (gethash form *source-paths*) + (let* ((*current-path* (or (get-source-path form) (cons form *current-path*))) (start (instrument-coverage start nil form))) (cond ((atom form) @@ -871,8 +884,8 @@ ;;; EQness of the conses. (defun maybe-instrument-progn-like (start forms form) (or (when (and *allow-instrumenting* - (not (gethash form *source-paths*))) - (let ((*current-path* (gethash forms *source-paths*))) + (not (get-source-path form))) + (let ((*current-path* (get-source-path forms))) (when *current-path* (instrument-coverage start nil form)))) start)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 7b671c479..57ec2ee95 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1150,7 +1150,7 @@ (declare (list path)) (catch 'process-toplevel-form-error-abort - (let* ((path (or (gethash form *source-paths*) (cons form path))) + (let* ((path (or (get-source-path form) (cons form path))) (*compiler-error-bailout* (lambda (&optional condition) (convert-and-maybe-compile diff --git a/tests/bug-417.lisp b/tests/bug-417.lisp new file mode 100644 index 000000000..87e3a37c5 --- /dev/null +++ b/tests/bug-417.lisp @@ -0,0 +1,6 @@ +;;; bug 417: toplevel nil confusing source-path logic +nil +(defmethod frob ((package package) stream) + (if (string= (package-name package) "FOO") + (pprint-logical-block (stream nil)) + (print-unreadable-object (package stream)))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 9431e70a1..fa098af26 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1511,4 +1511,10 @@ (quux))))) (assert (equal '(1 2 3) (wpo-multiple-call-local))) +;;; bug 417: toplevel NIL confusing source path logic +(handler-case + (delete-file (compile-file "bug-417.lisp")) + (sb-ext:code-deletion-note (e) + (error e))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 156fa072c..2d09e3a55 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.11.34" +"1.0.11.35" -- 2.11.4.GIT