From: Christophe Rhodes Date: Mon, 16 Jun 2003 14:18:16 +0000 (+0000) Subject: 0.8.0.74: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ff57884e206ac28660af6af34315bc9b81697f57;p=sbcl.git 0.8.0.74: Conditionize COMPILER-NOTE ... s/COMPILER-NOTE/COMPILER-NOTIFY/ for the function ... a couple of exports in package-data-list (also move a DECLAIM from the start of a MACROLET) --- diff --git a/NEWS b/NEWS index 9effeae..82970ef 100644 --- a/NEWS +++ b/NEWS @@ -1781,6 +1781,14 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: functions defined in the same file. This also permits the system to warn on static type mismatches and function redefinition. (Currently it does not work with high DEBUG level.) + * when issuing notes, the compiler now signals a condition of type + SB-EXT:COMPILER-NOTE, and provides an associated MUFFLE-WARNING + restart for use in user handlers. It is expected that the + COMPILER-NOTE condition will eventually become a condition + supertype to a hierarchy of note types, which will then be + handleable in a similar fashion; other than + SB-INT:SIMPLE-COMPILER-NOTE, an implementation detail, no such + note subtypes yet exist. * changes in type checking closed the following bugs: ** type checking of unused values (192b, 194d, 203); ** template selection based on unsafe type assertions (192c, 236); diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 193f46e..b2cc21a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -213,6 +213,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "COMPILE-IN-LEXENV" "COMPILE-LAMBDA-FOR-DEFUN" "%COMPILER-DEFUN" "COMPILER-ERROR" + "COMPILER-NOTIFY" + "COMPILER-STYLE-WARN" "COMPILER-WARN" "COMPONENT" "COMPONENT-HEADER-LENGTH" "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUN" "COMPUTE-OLD-NFP" "COPY-MORE-ARG" @@ -248,7 +250,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "MAKE-OTHER-IMMEDIATE-TYPE" "MAKE-RANDOM-TN" "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET" "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK" - "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTE" + "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTIFY" "MAYBE-INLINE-SYNTACTIC-CLOSURE" "META-PRIMITIVE-TYPE-OR-LOSE" "META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE" @@ -548,6 +550,10 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "DEFCONSTANT-UNEQL" "DEFCONSTANT-UNEQL-NAME" "DEFCONSTANT-UNEQL-NEW-VALUE" "DEFCONSTANT-UNEQL-OLD-VALUE" + ;; conditions that can be handled to reduce compiler + ;; verbosity + "COMPILER-NOTE" + ;; 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 @@ -704,7 +710,7 @@ retained, possibly temporariliy, because it might be used internally." "SIMPLE-PROGRAM-ERROR" "SIMPLE-STREAM-ERROR" "SIMPLE-STYLE-WARNING" "SPECIAL-FORM-FUNCTION" - "STYLE-WARN" + "STYLE-WARN" "SIMPLE-COMPILER-NOTE" ;; bootstrapping magic, to make things happen both in ;; the cross-compilation host compiler's environment and diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 45d064c..440fe2d 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -169,7 +169,7 @@ (or (sb!c:maybe-inline-syntactic-closure lambda env) (progn (#+sb-xc-host warn - #-sb-xc-host sb!c:maybe-compiler-note + #-sb-xc-host sb!c:maybe-compiler-notify "lexical environment too hairy, can't inline DEFUN ~S" name) nil))))) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index ae83f97..feec05a 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -49,7 +49,7 @@ ;; slow, so if anyone cares about performance of ;; non-toplevel DEFSTRUCTs, it should be rewritten to be ;; cleverer. -- WHN 2002-10-23 - (sb!c::compiler-note + (sb!c:compiler-notify "implementation limitation: ~ Non-toplevel DEFSTRUCT constructors are slow.") (with-unique-names (layout) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index d3d8a17..9d13c97 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -487,7 +487,7 @@ (:too-hairy (let ((*compiler-error-context* cast)) (when (policy cast (>= safety inhibit-warnings)) - (compiler-note + (compiler-notify "type assertion too complex to check:~% ~S." (type-specifier (coerce-to-values (cast-asserted-type cast)))))) (setf (cast-type-to-check cast) *wild-type*) diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index c4dc579..93aeb42 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -418,7 +418,7 @@ #'types-equal-or-intersect) (*lossage-fun* #'compiler-style-warn) - (*unwinnage-fun* #'compiler-note)) + (*unwinnage-fun* #'compiler-notify)) (let* ((*lossage-detected* nil) (*unwinnage-detected* nil) (required (fun-type-required type)) @@ -766,7 +766,7 @@ (when (eq where :declared) (setf (leaf-type fun) type) (assert-definition-type fun type - :unwinnage-fun #'compiler-note + :unwinnage-fun #'compiler-notify :where "proclamation")))) ;;;; FIXME: Move to some other file. diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index f4f65bf..9ddb5aa 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -426,7 +426,7 @@ `(coerce (,',prim-quick (coerce x 'double-float)) 'single-float)) (t - (compiler-note + (compiler-notify "unable to avoid inline argument range check~@ because the argument range (~S) was not within 2^64" (type-specifier (continuation-type x))) @@ -439,7 +439,7 @@ (#.(expt 2d0 64))))) `(,',prim-quick x)) (t - (compiler-note + (compiler-notify "unable to avoid inline argument range check~@ because the argument range (~S) was not within 2^64" (type-specifier (continuation-type x))) @@ -560,11 +560,11 @@ ;; Check that the ARG bounds are correctly canonicalized. (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo) (minusp (float-sign arg-lo-val))) - (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo) + (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo) (setq arg-lo '(0e0) arg-lo-val 0e0)) (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi) (plusp (float-sign arg-hi-val))) - (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi) + (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi) (setq arg-hi `(,(ecase *read-default-float-format* (double-float (load-time-value (make-unportable-float :double-float-negative-zero))) #!+long-float diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 4a3352f..571d82c 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -137,7 +137,7 @@ inhibit-warnings)) (dolist (fun funs (let ((*compiler-error-context* (lambda-bind (first funs)))) - (compiler-note + (compiler-notify "Return value count mismatch prevents known return ~ from these functions:~ ~{~% ~A~}" @@ -150,7 +150,7 @@ (declare (ignore ignore)) (when (eq count :unknown) (let ((*compiler-error-context* (lambda-bind fun))) - (compiler-note + (compiler-notify "Return type not fixed values, so can't use known return ~ convention:~% ~S" (type-specifier rtype))) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index b4a1dbb..3fa8bd3 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -27,8 +27,8 @@ (note (transform-note (car failure)))) (cond ((consp what) - (compiler-note "~@" - note (first what) (rest what))) + (compiler-notify "~@" + note (first what) (rest what))) ((valid-fun-use node what :argument-test #'types-equal-or-intersect :result-test #'values-types-equal-or-intersect) @@ -39,10 +39,10 @@ (valid-fun-use node what :unwinnage-fun #'give-grief :lossage-fun #'give-grief)) - (compiler-note "~@" + (compiler-notify "~@" note (messages)))) ;; As best I can guess, it's OK to fall off the end here ;; because if it's not a VALID-FUNCTION-USE, the user diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 08c20ad..0cac21d 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -935,7 +935,7 @@ ;; issue a full WARNING if the call ;; violates a DECLAIM FTYPE. :lossage-fun #'compiler-style-warn - :unwinnage-fun #'compiler-note) + :unwinnage-fun #'compiler-notify) (assert-call-type call type) (maybe-terminate-block call ir1-converting-not-optimizing-p) (recognize-known-call call ir1-converting-not-optimizing-p)) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 4ef2d65..4c1f514 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -415,33 +415,52 @@ format-args))) (values)) -;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other -;;; condition-signalling functions, but it just writes some output -;;; instead of signalling. (In CMU CL, it did signal a condition, but -;;; this didn't seem to work all that well; it was weird to have -;;; COMPILE-FILE return with WARNINGS-P set when the only problem was -;;; that the compiler couldn't figure out how to compile something as -;;; efficiently as it liked.) -(defun compiler-note (format-string &rest format-args) +;;; The act of signalling one of these beasts must not cause WARNINGSP +;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't +;;; inherit from WARNING or STYLE-WARNING. +;;; +;;; 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 simple-compiler-note (simple-condition compiler-note) ()) + +(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. (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-string 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)) (values)) ;;; Issue a note when we might or might not be in the compiler. -(defun maybe-compiler-note (&rest rest) +(defun maybe-compiler-notify (&rest rest) (if (boundp '*lexenv*) ; if we're in the compiler - (apply #'compiler-note rest) - (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))) - (fresh-line stream)))) ; (outside logical block, no per-line-prefix) + (apply #'compiler-notify rest) + (progn + (restart-case + (signal (make-condition 'simple-compiler-note + :format-string (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)) + (values)))) ;;; The politically correct way to print out progress messages and ;;; such like. We clear the current error context so that we know that diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index be94415..8ed6283 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -995,7 +995,7 @@ ;; compilation unit, so we can't do that. -- WHN 2001-02-11 :lossage-fun #'compiler-style-warn :unwinnage-fun (cond (info #'compiler-style-warn) - (for-real #'compiler-note) + (for-real #'compiler-notify) (t nil)) :really-assert (and for-real diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 542dfe0..3242c40 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -431,6 +431,8 @@ ;;;; IR1-CONVERT, macroexpansion and special form dispatching +(declaim (ftype (sfunction (continuation continuation t) (values)) + ir1-convert)) (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws ;; out of the body and converts a proxy form instead. (ir1-error-bailout ((start @@ -461,7 +463,6 @@ ;; the creation using backquote of forms that contain leaf ;; references, without having to introduce dummy names into the ;; namespace. - (declaim (ftype (sfunction (continuation continuation t) (values)) ir1-convert)) (defun ir1-convert (start cont form) (ir1-error-bailout (start cont form) (let ((*current-path* (or (gethash form *source-paths*) @@ -701,7 +702,7 @@ ;; WHN 19990412 #+(and cmu sb-xc-host) (warning (lambda (c) - (compiler-note + (compiler-notify "~@<~A~:@_~ ~A~:@_~ ~@<(KLUDGE: That was a non-STYLE WARNING. ~ @@ -794,12 +795,12 @@ (let ((transform (info :function :source-transform (leaf-source-name var)))) - (if transform - (multiple-value-bind (result pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start cont form var) + (if transform + (multiple-value-bind (result pass) (funcall transform form) + (if pass + (ir1-convert-maybe-predicate start cont form var) (ir1-convert start cont result))) - (ir1-convert-maybe-predicate start cont form var)))))) + (ir1-convert-maybe-predicate start cont form var)))))) ;;; If the function has the PREDICATE attribute, and the CONT's DEST ;;; isn't an IF, then we convert (IF
T NIL), ensuring that a @@ -970,7 +971,7 @@ (found (setf (leaf-type found) type) (assert-definition-type found type - :unwinnage-fun #'compiler-note + :unwinnage-fun #'compiler-notify :where "FTYPE declaration")) (t (res (cons (find-lexically-apparent-fun @@ -1046,9 +1047,9 @@ (etypecase found (functional (when (policy *lexenv* (>= speed inhibit-warnings)) - (compiler-note "ignoring ~A declaration not at ~ - definition of local function:~% ~S" - sense name))) + (compiler-notify "ignoring ~A declaration not at ~ + definition of local function:~% ~S" + sense name))) (global-var (push (cons name (make-new-inlinep found sense)) new-fenv))))))) @@ -1140,7 +1141,7 @@ "in VALUES declaration")))) (dynamic-extent (when (policy *lexenv* (> speed inhibit-warnings)) - (compiler-note + (compiler-notify "compiler limitation: ~ ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) res) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 0a9d898..02797be 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -862,8 +862,8 @@ (return-block (and return (node-block return)))) (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) - (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-debug-name clambda)))) + (compiler-notify "deleting unused function~:[.~;~:*~% ~S~]" + (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))) @@ -1240,7 +1240,7 @@ 0))) (unless (return-p node) (let ((*compiler-error-context* node)) - (compiler-note "deleting unreachable code"))) + (compiler-notify "deleting unreachable code"))) (return)))))) (values)) @@ -1594,10 +1594,10 @@ ;; compiler to be able to use WITH-COMPILATION-UNIT on ;; arbitrarily huge blocks of code. -- WHN) (let ((*compiler-error-context* node)) - (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ - probably trying to~% ~ - inline a recursive function." - *inline-expansion-limit*)) + (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ + probably trying to~% ~ + inline a recursive function." + *inline-expansion-limit*)) nil) (t t)))) @@ -1695,7 +1695,7 @@ (policy (or node *lexenv*) (= inhibit-warnings 0))) (let ((*compiler-error-context* node)) - (compiler-note (event-info-description info)))) + (compiler-notify (event-info-description info)))) (let ((action (event-info-action info))) (when action (funcall action node)))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d4ce370..be089db 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -347,9 +347,9 @@ original-functional))))))) (cond (losing-local-functional (let ((*compiler-error-context* call)) - (compiler-note "couldn't inline expand because expansion ~ - calls this LET-converted local function:~ - ~% ~S" + (compiler-notify "couldn't inline expand because expansion ~ + calls this LET-converted local function:~ + ~% ~S" (leaf-debug-name losing-local-functional))) original-functional) (t @@ -602,7 +602,7 @@ (let ((cont (first key))) (unless (constant-continuation-p cont) (when flame - (compiler-note "non-constant keyword in keyword call")) + (compiler-notify "non-constant keyword in keyword call")) (setf (basic-combination-kind call) :error) (return-from convert-more-call)) @@ -616,7 +616,7 @@ (setq allow-found t allowp (continuation-value val))) (t (when flame - (compiler-note "non-constant :ALLOW-OTHER-KEYS value")) + (compiler-notify "non-constant :ALLOW-OTHER-KEYS value")) (setf (basic-combination-kind call) :error) (return-from convert-more-call))))) (dolist (var (key-vars) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 3929851..826b8e3 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -669,7 +669,7 @@ ;;; known type. ;;; ;;; We go to some trouble to make the whole multi-line output into a -;;; single call to COMPILER-NOTE so that repeat messages are +;;; single call to COMPILER-NOTIFY so that repeat messages are ;;; suppressed, etc. (defun note-rejected-templates (call ltn-policy template) (declare (type combination call) (type ltn-policy ltn-policy) @@ -727,16 +727,16 @@ (count 1)))) (let ((*compiler-error-context* call)) - (compiler-note "~{~?~^~&~6T~}" - (if template - `("forced to do ~A (cost ~W)" - (,(or (template-note template) - (template-name template)) - ,(template-cost template)) - . ,(messages)) - `("forced to do full call" - nil - . ,(messages)))))))) + (compiler-notify "~{~?~^~&~6T~}" + (if template + `("forced to do ~A (cost ~W)" + (,(or (template-note template) + (template-name template)) + ,(template-cost template)) + . ,(messages)) + `("forced to do full call" + nil + . ,(messages)))))))) (values)) ;;; If a function has a special-case annotation method use that, diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index f8151f2..ec70efa 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -370,15 +370,15 @@ (vop-args op-vop) (vop-results op-vop))) (error "couldn't find op? bug!"))))) - (compiler-note + (compiler-notify "doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~ the ~:R ~:[result~;argument~] of ~A" note cost name arg-p name pos arg-p op-note))) (t - (compiler-note "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]" - note cost (get-operand-name op-tn t) - (get-operand-name dest-tn nil))))) + (compiler-notify "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]" + note cost (get-operand-name op-tn t) + (get-operand-name dest-tn nil))))) (values)) ;;; Find a move VOP to move from the operand OP-TN to some other diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 82a5fa7..0d6d07f 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -569,7 +569,7 @@ (specifier-type 'function))) (when (policy *compiler-error-context* (> speed inhibit-warnings)) - (compiler-note + (compiler-notify "~S may not be a function, so must coerce at run-time." n-fun)) (once-only ((n-fun `(if (functionp ,n-fun) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 2ec8bc6..b473f7f 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -220,8 +220,8 @@ (let ((spec (hairy-type-specifier type))) (cond ((unknown-type-p type) (when (policy *lexenv* (> speed inhibit-warnings)) - (compiler-note "can't open-code test of unknown type ~S" - (type-specifier type))) + (compiler-notify "can't open-code test of unknown type ~S" + (type-specifier type))) `(%typep ,object ',spec)) (t (ecase (first spec) diff --git a/version.lisp-expr b/version.lisp-expr index 42f97f2..f2fecc3 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.0.73" +"0.8.0.74"