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);
"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"
"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"
"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
"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
(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)))))
;; 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)
(: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*)
#'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))
(when (eq where :declared)
(setf (leaf-type fun) type)
(assert-definition-type fun type
- :unwinnage-fun #'compiler-note
+ :unwinnage-fun #'compiler-notify
:where "proclamation"))))
\f
;;;; FIXME: Move to some other file.
`(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)))
(#.(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)))
;; 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
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~}"
(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)))
(note (transform-note (car failure))))
(cond
((consp what)
- (compiler-note "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
- note (first what) (rest what)))
+ (compiler-notify "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
+ note (first what) (rest what)))
((valid-fun-use node what
:argument-test #'types-equal-or-intersect
:result-test #'values-types-equal-or-intersect)
(valid-fun-use node what
:unwinnage-fun #'give-grief
:lossage-fun #'give-grief))
- (compiler-note "~@<unable to ~
- ~2I~_~A ~
- ~I~_due to type uncertainty: ~
- ~2I~_~{~?~^~@:_~}~:>"
+ (compiler-notify "~@<unable to ~
+ ~2I~_~A ~
+ ~I~_due to type uncertainty: ~
+ ~2I~_~{~?~^~@:_~}~:>"
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
;; 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))
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
;; 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
\f
;;;; 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
;; 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*)
;; WHN 19990412
#+(and cmu sb-xc-host)
(warning (lambda (c)
- (compiler-note
+ (compiler-notify
"~@<~A~:@_~
~A~:@_~
~@<(KLUDGE: That was a non-STYLE WARNING. ~
(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 <form> T NIL), ensuring that a
(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
(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)))))))
"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)
(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)))
0)))
(unless (return-p node)
(let ((*compiler-error-context* node))
- (compiler-note "deleting unreachable code")))
+ (compiler-notify "deleting unreachable code")))
(return))))))
(values))
;; 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))))
\f
(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))))
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
(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))
(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)
;;; 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)
(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,
(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
(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)
(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)
;;; 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"
projects / sbcl.git / commitdiff