diff --git a/code/error.lisp b/code/error.lisp index c06c742e6a78391a4ae23556059f4228545a1a81..b864890ddd60eddd50a5842752608f1f6121fba7 100644 --- a/code/error.lisp +++ b/code/error.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/code/error.lisp,v 1.82 2005/10/18 13:29:12 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.83 2005/10/19 13:44:00 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -22,6 +22,7 @@ (export '(layout-invalid condition-function-name simple-control-error simple-file-error simple-program-error simple-parse-error simple-style-warning simple-undefined-function + constant-modified #+stack-checking stack-overflow #+heap-overflow-check heap-overflow)) @@ -1046,6 +1047,13 @@ (define-condition simple-undefined-function (simple-condition undefined-function) ()) +(define-condition constant-modified (warning) + ((function-name :initarg :function-name :reader constant-modified-function-name)) + (:report (lambda (c s) + (format s "~@<Destructive function ~S called on ~ + constant data.~@:>" + (constant-modified-function-name c))))) + (define-condition arithmetic-error (error) ((operation :reader arithmetic-error-operation :initarg :operation :initform nil) diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index 27e316d91654902282257d704d1611506fe291ca..ebdfb812223724d1d3722cee745e40e3c5bfffc1 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.132 2005/06/13 14:29:25 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.133 2005/10/19 13:44:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -401,8 +401,9 @@ (defknown reverse (sequence) consed-sequence (flushable) :derive-type #'result-type-first-arg/reverse) -(defknown nreverse (sequence) sequence () - :derive-type #'result-type-first-arg/reverse) +(defknown nreverse (sequence) sequence (important-result) + :derive-type #'result-type-first-arg/reverse + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown make-sequence (type-specifier index &key (:initial-element t)) consed-sequence (movable flushable unsafe) @@ -424,7 +425,8 @@ (defknown map-into (sequence callable &rest sequence) sequence (call dynamic-extent-closure-safe) - :derive-type #'result-type-first-arg) + :derive-type #'result-type-first-arg + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) ;;; Returns predicate result... (defknown some (callable sequence &rest sequence) t @@ -441,12 +443,14 @@ (defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence (unsafe) - :derive-type #'result-type-first-arg) + :derive-type #'result-type-first-arg + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown replace (sequence sequence &key (:start1 index) (:end1 sequence-end) (:start2 index) (:end2 sequence-end)) sequence () - :derive-type #'result-type-first-arg) + :derive-type #'result-type-first-arg + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown remove (t sequence &key (:from-end t) (:test callable) @@ -483,8 +487,9 @@ (:test-not callable) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call dynamic-extent-closure-safe) - :derive-type (sequence-result-nth-arg 2)) + (flushable call dynamic-extent-closure-safe important-result) + :derive-type (sequence-result-nth-arg 2) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) (defknown nsubstitute (t t sequence &key (:from-end t) (:test callable) @@ -492,21 +497,24 @@ (:count sequence-count) (:key callable)) sequence (flushable call dynamic-extent-closure-safe) - :derive-type (sequence-result-nth-arg 3)) + :derive-type (sequence-result-nth-arg 3) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 3)) (defknown (delete-if delete-if-not) (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call dynamic-extent-closure-safe) - :derive-type (sequence-result-nth-arg 2)) + (flushable call dynamic-extent-closure-safe important-result) + :derive-type (sequence-result-nth-arg 2) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) (defknown (nsubstitute-if nsubstitute-if-not) (t callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence (flushable call dynamic-extent-closure-safe) - :derive-type (sequence-result-nth-arg 3)) + :derive-type (sequence-result-nth-arg 3) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 3)) (defknown remove-duplicates (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) @@ -519,8 +527,9 @@ (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) sequence - (flushable call dynamic-extent-closure-safe) - :derive-type (sequence-result-nth-arg 1)) + (flushable call dynamic-extent-closure-safe important-result) + :derive-type (sequence-result-nth-arg 1) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown find (t sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) @@ -567,13 +576,15 @@ ;;; Not flushable, since vector sort guaranteed in-place... (defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence (call dynamic-extent-closure-safe) - :derive-type (sequence-result-nth-arg 1)) + :derive-type (sequence-result-nth-arg 1) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown merge (type-specifier sequence sequence callable &key (:key callable)) sequence - (flushable call dynamic-extent-closure-safe) - :derive-type (result-type-specifier-nth-arg 1)) + (flushable call dynamic-extent-closure-safe important-result) + :derive-type (result-type-specifier-nth-arg 1) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2 3)) (defknown read-sequence (sequence stream &key (:start index) (:end sequence-end) @@ -616,25 +627,40 @@ (defknown copy-alist (list) list (flushable)) (defknown copy-tree (t) t (flushable)) (defknown revappend (list t) t (flushable)) -(defknown nconc (&rest t) t ()) -(defknown nreconc (list t) list ()) +(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 butlast (list &optional unsigned-byte) list (flushable)) -(defknown nbutlast (list &optional unsigned-byte) list ()) +(defknown nbutlast (list &optional unsigned-byte) list () + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown ldiff (list t) list (flushable)) -(defknown (rplaca rplacd) (cons t) list (unsafe)) +(defknown (rplaca rplacd) (cons t) list (unsafe) + :destroyed-constant-args (nth-constant-args 1)) + +(defknown subst (t t t &key (:key callable) (:test callable) + (:test-not callable)) + t (flushable unsafe call)) -(defknown (nsubst subst) (t t t &key (:key callable) (:test callable) +(defknown (nsubst) (t t t &key (:key callable) (:test callable) (:test-not callable)) - list (flushable unsafe call dynamic-extent-closure-safe)) + list (flushable unsafe call dynamic-extent-closure-safe) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 3)) (defknown (subst-if subst-if-not nsubst-if nsubst-if-not) (t t t &key (:key callable)) - list (flushable unsafe call dynamic-extent-closure-safe)) + list (flushable unsafe call dynamic-extent-closure-safe) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 3)) -(defknown (sublis nsublis) (list t &key (:key callable) (:test callable) +(defknown (sublis) (list t &key (:key callable) (:test callable) (:test-not callable)) list (flushable unsafe call dynamic-extent-closure-safe)) +(defknown nsublis (list t &key (:key callable) (:test callable) + (:test-not callable)) + t (flushable unsafe call) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) + (defknown member (t list &key (:key callable) (:test callable) (:test-not callable)) list (foldable flushable call dynamic-extent-closure-safe)) @@ -655,7 +681,8 @@ (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)) + (foldable flushable call dynamic-extent-closure-safe important-result) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1 2)) (defknown subsetp (list list &key (:key callable) (:test callable) (:test-not callable)) @@ -673,7 +700,8 @@ (foldable flushable call dynamic-extent-closure-safe)) (defknown (memq assq) (t list) list (foldable flushable unsafe)) -(defknown delq (t list) list (flushable unsafe)) +(defknown delq (t list) list (flushable unsafe) + :destroyed-constant-args (nth-constant-nonempty-sequence-args 2)) ;;;; In the "Hash Tables" chapter: @@ -688,11 +716,14 @@ (defknown hash-table-p (t) boolean (movable foldable flushable)) (defknown gethash (t hash-table &optional t) (values t boolean) (foldable flushable unsafe)) -(defknown %puthash (t hash-table t) t (unsafe)) -(defknown remhash (t hash-table) boolean ()) +(defknown %puthash (t hash-table t) t (unsafe) + :destroyed-constant-args (nth-constant-args 2)) +(defknown remhash (t hash-table) boolean () + :destroyed-constant-args (nth-constant-args 2)) (defknown maphash (callable hash-table) null (foldable flushable call dynamic-extent-closure-safe)) -(defknown clrhash (hash-table) hash-table ()) +(defknown clrhash (hash-table) hash-table () + :destroyed-constant-args (nth-constant-args 1)) (defknown hash-table-count (hash-table) index (foldable flushable)) (defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0))) (foldable flushable)) @@ -732,6 +763,7 @@ (defknown bit ((array bit) &rest index) bit (foldable flushable)) (defknown sbit ((simple-array bit) &rest index) bit (foldable flushable)) +;;; FIXME: :DESTROYED-CONSTANT-ARGS for these is complicated. (defknown (bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1 bit-orc2) ((array bit) (array bit) &optional (or (array bit) (member nil t))) @@ -746,10 +778,16 @@ (defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable)) (defknown fill-pointer (vector) index (foldable flushable)) -(defknown vector-push (t vector) (or index null) ()) -(defknown vector-push-extend (t vector &optional index) index ()) -(defknown vector-pop (vector) t ()) - +(defknown vector-push (t vector) (or index null) () + :destroyed-constant-args (nth-constant-args 2)) +(defknown vector-push-extend (t vector &optional index) index () + :destroyed-constant-args (nth-constant-args 2)) +(defknown vector-pop (vector) t () + :destroyed-constant-args (nth-constant-args 1)) + +;;; FIXME: complicated :DESTROYED-CONSTANT-ARGS +;;; Also, an important-result warning could be provided if the array +;;; is known to be not expressly adjustable. (defknown adjust-array (array (or index list) &key (:element-type type-specifier) (:initial-element t) (:initial-contents t) @@ -793,7 +831,8 @@ (defknown (nstring-upcase nstring-downcase nstring-capitalize) (string &key (:start index) (:end sequence-end)) - string ()) + string () + :destroyed-constant-args (nth-constant-nonempty-sequence-args 1)) (defknown string (stringable) string (flushable explicit-check)) @@ -939,6 +978,7 @@ (defknown write-byte (integer stream) integer (explicit-check)) +;;; FIXME: complicated :DESTROYED-CONSTANT-ARGS (defknown format ((or streamlike string) (or string function) &rest t) (or string null) (explicit-check)) @@ -1201,25 +1241,36 @@ ;;;; Setf inverses: -(defknown %aset (array &rest t) t (unsafe)) -(defknown %set-row-major-aref (array index t) t (unsafe)) -(defknown %rplaca (cons t) t (unsafe)) +(defknown %aset (array &rest t) t (unsafe) + :destroyed-constant-args (nth-constant-args 1)) +(defknown %set-row-major-aref (array index t) t (unsafe) + :destroyed-constant-args (nth-constant-args 1)) +(defknown %rplaca (cons t) t (unsafe) + :destroyed-constant-args (nth-constant-args 1)) (defknown %rplacd (cons t) t (unsafe)) (defknown %put (symbol t t) t (unsafe)) -(defknown %setelt (sequence index t) t (unsafe)) -(defknown %svset (simple-vector index t) t (unsafe)) -(defknown %bitset ((array bit) &rest index) bit (unsafe)) -(defknown %sbitset ((simple-array bit) &rest index) bit (unsafe)) -(defknown %charset (string index character) character (unsafe)) -(defknown %scharset (simple-string index character) character (unsafe)) +(defknown %setelt (sequence index t) t (unsafe) + :destroyed-constant-args (nth-constant-args 1)) +(defknown %svset (simple-vector index t) t (unsafe) + :destroyed-constant-args (nth-constant-args 1)) +(defknown %bitset ((array bit) &rest index) bit (unsafe) + :destroyed-constant-args (nth-constant-args 1)) +(defknown %sbitset ((simple-array bit) &rest index) bit (unsafe) + :destroyed-constant-args (nth-constant-args 1)) +(defknown %charset (string index character) character (unsafe) + :destroyed-constant-args (nth-constant-args 1)) +(defknown %scharset (simple-string index character) character (unsafe) + :destroyed-constant-args (nth-constant-args 1)) (defknown %set-symbol-value (symbol t) t (unsafe)) (defknown fset (symbol function) function (unsafe)) (defknown %set-symbol-plist (symbol t) t (unsafe)) (defknown (setf documentation) ((or string null) t symbol) (or string null) ()) -(defknown %setnth (index list t) t (unsafe)) -(defknown %set-fill-pointer (vector index) index (unsafe)) +(defknown %setnth (index list t) t (unsafe) + :destroyed-constant-args (nth-constant-args 2)) +(defknown %set-fill-pointer (vector index) index (unsafe) + :destroyed-constant-args (nth-constant-args 1)) ;;;; Internal type predicates: diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index 600b9df58424fb5c092459321457116d8feefa32..c0dfeaaea06f78877b2d77284fce1ad9620de40a 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.83 2004/08/30 14:55:38 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.84 2005/10/19 13:44:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -754,6 +754,15 @@ (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: @@ -785,6 +794,19 @@ (when arg (setf (continuation-reoptimize arg) nil))) + (check-important-result node kind) + + (let ((fun (function-info-destroyed-constant-args kind))) + (when fun + (let ((destroyed-constant-args (funcall fun args))) + (when destroyed-constant-args + (let ((*compiler-error-context* node)) + (warn 'kernel:constant-modified + :function-name (continuation-function-name + (basic-combination-fun node))) + (setf (basic-combination-kind node) :error) + (return-from ir1-optimize-combination)))))) + (let ((attr (function-info-attributes kind))) (when (and (ir1-attributep attr foldable) (not (ir1-attributep attr call)) diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp index b019977e9db757630b51d832bc2df73d5a2ebf7e..d5e6b130fcb581b1c2e231636b1012a64e69ac10 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.27 2005/03/22 14:33:53 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.28 2005/10/19 13:44:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -80,7 +80,12 @@ explicit-check ;; ;; Safe to stack-allocate function args that are closures. - dynamic-extent-closure-safe) + 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 (:print-function %print-function-info) @@ -129,7 +134,11 @@ ;; 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))) + (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)) + ) (defprinter function-info (transforms :test transforms) @@ -201,13 +210,14 @@ ;;; Make a function-info structure with the specified type, attributes and ;;; optimizers. ;;; -(defun %defknown (names type attributes &key derive-type optimizer) +(defun %defknown (names type attributes &key derive-type optimizer destroyed-constant-args) (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)) + :optimizer optimizer + :destroyed-constant-args destroyed-constant-args)) (target-env (or (backend-info-environment *target-backend*) *info-environment*))) (dolist (name names) @@ -383,3 +393,44 @@ (eq if-does-not-exist nil)) (specifier-type `(or null ,class)) (specifier-type class)))) + +(defun remove-non-constants-and-nils (fun) + (lambda (list) + (remove-if-not #'continuation-value + (remove-if-not #'constant-continuation-p (funcall fun list))))) + +;;; FIXME: bad name (first because it uses 1-based indexing; second +;;; because it doesn't get the nth constant arguments) +(defun nth-constant-args (&rest indices) + (lambda (list) + (let (result) + (do ((i 1 (1+ i)) + (list list (cdr list)) + (indices indices)) + ((null indices) (nreverse result)) + (when (= i (car indices)) + (when (constant-continuation-p (car list)) + (push (car list) result)) + (setf indices (cdr indices))))))) + +;;; FIXME: a number of the sequence functions not only do not destroy +;;; their argument if it is empty, but also leave it alone if :start +;;; and :end bound a null sequence, or if :count is 0. This test is a +;;; bit complicated to implement, verging on the impossible, but for +;;; extra points (fill #\1 "abc" :start 0 :end 0) should not cause a +;;; warning. +(defun nth-constant-nonempty-sequence-args (&rest indices) + (lambda (list) + (let (result) + (do ((i 1 (1+ i)) + (list list (cdr list)) + (indices indices)) + ((null indices) + (nreverse result)) + (when (= i (car indices)) + (when (constant-continuation-p (car list)) + (let ((value (continuation-value (car list)))) + (unless (or (typep value 'null) + (typep value '(vector * 0))) + (push (car list) result)))) + (setf indices (cdr indices)))))))