From: Christophe Rhodes Date: Wed, 30 Jul 2003 16:07:44 +0000 (+0000) Subject: 0.8.2.10: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d814ff09969434c1d5225786da1c01d7a959cba0;p=sbcl.git 0.8.2.10: Implement SB-EXT:CODE-DELETION-NOTE, at least partly for pfdietz' benefit ... I'm too nice, really I am; ... we're going to need COERCE-TO-CONDITION in the cross-compiler; ... extract (somewhat bogusly) format control and arguments from the condition in the SIMPLE-CONDITION case, so that warm init doesn't print every compiler note in long form. --- diff --git a/NEWS b/NEWS index cdabc42..d0da2bc 100644 --- a/NEWS +++ b/NEWS @@ -1941,6 +1941,9 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: * SBCL now builds and runs on MacOS X (version 10.2), or perhaps more accurately, on the Darwin kernel running on PowerPC hardware. (thanks to Brian Mastenbrook, Pierre Mai and Patrik Nordebo) + * Compiler code deletion notes now signal a condition of type + SB-EXT:CODE-DELETION-NOTE (a subtype of SB-EXT:COMPILER-NOTE) with + an associated MUFFLE-WARNING restart. * bug fix: WITH-OUTPUT-TO-STRING (and MAKE-STRING-OUTPUT-STREAM) now accept and act upon their :ELEMENT-TYPE keyword argument. (reported by Edi Weitz) diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index a2df438..17737ce 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -53,4 +53,4 @@ (:integer map-shared "MAP_SHARED" "mmap: shared memory") (:integer map-private "MAP_PRIVATE" "mmap: private mapping") (:integer map-fixed "MAP_FIXED" "mmap: map at given location") - ) \ No newline at end of file + ) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f883311..4311813 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -552,7 +552,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; conditions that can be handled to reduce compiler ;; verbosity - "COMPILER-NOTE" + "CODE-DELETION-NOTE" "COMPILER-NOTE" ;; FIXME: This name doesn't match the DEFFOO - vs. - ;; DEFINE-FOO convention used in the ANSI spec, and so diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 32f71ad..7718c29 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -50,33 +50,6 @@ (/noshow0 "returning from SIGNAL") nil)) -;;; a utility for SIGNAL, ERROR, CERROR, WARN, and INVOKE-DEBUGGER: -;;; Parse the hairy argument conventions into a single argument that's -;;; directly usable by all the other routines. -(defun coerce-to-condition (datum arguments default-type fun-name) - (cond ((typep datum 'condition) - (if arguments - (cerror "Ignore the additional arguments." - 'simple-type-error - :datum arguments - :expected-type 'null - :format-control "You may not supply additional arguments ~ - when giving ~S to ~S." - :format-arguments (list datum fun-name))) - datum) - ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) - (apply #'make-condition datum arguments)) - ((or (stringp datum) (functionp datum)) - (make-condition default-type - :format-control datum - :format-arguments arguments)) - (t - (error 'simple-type-error - :datum datum - :expected-type '(or symbol string) - :format-control "bad argument to ~S: ~S" - :format-arguments (list fun-name datum))))) - ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably ;;; doesn't want to hear that the error "occurred in" one of these ;;; functions, so we try to point the top of the stack to our caller diff --git a/src/code/error.lisp b/src/code/error.lisp index bb3b024..163c0e3 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -23,6 +23,33 @@ :format-control format-control :format-arguments format-arguments)) +;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY and +;;; INVOKE-DEBUGGER: Parse the hairy argument conventions into a +;;; single argument that's directly usable by all the other routines. +(defun coerce-to-condition (datum arguments default-type fun-name) + (cond ((typep datum 'condition) + (if arguments + (cerror "Ignore the additional arguments." + 'simple-type-error + :datum arguments + :expected-type 'null + :format-control "You may not supply additional arguments ~ + when giving ~S to ~S." + :format-arguments (list datum fun-name))) + datum) + ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) + (apply #'make-condition datum arguments)) + ((or (stringp datum) (functionp datum)) + (make-condition default-type + :format-control datum + :format-arguments arguments)) + (t + (error 'simple-type-error + :datum datum + :expected-type '(or symbol string) + :format-control "bad argument to ~S: ~S" + :format-arguments (list fun-name datum))))) + (define-condition layout-invalid (type-error) () (:report diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index f598a04..6f18bd4 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -375,6 +375,8 @@ (setq *last-error-context* context) + ;; FIXME: this testing for effective equality of compiler messages + ;; is ugly, and really ought to be done at a higher level. (unless (and (equal format-string *last-format-string*) (tree-equal format-args *last-format-args*)) (note-message-repeats nil) @@ -408,11 +410,9 @@ (values "~A" (list (with-output-to-string (s) (princ condition s))))) - (print-compiler-message (format nil - "caught ~S:~% ~A" - what - format-string) - format-args))) + (print-compiler-message + (format nil "caught ~S:~% ~A" what format-string) + format-args))) (values)) ;;; The act of signalling one of these beasts must not cause WARNINGSP @@ -422,24 +422,38 @@ ;;; FIXME: the handling of compiler-notes could be unified with ;;; warnings and style-warnings (see the various handler functions ;;; below). -(define-condition compiler-note (condition) ()) +(define-condition compiler-note (condition) () + (:documentation + "Root of the hierarchy of conditions representing information discovered +by the compiler that the user might wish to know, but which does not merit +a STYLE-WARNING (or any more serious condition).")) (define-condition simple-compiler-note (simple-condition compiler-note) ()) +(define-condition code-deletion-note (simple-compiler-note) () + (:documentation + "A condition type signalled when the compiler deletes code that the user +has written, having proved that it is unreachable.")) -(defun compiler-notify (format-string &rest format-args) - ;; FORMAT-STRING and FORMAT-ARGS might well end up turning into - ;; DATUM and REST, and COERCE-TO-CONDITION will be used. +(defun compiler-notify (datum &rest args) (unless (if *compiler-error-context* (policy *compiler-error-context* (= inhibit-warnings 3)) (policy *lexenv* (= inhibit-warnings 3))) - (restart-case - (signal (make-condition 'simple-compiler-note - :format-control format-string - :format-arguments format-args)) - (muffle-warning () - (return-from compiler-notify (values)))) - (incf *compiler-note-count*) - (print-compiler-message (format nil "note: ~A" format-string) - format-args)) + (let ((condition + (coerce-to-condition datum args + 'simple-compiler-note 'compiler-notify))) + (restart-case + (signal condition) + (muffle-warning () + (return-from compiler-notify (values)))) + (incf *compiler-note-count*) + (multiple-value-bind (format-string format-args) + (if (typep condition 'simple-condition) + (values (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (values "~A" + (list (with-output-to-string (s) + (princ condition s))))) + (print-compiler-message (format nil "note: ~A" format-string) + format-args)))) (values)) ;;; Issue a note when we might or might not be in the compiler. @@ -447,19 +461,21 @@ (if (boundp '*lexenv*) ; if we're in the compiler (apply #'compiler-notify rest) (progn - (restart-case - (signal (make-condition 'simple-compiler-note - :format-control (car rest) - :format-arguments (cdr rest))) - (muffle-warning () - (return-from maybe-compiler-notify (values)))) - (let ((stream *error-output*)) - (pprint-logical-block (stream nil :per-line-prefix ";") - (format stream " note: ~3I~_") - (pprint-logical-block (stream nil) - (apply #'format stream rest))) - ;; (outside logical block, no per-line-prefix) - (fresh-line stream)) + (let ((condition + (coerce-to-condition (car rest) (cdr rest) + 'simple-compiler-note + 'maybe-compiler-notify))) + (restart-case + (signal condition) + (muffle-warning () + (return-from maybe-compiler-notify (values)))) + (let ((stream *error-output*)) + (pprint-logical-block (stream nil :per-line-prefix ";") + (format stream " note: ~3I~_") + (pprint-logical-block (stream nil) + (format stream "~A" condition))) + ;; (outside logical block, no per-line-prefix) + (fresh-line stream))) (values)))) ;;; The politically correct way to print out progress messages and diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index ea581fb..429c7ae 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -862,8 +862,9 @@ (return-block (and return (node-block return)))) (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) - (compiler-notify "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-debug-name clambda)))) + (compiler-notify 'code-deletion-note + :format-control "deleting unused function~:[.~;~:*~% ~S~]" + :format-arguments (list (leaf-debug-name clambda))))) (unless (block-delete-p bind-block) (unlink-blocks (component-head component) bind-block)) (when (and return-block (not (block-delete-p return-block))) @@ -1245,7 +1246,9 @@ 0))) (unless (return-p node) (let ((*compiler-error-context* node)) - (compiler-notify "deleting unreachable code"))) + (compiler-notify 'code-deletion-note + :format-control "deleting unreachable code" + :format-arguments nil))) (return)))))) (values)) diff --git a/version.lisp-expr b/version.lisp-expr index e4f59c7..4c21280 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.8.2.9" +"0.8.2.10"