X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=07059073f1dc477d98469d350b1363c9b7dfcff1;hb=1d941f3d8f343f5779526b66b2358b4893a17281;hp=73eb6eead9f33fca93ad5e1356c88ed02148d2ef;hpb=f1bd97fb5f536b9ac7195aaa20bf02c829793f6a;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 73eb6ee..0705907 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -292,9 +292,9 @@ (declare (list path) (inline member)) (cadr (member 'original-source-start path :test #'eq))) -;;; Return a list of all the enclosing forms not in the original source that -;;; converted to get to this form, with the immediate source for node at the -;;; start of the list. +;;; Return a list of all the enclosing forms not in the original +;;; source that converted to get to this form, with the immediate +;;; source for node at the start of the list. (defun source-path-forms (path) (subseq path 0 (position 'original-source-start path))) @@ -307,24 +307,24 @@ (first forms) (values (find-original-source path))))) -;;; Return NODE-SOURCE-FORM, T if continuation has a single use, otherwise -;;; NIL, NIL. +;;; Return NODE-SOURCE-FORM, T if continuation has a single use, +;;; otherwise NIL, NIL. (defun continuation-source (cont) (let ((use (continuation-use cont))) (if use (values (node-source-form use) t) (values nil nil)))) -;;; Return a new LEXENV just like Default except for the specified slot -;;; values. Values for the alist slots are NCONC'ed to the beginning of the -;;; current value, rather than replacing it entirely. +;;; Return a new LEXENV just like DEFAULT except for the specified +;;; slot values. Values for the alist slots are NCONCed to the +;;; beginning of the current value, rather than replacing it entirely. (defun make-lexenv (&key (default *lexenv*) functions variables blocks tags type-restrictions options (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) - (cookie (lexenv-cookie default)) - (interface-cookie (lexenv-interface-cookie default))) + (policy (lexenv-policy default)) + (interface-policy (lexenv-interface-policy default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) (if ,var @@ -336,26 +336,25 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup cookie interface-cookie + lambda cleanup policy interface-policy (frob options lexenv-options)))) -;;; Return a cookie that defaults any unsupplied optimize qualities in the -;;; Interface-Cookie with the corresponding ones from the Cookie. -(defun make-interface-cookie (lexenv) +;;; Return a POLICY that defaults any unsupplied optimize qualities in +;;; the INTERFACE-POLICY with the corresponding ones from the POLICY. +(defun make-interface-policy (lexenv) (declare (type lexenv lexenv)) - (let ((icookie (lexenv-interface-cookie lexenv)) - (cookie (lexenv-cookie lexenv))) - (make-cookie - :speed (or (cookie-speed icookie) (cookie-speed cookie)) - :space (or (cookie-space icookie) (cookie-space cookie)) - :safety (or (cookie-safety icookie) (cookie-safety cookie)) - :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie)) - :brevity (or (cookie-brevity icookie) (cookie-brevity cookie)) - :debug (or (cookie-debug icookie) (cookie-debug cookie))))) + (let ((ipolicy (lexenv-interface-policy lexenv)) + (policy (lexenv-policy lexenv))) + (let ((result policy)) + (dolist (quality '(speed safety space)) + (let ((iquality-entry (assoc quality ipolicy))) + (when iquality-entry + (push iquality-entry result)))) + result))) ;;;; flow/DFO/component hackery -;;; Join Block1 and Block2. +;;; Join BLOCK1 and BLOCK2. #!-sb-fluid (declaim (inline link-blocks)) (defun link-blocks (block1 block2) (declare (type cblock block1 block2)) @@ -890,7 +889,7 @@ (unless (or (leaf-ever-used var) (lambda-var-ignorep var)) (let ((*compiler-error-context* (lambda-bind fun))) - (unless (policy *compiler-error-context* (= brevity 3)) + (unless (policy *compiler-error-context* (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" ;; requires this to be a STYLE-WARNING. (compiler-style-warning "The variable ~S is defined but never used." @@ -1273,8 +1272,13 @@ (declaim (special *current-path*)) -;;; We bind print level and length when printing out messages so that we don't -;;; dump huge amounts of garbage. +;;; We bind print level and length when printing out messages so that +;;; we don't dump huge amounts of garbage. +;;; +;;; FIXME: It's not possible to get the defaults right for everyone. +;;; So: Should these variables be in the SB-EXT package? Or should we +;;; just get rid of them completely and just use the bare +;;; CL:*PRINT-FOO* variables instead? (declaim (type (or unsigned-byte null) *compiler-error-print-level* *compiler-error-print-length* @@ -1513,10 +1517,10 @@ (setq *last-message-count* 0)) ;;; Print out the message, with appropriate context if we can find it. -;;; If If the context is different from the context of the last -;;; message we printed, then we print the context. If the original -;;; source is different from the source we are working on, then we -;;; print the current source in addition to the original source. +;;; If the context is different from the context of the last message +;;; we printed, then we print the context. If the original source is +;;; different from the source we are working on, then we print the +;;; current source in addition to the original source. ;;; ;;; We suppress printing of messages identical to the previous, but ;;; record the number of times that the message is repeated. @@ -1608,9 +1612,10 @@ (defun print-compiler-condition (condition) (declare (type condition condition)) - (let (;; These different classes of conditions have different effects - ;; on the return codes of COMPILE-FILE, so it's nice for users to be - ;; able to pick them out by lexical search through the output. + (let (;; These different classes of conditions have different + ;; effects on the return codes of COMPILE-FILE, so it's nice + ;; for users to be able to pick them out by lexical search + ;; through the output. (what (etypecase condition (style-warning 'style-warning) (warning 'warning) @@ -1637,8 +1642,8 @@ ;;; out how to compile something as efficiently as it liked.) (defun compiler-note (format-string &rest format-args) (unless (if *compiler-error-context* - (policy *compiler-error-context* (= brevity 3)) - (policy nil (= brevity 3))) + (policy *compiler-error-context* (= inhibit-warnings 3)) + (policy nil (= inhibit-warnings 3))) (incf *compiler-note-count*) (print-compiler-message (format nil "note: ~A" format-string) format-args)) @@ -1697,8 +1702,8 @@ (defvar *warnings-p*) ;;; condition handlers established by the compiler. We re-signal the -;;; condition, if it is not handled, we increment our warning counter -;;; and print the error message. +;;; condition, then if it isn't handled, we increment our warning +;;; counter and print the error message. (defun compiler-error-handler (condition) (signal condition) (incf *compiler-error-count*) @@ -1730,7 +1735,7 @@ problem is a missing definition (as opposed to a typo in the use.)") ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference -;;; to Name of the specified Kind. If we have exceeded the warning +;;; to NAME of the specified KIND. If we have exceeded the warning ;;; limit, then just increment the count, otherwise note the current ;;; error context. ;;; @@ -1738,14 +1743,18 @@ ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside ;;; the compiler, hence the BOUNDP check. (defun note-undefined-reference (name kind) - (unless (and (boundp '*lexenv*) - ;; FIXME: I'm pretty sure the BREVITY test below isn't - ;; a good idea; we should have BREVITY 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 nil (= brevity 3))) + (unless (and + ;; (POLICY NIL ..) isn't well-defined except in IR1 + ;; conversion. This BOUNDP test seems to be a test for + ;; whether IR1 conversion is 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 nil (= inhibit-warnings 3))) (let* ((found (dolist (warning *undefined-warnings* nil) (when (and (equal (undefined-warning-name warning) name) (eq (undefined-warning-kind warning) kind)) @@ -1827,8 +1836,8 @@ (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) (if node - (policy node (= brevity 0)) - (policy nil (= brevity 0)))) + (policy node (= inhibit-warnings 0)) + (policy nil (= inhibit-warnings 0)))) (let ((*compiler-error-context* node)) (compiler-note (event-info-description info))))