From 0794cd3908a441222f430ba0cf3bb7c3e1a96c63 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 17 May 2004 16:17:56 +0000 Subject: [PATCH] 0.8.10.29: SB-EXT:MUFFLE-CONDITIONS. Go wild. ... rejig the implementation a bit more from the latest CSR sbcl-devel patch: new SB-C::*HANDLED-CONDITIONS* variable analogous to SB-C::*POLICY* (and treated with the same kinds of hack, too, with rebindings and other fakery to get the right semantics); ... more test cases; ... documentation; ... since we're in the general area, make SB-CLTL2:DECLARATION-INFORMATION work on it... ... and write test cases for this and OPTIMIZE. --- NEWS | 5 +++ contrib/sb-cltl2/env.lisp | 19 ++++++---- contrib/sb-cltl2/tests.lisp | 42 ++++++++++++++++++++++ doc/manual/backmatter.texinfo | 6 ++++ doc/manual/beyond-ansi.texinfo | 3 -- doc/manual/compiler.texinfo | 59 ++++++++++++++++++------------ doc/manual/sbcl.texinfo | 1 + package-data-list.lisp-expr | 3 ++ src/compiler/early-c.lisp | 1 + src/compiler/ir1report.lisp | 37 ++++++++++++++----- src/compiler/ir1tran.lisp | 10 ++++++ src/compiler/ir1util.lisp | 4 ++- src/compiler/lexenv.lisp | 9 ++--- src/compiler/main.lisp | 77 +++++++++++++++++++++++++++++++--------- src/compiler/policy.lisp | 21 +++++------ src/compiler/proclaim.lisp | 64 +++++++++++++++++++++++++++++++++ src/compiler/target-main.lisp | 13 ++++--- tests/compiler.impure.lisp | 19 +++++++++- tests/compiler.test.sh | 64 +++++++++++++++++++++++++++++++++ tests/expect.sh | 19 +++++++--- version.lisp-expr | 2 +- 21 files changed, 391 insertions(+), 87 deletions(-) diff --git a/NEWS b/NEWS index 3826b23..c042a50 100644 --- a/NEWS +++ b/NEWS @@ -2398,6 +2398,11 @@ changes in sbcl-0.8.10 relative to sbcl-0.8.9: to Bruno Haible) changes in sbcl-0.8.11 relative to sbcl-0.8.10: + * new feature: the SB-EXT:MUFFLE-CONDITIONS declaration should be + used to control emission of compiler diagnostics, rather than the + SB-EXT:INHIBIT-WARNINGS OPTIMIZE quality. See the manual for + documentation on this feature. The SB-EXT:INHIBIT-WARNINGS + quality should be considered deprecated. * fixed bug 320: Shared to local slot value transfers in class redefinitions now happen corrently from superclasses as well. (reported by Bruno Haible) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 2a99b98..896d8f3 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -55,14 +55,19 @@ alist of declarations that apply to the apparent binding of VAR." (declaim (ftype (sfunction (symbol &optional (or null lexenv)) t) declaration-information)) (defun declaration-information (declaration-name &optional env) - (let ((policy (sb-c::lexenv-policy (or env (make-null-lexenv))))) + (let ((env (or env (make-null-lexenv)))) (case declaration-name - (optimize (collect ((res)) - (dolist (name sb-c::*policy-qualities*) - (res (list name (cdr (assoc name policy))))) - (loop for (name . nil) in sb-c::*policy-dependent-qualities* - do (res (list name (sb-c::policy-quality policy name)))) - (res))) + (optimize + (let ((policy (sb-c::lexenv-policy env))) + (collect ((res)) + (dolist (name sb-c::*policy-qualities*) + (res (list name (cdr (assoc name policy))))) + (loop for (name . nil) in sb-c::*policy-dependent-qualities* + do (res (list name (sb-c::policy-quality policy name)))) + (res)))) + (sb-ext:muffle-conditions + (car (rassoc 'muffle-warning + (sb-c::lexenv-handled-conditions env)))) (t (error "Unsupported declaration ~S." declaration-name))))) (defun parse-macro (name lambda-list body &optional env) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index 19d5f05..3a9bd8c 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -56,3 +56,45 @@ (deftest macroexpand-all.4 (macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr))) (symbol-macrolet ((srlt '(nil zool))) 'zool)) + +(defmacro dinfo (thing &environment env) + `',(declaration-information thing env)) + +(macrolet ((def (x) + `(macrolet ((frob (suffix answer &optional declaration) + `(deftest ,(intern (concatenate 'string + "DECLARATION-INFORMATION." + (symbol-name ',x) + suffix)) + (locally (declare ,@(when declaration + (list declaration))) + (cadr (assoc ',',x (dinfo optimize)))) + ,answer))) + (frob ".DEFAULT" 1) + (frob ".0" 0 (optimize (,x 0))) + (frob ".1" 1 (optimize (,x 1))) + (frob ".2" 2 (optimize (,x 2))) + (frob ".3" 3 (optimize (,x 3))) + (frob ".IMPLICIT" 3 (optimize ,x))))) + (def speed) + (def safety) + (def debug) + (def compilation-speed) + (def space)) + +(deftest declaration-information.muffle-conditions.default + (dinfo sb-ext:muffle-conditions) + nil) +(deftest declaration-information.muffle-conditions.1 + (locally (declare (sb-ext:muffle-conditions warning)) + (dinfo sb-ext:muffle-conditions)) + warning) +(deftest declaration-information.muffle-conditions.2 + (locally (declare (sb-ext:muffle-conditions warning)) + (locally (declare (sb-ext:unmuffle-conditions style-warning)) + (let ((dinfo (dinfo sb-ext:muffle-conditions))) + (not + (not + (and (subtypep dinfo '(and warning (not style-warning))) + (subtypep '(and warning (not style-warning)) dinfo))))))) + t) diff --git a/doc/manual/backmatter.texinfo b/doc/manual/backmatter.texinfo index c0cda39..e435843 100644 --- a/doc/manual/backmatter.texinfo +++ b/doc/manual/backmatter.texinfo @@ -16,6 +16,12 @@ @printindex vr +@node Type Index +@comment node-name, next, previous, up +@appendix Type Index + +@printindex tp + @node Colophon @comment node-name, next, previous, up @unnumbered Colophon diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 62ef354..a8c8a28 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -317,10 +317,8 @@ implementation-defined. In SBCL, @code{require} behaves in the following way: @include fun-common-lisp-require.texinfo - @include var-sb-ext-star-module-provider-functions-star.texinfo - @node Tools To Help Developers @comment node-name, next, previous, up @subsection Tools To Help Developers @@ -335,7 +333,6 @@ Debugger}. Documentation for @code{inspect} is accessed by typing @kbd{help} at the @code{inspect} prompt. - @node Interface To Low-Level SBCL Implementation @comment node-name, next, previous, up @subsection Interface To Low-Level SBCL Implementation diff --git a/doc/manual/compiler.texinfo b/doc/manual/compiler.texinfo index d404ef9..fa0205c 100644 --- a/doc/manual/compiler.texinfo +++ b/doc/manual/compiler.texinfo @@ -311,6 +311,11 @@ explanation, so the compiler backed out one level. @subsection Error Severity @cindex Severity of compiler errors @cindex compiler error severity +@tindex error +@tindex warning +@tindex style-warning +@tindex compiler-note +@tindex code-deletion-note There are four levels of compiler error severity: @emph{error}, @emph{warning}, @emph{style warning}, and @emph{note}. The first three @@ -319,10 +324,15 @@ standard for Common Lisp and which have special significance to the @code{compile} and @code{compile-file} functions. These levels of compiler error severity occur when the compiler handles conditions of these classes. The fourth level of compiler error severity, -@emph{note}, is used for problems which are too mild for the standard -condition classes, typically hints about how efficiency might be -improved. -@comment mention sb-ext:compiler-note +@emph{note}, corresponds to the @code{sb-ext:compiler-note}, and is +used for problems which are too mild for the standard condition +classes, typically hints about how efficiency might be improved. The +@code{sb-ext:code-deletion-note}, a subtype of @code{compiler-note}, +is signalled when the compiler deletes user-supplied code, usually +after proving that the code in question is unreachable. + +@include condition-sb-ext-compiler-note.texinfo +@include condition-sb-ext-code-deletion-note.texinfo @node Errors During Macroexpansion @comment node-name, next, previous, up @@ -773,8 +783,8 @@ is some rudimentary documentation on the current behavior of the system. Compiler policy is controlled by the @code{optimize} declaration. The -compiler supports the ANSI optimization qualities, and also an -extension @code{sb-ext:inhibit-warnings}. +compiler supports the ANSI optimization qualities, and also a +deprecated extension @code{sb-ext:inhibit-warnings}. Ordinarily, when the @code{speed} quality is high, the compiler emits notes to notify the programmer about its inability to apply various @@ -786,28 +796,31 @@ notes about having to use generic arithmetic instead of fixnum arithmetic, which is not helpful for code which by design supports arbitrary-sized integers instead of being limited to fixnums.) -@quotation -Note: The basic functionality of the @code{optimize -inhibit-warnings} extension will probably be supported in all future -versions of the system, but it will probably be renamed when the -compiler and its interface are cleaned up. The current name is -misleading, because it mostly inhibits optimization notes, not -warnings. And making it an optimization quality is misleading, because -it shouldn't affect the resulting code at all. It may become a -declaration identifier with a name like -@code{sb-ext:inhibit-notes}, so that what's currently written. - +The recommended way to inhibit compiler diagnostics (of any severity +other than @code{error}: @pxref{Error Severity}) is to use the +@code{sb-ext:muffle-conditions} declaration, specifying the type of +condition that is to be muffled (using an associated +@code{muffle-warning} restart). Thus, what was previously written @lisp (declaim (optimize (sb-ext:inhibit-warnings 2))) @end lisp - -would become something like - +becomes something like @lisp -(declaim (sb-ext:inhibit-notes 2)) +(declaim (sb-ext:muffle-conditions sb-ext:compiler-note)) +@end lisp +to muffle all compiler notes. Compiler diagnostics can be muffled in +the lexical scope of a declaration, and also lexically unmuffled by +the use of the sb-ext:unmuffle-conditions, for instance +@lisp +(defun foo (x) + (declare (optimize speed) (fixnum x)) + (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (values (* x 5) ; no compiler note from this + (locally + (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + ;; this one gives a compiler note + (* x -5)))) @end lisp - -@end quotation In early versions of SBCL, a @code{speed} value of zero was used to enable byte compilation, but since version 0.7.0, SBCL only supports diff --git a/doc/manual/sbcl.texinfo b/doc/manual/sbcl.texinfo index 6a9ecc5..8a765ee 100644 --- a/doc/manual/sbcl.texinfo +++ b/doc/manual/sbcl.texinfo @@ -67,6 +67,7 @@ provided with absolutely no warranty. See the @file{COPYING} and * Concept Index:: * Function Index:: * Variable Index:: +* Type Index:: * Colophon:: @end menu diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index af139dc..bb19574 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -568,6 +568,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; verbosity "CODE-DELETION-NOTE" "COMPILER-NOTE" + ;; and a mechanism for controlling same at compile time + "MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS" + ;; FIXME: This name doesn't match the DEFFOO - vs. - ;; DEFINE-FOO convention used in the ANSI spec, and so ;; was deprecated in sbcl-0.pre7, ca. 2001-12-12. After diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 1de88a5..d308bdd 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -101,6 +101,7 @@ (defvar *current-path*) (defvar *current-component*) (defvar *delayed-ir1-transforms*) +(defvar *handled-conditions*) (defvar *policy*) (defvar *dynamic-counts-tn*) (defvar *elsewhere*) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 27a2cf3..6828f90 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -72,7 +72,9 @@ ;; the file position at which the top level form starts, if applicable (file-position nil :type (or index null)) ;; the original source part of the source path - (original-source-path nil :type list)) + (original-source-path nil :type list) + ;; the lexenv active at the time + (lexenv nil :type (or null lexenv))) ;;; If true, this is the node which is used as context in compiler warning ;;; messages. @@ -239,7 +241,10 @@ (declare (ignore ignore)) pos) :original-source-path - (source-path-original-source path)))))))))) + (source-path-original-source path) + :lexenv (if context + (node-lexenv context) + (if (boundp '*lexenv*) *lexenv* nil))))))))))) ;;;; printing error messages @@ -539,13 +544,27 @@ has written, having proved that it is unreachable.")) ;; Check for boundness so we don't blow up if we're called ;; when IR1 conversion isn't going on. (boundp '*lexenv*) - ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below - ;; isn't a good idea; we should have INHIBIT-WARNINGS - ;; affect compiler notes, not STYLE-WARNINGs. And I'm not - ;; sure what the BOUNDP '*LEXENV* test above is for; it's - ;; likely a good idea, but it probably deserves an - ;; explanatory comment. - (policy *lexenv* (= inhibit-warnings 3))) + (or + ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below + ;; isn't a good idea; we should have INHIBIT-WARNINGS + ;; affect compiler notes, not STYLE-WARNINGs. And I'm not + ;; sure what the BOUNDP '*LEXENV* test above is for; it's + ;; likely a good idea, but it probably deserves an + ;; explanatory comment. + (policy *lexenv* (= inhibit-warnings 3)) + ;; KLUDGE: weird decoupling between here and where we're + ;; going to signal the condition. I don't think we can + ;; rewrite this using SIGNAL and RESTART-CASE (to take + ;; advantage of the (SATISFIES HANDLE-CONDITION-P) + ;; handler, because if that doesn't handle it the ordinary + ;; compiler handlers will trigger. + (typep + (ecase kind + (:variable (make-condition 'warning)) + ((:function :type) (make-condition 'style-warning))) + (car + (rassoc 'muffle-warning + (lexenv-handled-conditions *lexenv*)))))) (let* ((found (dolist (warning *undefined-warnings* nil) (when (and (equal (undefined-warning-name warning) name) (eq (undefined-warning-kind warning) kind)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index a58d8d7..8ed61a8 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1171,6 +1171,16 @@ (make-lexenv :default res :policy (process-optimize-decl spec (lexenv-policy res)))) + (muffle-conditions + (make-lexenv + :default res + :handled-conditions (process-muffle-conditions-decl + spec (lexenv-handled-conditions res)))) + (unmuffle-conditions + (make-lexenv + :default res + :handled-conditions (process-unmuffle-conditions-decl + spec (lexenv-handled-conditions res)))) (type (process-type-decl (cdr spec) res vars)) (values diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index b86ce53..23281cb 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -538,6 +538,7 @@ type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) + (handled-conditions (lexenv-handled-conditions default)) (policy (lexenv-policy default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) @@ -550,7 +551,7 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup policy))) + lambda cleanup handled-conditions policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -579,6 +580,7 @@ (lexenv-type-restrictions lexenv) ; XXX nil nil + (lexenv-handled-conditions lexenv) (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 424eefa..f89df35 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -11,8 +11,6 @@ (in-package "SB!C") -#!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place - ;;; The LEXENV represents the lexical environment used for IR1 conversion. ;;; (This is also what shows up as an ENVIRONMENT value in macroexpansion.) #!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place @@ -28,7 +26,8 @@ (:constructor internal-make-lexenv (funs vars blocks tags type-restrictions - lambda cleanup policy))) + lambda cleanup handled-conditions + policy))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an ;; INLINE/NOTINLINE declaration, or a list (MACRO . ) (a @@ -61,8 +60,10 @@ ;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard ;; to get CLAMBDA defined in time for the cross-compiler. (lambda nil) - ;; the lexically enclosing cleanup, or NIL if none enclosing within Lambda + ;; the lexically enclosing cleanup, or NIL if none enclosing within LAMBDA (cleanup nil) + ;; condition types we handle with a handler around the compiler + (handled-conditions *handled-conditions*) ;; the current OPTIMIZE policy (policy *policy* :type policy)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index d74d3ae..47b4c92 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -805,7 +805,8 @@ ;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :policy *policy*)) + (let* ((*lexenv* (make-lexenv :policy *policy* + :handled-conditions *handled-conditions*)) (tll (ir1-toplevel form path nil))) (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*)) (t (compile-toplevel (list tll) nil))))) @@ -850,7 +851,9 @@ ;; FIXME: Ideally, something should be done so that DECLAIM ;; inside LOCALLY works OK. Failing that, at least we could ;; issue a warning instead of silently screwing up. - (*policy* (lexenv-policy *lexenv*))) + (*policy* (lexenv-policy *lexenv*)) + ;; This is probably also a hack + (*handled-conditions* (lexenv-handled-conditions *lexenv*))) (process-toplevel-progn forms path compile-time-too)))) ;;; Parse an EVAL-WHEN situations list, returning three flags, @@ -948,7 +951,8 @@ '(original-source-start 0 0))) (when name (legal-fun-name-or-type-error name)) - (let* ((*lexenv* (make-lexenv :policy *policy*)) + (let* ((*lexenv* (make-lexenv :policy *policy* + :handled-conditions *handled-conditions*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -1338,6 +1342,45 @@ (setq *block-compile* nil) (setq *entry-points* nil))) +(defun handle-condition-p (condition) + (let ((lexenv + (etypecase *compiler-error-context* + (node + (node-lexenv *compiler-error-context*)) + (compiler-error-context + (let ((lexenv (compiler-error-context-lexenv + *compiler-error-context*))) + (aver lexenv) + lexenv)) + (null *lexenv*)))) + (let ((muffles (lexenv-handled-conditions lexenv))) + (if (null muffles) ; common case + nil + (dolist (muffle muffles nil) + (destructuring-bind (typespec . restart-name) muffle + (when (and (typep condition typespec) + (find-restart restart-name condition)) + (return t)))))))) + +(defun handle-condition-handler (condition) + (let ((lexenv + (etypecase *compiler-error-context* + (node + (node-lexenv *compiler-error-context*)) + (compiler-error-context + (let ((lexenv (compiler-error-context-lexenv + *compiler-error-context*))) + (aver lexenv) + lexenv)) + (null *lexenv*)))) + (let ((muffles (lexenv-handled-conditions lexenv))) + (aver muffles) + (dolist (muffle muffles (bug "fell through")) + (destructuring-bind (typespec . restart-name) muffle + (when (typep condition typespec) + (awhen (find-restart restart-name condition) + (invoke-restart it)))))))) + ;;; Read all forms from INFO and compile them, with output to OBJECT. ;;; Return (VALUES NIL WARNINGS-P FAILURE-P). (defun sub-compile-file (info) @@ -1348,6 +1391,7 @@ (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE (*policy* *policy*) + (*handled-conditions* *handled-conditions*) (*lexenv* (make-null-lexenv)) (*block-compile* *block-compile-arg*) (*source-info* info) @@ -1372,19 +1416,20 @@ (*info-environment* *info-environment*) (*gensym-counter* 0)) (handler-case - (with-compilation-values - (sb!xc:with-compilation-unit () - (clear-stuff) - - (sub-sub-compile-file info) - - (finish-block-compilation) - (let ((object *compile-object*)) - (etypecase object - (fasl-output (fasl-dump-source-info info object)) - (core-object (fix-core-source-info info object)) - (null))) - nil)) + (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) + (with-compilation-values + (sb!xc:with-compilation-unit () + (clear-stuff) + + (sub-sub-compile-file info) + + (finish-block-compilation) + (let ((object *compile-object*)) + (etypecase object + (fasl-output (fasl-dump-source-info info object)) + (core-object (fix-core-source-info info object)) + (null))) + nil))) ;; Some errors are sufficiently bewildering that we just fail ;; immediately, without trying to recover and compile more of ;; the input file. diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 9ec12e3..47becfd 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -22,13 +22,6 @@ ;;; alists instead. (def!type policy () 'list) -;;; FIXME: the original implementation of this was protected by -;;; -;;; (eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute) -;;; -;;; but I don't know why. This seems to work, but I don't understand -;;; why the original wasn't this in the first place. -- CSR, -;;; 2003-05-04 (defstruct policy-dependent-quality name expression @@ -37,8 +30,7 @@ ;;; names of recognized optimization policy qualities (defvar *policy-qualities*) ; (initialized at cold init) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *policy-dependent-qualities* nil)) ; alist of POLICY-DEPENDENT-QUALITYs +(defvar *policy-dependent-qualities* nil) ; alist of POLICY-DEPENDENT-QUALITYs ;;; Is X the name of an optimization policy quality? (defun policy-quality-name-p (x) @@ -75,10 +67,14 @@ inhibit-warnings)) (setf *policy* (mapcar (lambda (name) - ;; CMU CL didn't use 1 as the default for everything, - ;; but since ANSI says 1 is the ordinary value, we do. + ;; CMU CL didn't use 1 as the default for + ;; everything, but since ANSI says 1 is the ordinary + ;; value, we do. (cons name 1)) - *policy-qualities*))) + *policy-qualities*)) + ;; not actually POLICY, but very similar + (setf *handled-conditions* nil)) + ;;; On the cross-compilation host, we initialize immediately (not ;;; waiting for "cold init", since cold init doesn't exist on ;;; cross-compilation host). @@ -88,6 +84,7 @@ ;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED; ;;; it's an error if it's called for a quality which isn't defined. (defun policy-quality (policy quality-name) + (aver (policy-quality-name-p quality-name)) (let* ((acons (assoc quality-name policy)) (result (or (cdr acons) 1))) result)) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 8c48392..d189c90 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -52,6 +52,12 @@ (compiler-warn "ignoring bad optimization value ~S in ~S" raw-value spec)) (t + ;; we can't do this yet, because CLOS macros expand + ;; into code containing INHIBIT-WARNINGS. + #+nil + (when (eql quality 'sb!ext:inhibit-warnings) + (compiler-style-warn "~S is deprecated: use ~S instead" + quality 'sb!ext:muffle-conditions)) (push (cons quality raw-value) result))))) ;; Add any nonredundant entries from old POLICY. @@ -61,6 +67,58 @@ ;; Voila. result)) +(declaim (ftype (function (list list) list) + process-handle-conditions-decl)) +(defun process-handle-conditions-decl (spec list) + (let ((new (copy-alist list))) + (dolist (clause (cdr spec)) + (destructuring-bind (typespec restart-name) clause + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (setf (car ospec) + (type-specifier + (type-union (specifier-type (car ospec)) + (specifier-type typespec)))) + (push (cons (type-specifier (specifier-type typespec)) + restart-name) + new))))) + new)) +(declaim (ftype (function (list list) list) + process-muffle-conditions-decl)) +(defun process-muffle-conditions-decl (spec list) + (process-handle-conditions-decl + (cons 'handle-conditions + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + list)) + +(declaim (ftype (function (list list) list) + process-unhandle-conditions-decl)) +(defun process-unhandle-conditions-decl (spec list) + (let ((new (copy-alist list))) + (dolist (clause (cdr spec)) + (destructuring-bind (typespec restart-name) clause + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (let ((type-specifier + (type-specifier + (type-intersection + (specifier-type (car ospec)) + (specifier-type `(not ,typespec)))))) + (if type-specifier + (setf (car ospec) type-specifier) + (setq new + (delete restart-name new :test #'eq :key #'cdr)))) + ;; do nothing? + nil)))) + new)) +(declaim (ftype (function (list list) list) + process-unmuffle-conditions-decl)) +(defun process-unmuffle-conditions-decl (spec list) + (process-unhandle-conditions-decl + (cons 'unhandle-conditions + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + list)) + ;;; ANSI defines the declaration (FOO X Y) to be equivalent to ;;; (TYPE FOO X Y) when FOO is a type specifier. This function ;;; implements that by converting (FOO X Y) to (TYPE FOO X Y). @@ -158,6 +216,12 @@ (setf (classoid-state subclass) :sealed)))))))) (optimize (setq *policy* (process-optimize-decl form *policy*))) + (muffle-conditions + (setq *handled-conditions* + (process-muffle-conditions-decl form *handled-conditions*))) + (unmuffle-conditions + (setq *handled-conditions* + (process-unmuffle-conditions-decl form *handled-conditions*))) ((inline notinline maybe-inline) (dolist (name args) (proclaim-as-fun-name name) ; since implicitly it is a function diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index 6838041..b031250 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -70,6 +70,8 @@ ;; 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*)) ;; 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 @@ -78,11 +80,12 @@ ;; controlled by function arguments and lexical variables. (*compile-verbose* nil) (*compile-print* nil)) - (clear-stuff) - (find-source-paths form 0) - (%compile form (make-core-object) - :name name - :path '(original-source-start 0 0)))))) + (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 compile-in-lexenv (name definition lexenv) (multiple-value-bind (compiled-definition warnings-p failure-p) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 6e4ee6d..67152a1 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -890,7 +890,24 @@ (type-error (c) (return-from return :good)))) :good)) - + +;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual) +(defvar *compiler-note-count* 0) +(handler-bind ((sb-ext:compiler-note (lambda (c) + (declare (ignore c)) + (incf *compiler-note-count*)))) + (let ((fun + (compile nil + '(lambda (x) + (declare (optimize speed) (fixnum x)) + (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (values (* x 5) ; no compiler note from this + (locally + (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + ;; this one gives a compiler note + (* x -5))))))) + (assert (= *compiler-note-count* 1)) + (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh index c7a4d57..b7f34a1 100644 --- a/tests/compiler.test.sh +++ b/tests/compiler.test.sh @@ -169,6 +169,70 @@ cat > $tmpfilename < $tmpfilename < $tmpfilename < $tmpfilename < $tmpfilename < $tmpfilename < $tmpfilename < $tmpfilename < $tmpfilename <