X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1util.lisp;h=66d35aab6ae8fde32b7af5ad526b5faaf59fea98;hb=fa8962d732057015fbb9a2f8a08ea8d5299b50dd;hp=68deb1b992a8713866ad90d8e99a443493d2289e;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 68deb1b..66d35aa 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -11,9 +11,6 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") ;;;; cleanup hackery @@ -156,9 +153,10 @@ (setf (continuation-dest new) dest)) (values)) -;;; Replace all uses of Old with uses of New, where New has an arbitary -;;; number of uses. If New will end up with more than one use, then we must -;;; arrange for it to start a block if it doesn't already. +;;; Replace all uses of OLD with uses of NEW, where NEW has an +;;; arbitary number of uses. If NEW will end up with more than one +;;; use, then we must arrange for it to start a block if it doesn't +;;; already. (defun substitute-continuation-uses (new old) (declare (type continuation old new)) (unless (and (eq (continuation-kind new) :unused) @@ -168,20 +166,23 @@ (do-uses (node old) (delete-continuation-use node) (add-continuation-use node new)) + (dolist (lexenv-use (continuation-lexenv-uses old)) + (setf (cadr lexenv-use) new)) (reoptimize-continuation new) (values)) ;;;; block starting/creation -;;; Return the block that Continuation is the start of, making a block if -;;; necessary. This function is called by IR1 translators which may cause a -;;; continuation to be used more than once. Every continuation which may be -;;; used more than once must start a block by the time that anyone does a -;;; Use-Continuation on it. +;;; Return the block that CONT is the start of, making a block if +;;; necessary. This function is called by IR1 translators which may +;;; cause a continuation to be used more than once. Every continuation +;;; which may be used more than once must start a block by the time +;;; that anyone does a USE-CONTINUATION on it. ;;; ;;; We also throw the block into the next/prev list for the -;;; *current-component* so that we keep track of which blocks we have made. +;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have +;;; made. (defun continuation-starts-block (cont) (declare (type continuation cont)) (ecase (continuation-kind cont) @@ -291,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))) @@ -306,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 @@ -335,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)) @@ -889,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." @@ -1423,7 +1423,7 @@ (values '(unable to locate source) '((some strange place))))))))) -;;; Convert a source form to a string, formatted suitably for use in +;;; Convert a source form to a string, suitably formatted for use in ;;; compiler warnings. (defun stringify-form (form &optional (pretty t)) (let ((*print-level* *compiler-error-print-level*) @@ -1431,13 +1431,14 @@ (*print-lines* *compiler-error-print-lines*) (*print-pretty* pretty)) (if pretty - (format nil " ~S~%" form) + (format nil "~<~@; ~S~:>" (list form)) (prin1-to-string form)))) -;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error -;;; context, or NIL if we can't figure anything out. ARGS is a list of things -;;; that are going to be printed out in the error message, and can thus be -;;; blown off when they appear in the source context. +;;; Return a COMPILER-ERROR-CONTEXT structure describing the current +;;; error context, or NIL if we can't figure anything out. ARGS is a +;;; list of things that are going to be printed out in the error +;;; message, and can thus be blown off when they appear in the source +;;; context. (defun find-error-context (args) (let ((context *compiler-error-context*)) (if (compiler-error-context-p context) @@ -1481,8 +1482,8 @@ ;;;; printing error messages -;;; We save the context information that we printed out most recently so that -;;; we don't print it out redundantly. +;;; We save the context information that we printed out most recently +;;; so that we don't print it out redundantly. ;;; The last COMPILER-ERROR-CONTEXT that we printed. (defvar *last-error-context* nil) @@ -1494,8 +1495,8 @@ (declaim (type (or string null) *last-format-string*)) (declaim (type list *last-format-args*)) -;;; The number of times that the last error message has been emitted, so that -;;; we can compress duplicate error messages. +;;; The number of times that the last error message has been emitted, +;;; so that we can compress duplicate error messages. (defvar *last-message-count* 0) (declaim (type index *last-message-count*)) @@ -1506,18 +1507,18 @@ (cond ((= *last-message-count* 1) (when terpri (terpri *error-output*))) ((> *last-message-count* 1) - (format *error-output* "[Last message occurs ~D times.]~2%" + (format *error-output* "~&; [Last message occurs ~D times.]~2%" *last-message-count*))) (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. +;;; 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. ;;; -;;; We suppress printing of messages identical to the previous, but record -;;; the number of times that the message is repeated. +;;; We suppress printing of messages identical to the previous, but +;;; record the number of times that the message is repeated. (defun print-compiler-message (format-string format-args) (declare (type simple-string format-string)) @@ -1539,20 +1540,27 @@ (when (pathnamep file) (note-message-repeats) (setq last nil) - (format stream "~2&file: ~A~%" (namestring file)))) + (format stream "~2&; file: ~A~%" (namestring file)))) (unless (and last (equal in (compiler-error-context-context last))) (note-message-repeats) (setq last nil) - (format stream "~2&in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" in)) + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in)) + (format stream "~%")) + (unless (and last (string= form (compiler-error-context-original-source last))) (note-message-repeats) (setq last nil) - (write-string form stream)) + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream " ~A" form)) + (format stream "~&")) (unless (and last (equal enclosing @@ -1560,7 +1568,7 @@ (when enclosing (note-message-repeats) (setq last nil) - (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing))) + (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing))) (unless (and last (equal source (compiler-error-context-source last))) @@ -1568,12 +1576,16 @@ (when source (note-message-repeats) (dolist (src source) - (write-line "==>" stream) - (write-string src stream)))))) + (format stream "~&") + (write-string "; ==>" stream) + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (write-string src stream))))))) (t + (format stream "~&") (note-message-repeats) (setq *last-format-string* nil) - (format stream "~2&"))) + (format stream "~&"))) (setq *last-error-context* context) @@ -1585,7 +1597,10 @@ (let ((*print-level* *compiler-error-print-level*) (*print-length* *compiler-error-print-length*) (*print-lines* *compiler-error-print-lines*)) - (format stream "~&~?~&" format-string format-args)))) + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream "~&~?" format-string format-args)) + (format stream "~&")))) (incf *last-message-count*) (values)) @@ -1621,13 +1636,25 @@ ;;; 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)) (values)) +;;; Issue a note when we might or might not be in the compiler. +(defun maybe-compiler-note (&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) + ;;; The politically correct way to print out progress messages and ;;; such like. We clear the current error context so that we know that ;;; it needs to be reprinted, and we also Force-Output so that the @@ -1702,7 +1729,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. ;;; @@ -1710,14 +1737,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)) @@ -1799,8 +1830,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))))