diff --git a/bootfiles/19c/boot-2005-11-1.lisp b/bootfiles/19c/boot-2005-11-1.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8691070084358b1e10cb6def82e26a831abf56d3 --- /dev/null +++ b/bootfiles/19c/boot-2005-11-1.lisp @@ -0,0 +1,121 @@ +(in-package :C) + +(setf lisp::*enable-package-locked-errors* nil) + +(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (def-boolean-attribute ir1 + ;; + ;; May call functions that are passed as arguments. In order to determine + ;; what other effects are present, we must find the effects of all arguments + ;; that may be functions. + call + ;; + ;; May incorporate function or number arguments into the result or somehow + ;; pass them upward. Note that this applies to any argument that *might* be + ;; a function or number, not just the arguments that always are. + unsafe + ;; + ;; May fail to return during correct execution. Errors are O.K. + unwind + ;; + ;; The (default) worst case. Includes all the other bad things, plus any + ;; other possible bad thing. If this is present, the above bad attributes + ;; will be explicitly present as well. + any + ;; + ;; May be constant-folded. The function has no side effects, but may be + ;; affected by side effects on the arguments. e.g. SVREF, MAPC. Functions + ;; that side-effect their arguments are not considered to be foldable. + ;; Although it would be "legal" to constant fold them (since it "is an error" + ;; to modify a constant), we choose not to mark theses functions as foldable + ;; in this database. + foldable + ;; + ;; May be eliminated if value is unused. The function has no side effects + ;; except possibly CONS. If a function is defined to signal errors, then it + ;; is not flushable even if it is movable or foldable. + flushable + ;; + ;; May be moved with impunity. Has no side effects except possibly CONS, and + ;; is affected only by its arguments. + movable + ;; + ;; Function is a true predicate likely to be open-coded. Convert any + ;; non-conditional uses into (IF <pred> T NIL). + predicate + ;; + ;; Inhibit any warning for compiling a recursive definition. [Normally the + ;; compiler warns when compiling a recursive definition for a known function, + ;; since it might be a botched interpreter stub.] + recursive + ;; + ;; Function does explicit argument type checking, so the declared type should + ;; not be asserted when a definition is compiled. + explicit-check + ;; + ;; Safe to stack-allocate function args that are closures. + dynamic-extent-closure-safe + )) + +(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::clobber-it)))) + + (defstruct (function-info + (:print-function %print-function-info) + (:pure t)) + ;; + ;; Boolean attributes of this function. + (attributes (required-argument) :type attributes) + ;; + ;; A list of Transform structures describing transforms for this function. + (transforms () :type list) + ;; + ;; A function which computes the derived type for a call to this function by + ;; examining the arguments. This is null when there is no special method for + ;; this function. + (derive-type nil :type (or function null)) + ;; + ;; A function that does random unspecified code transformations by directly + ;; hacking the IR. Returns true if further optimizations of the call + ;; shouldn't be attempted. + (optimizer nil :type (or function null)) + ;; + ;; If true, a special-case LTN annotation method that is used in place of the + ;; standard type/policy template selection. It may use arbitrary code to + ;; choose a template, decide to do a full call, or conspire with the + ;; IR2-Convert method to do almost anything. The Combination node is passed + ;; as the argument. + (ltn-annotate nil :type (or function null)) + ;; + ;; If true, the special-case IR2 conversion method for this function. This + ;; deals with funny functions, and anything else that can't be handled using + ;; the template mechanism. The Combination node and the IR2-Block are passed + ;; as arguments. + (ir2-convert nil :type (or function null)) + ;; + ;; A list of all the templates that could be used to translate this function + ;; into IR2, sorted by increasing cost. + (templates nil :type list) + ;; + ;; If non-null, then this function is a unary type predicate for this type. + (predicate-type nil :type (or ctype null)) + ;; + ;; If non-null, use this function to annotate the known call for the byte + ;; compiler. If it returns NIL, then change the call to :full. + (byte-annotate nil :type (or function null)) + ;; + ;; If non-null, use this function to generate the byte code for this known + ;; call. This function can only give up if there is a byte-annotate function + ;; that arranged for the functional to be pushed onto the stack. + (byte-compile nil :type (or function null)) + ;; A function computing the constant or literal arguments which are + ;; destructively modified by the call. + (destroyed-constant-args nil :type (or function null)) + ;; If non-null, use this function to determine if the result of the + ;; function is used or not. This is used to detect if you used a + ;; destructive function but didn't use the result of the function. + (result-not-used nil :type (or function null)) + )) diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index ebdfb812223724d1d3722cee745e40e3c5bfffc1..d8249701eaf3fdfacf39932fc21c06a95d26251e 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.133 2005/10/19 13:44:01 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.134 2005/11/09 01:48:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -401,9 +401,10 @@ (defknown reverse (sequence) consed-sequence (flushable) :derive-type #'result-type-first-arg/reverse) -(defknown nreverse (sequence) sequence (important-result) +(defknown nreverse (sequence) sequence () :derive-type #'result-type-first-arg/reverse - :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1) + :result-not-used #'function-result-not-used-p) (defknown make-sequence (type-specifier index &key (:initial-element t)) consed-sequence (movable flushable unsafe) @@ -487,9 +488,10 @@ (:test-not callable) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call dynamic-extent-closure-safe important-result) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 2) - :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2) + :result-not-used #'function-result-not-used-p) (defknown nsubstitute (t t sequence &key (:from-end t) (:test callable) @@ -504,9 +506,10 @@ (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call dynamic-extent-closure-safe important-result) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 2) - :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2) + :result-not-used #'function-result-not-used-p) (defknown (nsubstitute-if nsubstitute-if-not) (t callable sequence &key (:from-end t) (:start index) (:end sequence-end) @@ -527,9 +530,10 @@ (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) sequence - (flushable call dynamic-extent-closure-safe important-result) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 1) - :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1) + :result-not-used #'function-result-not-used-p) (defknown find (t sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) @@ -577,14 +581,16 @@ (defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence (call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 1) - :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1) + :result-not-used #'sort-result-not-used-p) (defknown merge (type-specifier sequence sequence callable &key (:key callable)) sequence - (flushable call dynamic-extent-closure-safe important-result) + (flushable call dynamic-extent-closure-safe) :derive-type (result-type-specifier-nth-arg 1) - :destroyed-constant-args (nth-constant-nonempty-sequence-args 2 3)) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2 3) + :result-not-used #'function-result-not-used-p) (defknown read-sequence (sequence stream &key (:start index) (:end sequence-end) @@ -629,8 +635,9 @@ (defknown revappend (list t) t (flushable)) (defknown nconc (&rest t) t () :destroyed-constant-args (remove-non-constants-and-nils #'butlast)) -(defknown nreconc (list t) list (important-result) - :destroyed-constant-args (nth-constant-nonempty-sequence-args 1) ) +(defknown nreconc (list t) list () + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1) + :result-not-used #'function-result-not-used-p) (defknown butlast (list &optional unsigned-byte) list (flushable)) (defknown nbutlast (list &optional unsigned-byte) list () :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) @@ -681,8 +688,9 @@ (defknown (nunion nintersection nset-difference nset-exclusive-or) (list list &key (:key callable) (:test callable) (:test-not callable)) list - (foldable flushable call dynamic-extent-closure-safe important-result) - :destroyed-constant-args (nth-constant-nonempty-sequence-args 1 2)) + (foldable flushable call dynamic-extent-closure-safe) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1 2) + :result-not-used #'function-result-not-used-p) (defknown subsetp (list list &key (:key callable) (:test callable) (:test-not callable)) @@ -793,7 +801,8 @@ (:initial-element t) (:initial-contents t) (:fill-pointer t) (:displaced-to (or array null)) (:displaced-index-offset index)) - array (unsafe)) + array (unsafe) + :result-not-used #'adjust-array-result-not-used-p) ; :derive-type 'result-type-arg1) Not even close... diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index c0dfeaaea06f78877b2d77284fce1ad9620de40a..c8af5a3905d83751e5b5e3494cf31e8cd4678f9f 100644 --- a/compiler/ir1opt.lisp +++ b/compiler/ir1opt.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.84 2005/10/19 13:44:01 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.85 2005/11/09 01:48:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -754,15 +754,6 @@ (dolist (merge (merges)) (merge-tail-sets merge)))))))) -(defun check-important-result (node kind) - (let ((attr (function-info-attributes kind))) - (when (and attr - (ir1-attributep attr important-result) - (null (continuation-dest (node-cont node)))) - (let ((*compiler-error-context* node)) - (compiler-warning "The return value of ~A should not be discarded." - (continuation-function-name (basic-combination-fun node))))))) - ;;;; Combination IR1 optimization: @@ -794,7 +785,13 @@ (when arg (setf (continuation-reoptimize arg) nil))) - (check-important-result node kind) + (let ((fun (function-info-result-not-used kind))) + (when fun + (let ((unused-result (funcall fun node))) + (when unused-result + (let ((*compiler-error-context* node)) + (compiler-warning "The return value of ~A should not be discarded." + (continuation-function-name (basic-combination-fun node)))))))) (let ((fun (function-info-destroyed-constant-args kind))) (when fun diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp index d5e6b130fcb581b1c2e231636b1012a64e69ac10..5e2164f8fbbd9ec4411d9ee03ab2c7014e799c2e 100644 --- a/compiler/knownfun.lisp +++ b/compiler/knownfun.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.28 2005/10/19 13:44:01 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.29 2005/11/09 01:48:22 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -81,10 +81,6 @@ ;; ;; Safe to stack-allocate function args that are closures. dynamic-extent-closure-safe - ;; Return value is important and ignoring it is probably a mistake. - ;; This is for things like not using the result of nreverse. This - ;; is only for warnings and has no effect on optimization. - important-result ) (defstruct (function-info @@ -135,9 +131,18 @@ ;; call. This function can only give up if there is a byte-annotate function ;; that arranged for the functional to be pushed onto the stack. (byte-compile nil :type (or function null)) - ;; A function computing the constant or literal arguments which are - ;; destructively modified by the call. + ;; + ;; If non-null, use this function to determine if constant or + ;; literal arguments are destructively modified by the call. A list + ;; of the Basic-combination-args for the node is passed to the + ;; function. (destroyed-constant-args nil :type (or function null)) + ;; + ;; If non-null, use this function to determine if the result of the + ;; function is used or not. This is used to detect if you used a + ;; destructive function but didn't use the result of the function. + ;; The Combination node is passed to the function. + (result-not-used nil :type (or function null)) ) (defprinter function-info @@ -210,14 +215,16 @@ ;;; Make a function-info structure with the specified type, attributes and ;;; optimizers. ;;; -(defun %defknown (names type attributes &key derive-type optimizer destroyed-constant-args) +(defun %defknown (names type attributes &key derive-type optimizer + destroyed-constant-args result-not-used) (declare (list names type) (type attributes attributes) (type (or function null) derive-type optimizer)) (let ((ctype (specifier-type type)) (info (make-function-info :attributes attributes :derive-type derive-type :optimizer optimizer - :destroyed-constant-args destroyed-constant-args)) + :destroyed-constant-args destroyed-constant-args + :result-not-used result-not-used)) (target-env (or (backend-info-environment *target-backend*) *info-environment*))) (dolist (name names) @@ -434,3 +441,28 @@ (typep value '(vector * 0))) (push (car list) result)))) (setf indices (cdr indices))))))) + +(defun sort-result-not-used-p (node) + (let* ((args (combination-args node)) + (seq-type (continuation-type (first args)))) + ;; Make sure we use the result of SORT if the sequence could be a + ;; list. + (csubtypep (specifier-type 'list) seq-type))) + +(defun function-result-not-used-p (node) + ;; Is the result of the function used? + (null (continuation-dest (node-cont node)))) + +(defun adjust-array-result-aux (node) + (let* ((args (combination-args node)) + (array-type (continuation-type (first args)))) + ;; Unless the array is known to be an adjustable array, we should + ;; warn if we don't use the result of adjust-array. + (not (eql (array-type-complexp array-type) t)))) + +(defun adjust-array-result-not-used-p (node) + (let* ((args (combination-args node)) + (array-type (continuation-type (first args)))) + ;; Unless the array is known to be an adjustable array, we should + ;; warn if we don't use the result of adjust-array. + (not (eql (array-type-complexp array-type) t))))