Skip to content
Snippets Groups Projects
Commit 31ddb605 authored by rtoy's avatar rtoy
Browse files

Port SBCL'S support for detecting when destructive functions (such as

nreverse) modify constant args and for warning when the result of
destructive functions is not used.

Detecting modification of constant args is done by adding a new IR1
transformation that checks that a function is not destructively
modifying constants or literals.

A new IR1 attribute, important-result, is used to determine if the
result of a function should be used instead of discarded.  (Note:
this means some functions are not detected.  This should probably be
implemented as another transform so the compiler can detect those cases.)

code/error.lisp:
o Add new condition CONSTANT-MODIFIED.

compiler/fndb.lisp:
o Note destructive functions that should not modify constant args
o Note destructive functions whose results should be used.

compiler/ir1opt.lisp:
o Add new function CHECK-IMPORTANT-RESULT to check if the result is
  used.
o Update IR1-OPTIMIZE-COMBINATION to check if a function destructively
  modifies constant args or if the result of a destructive function is
  not used.

compiler/knownfun.lisp:
o Add new IR1 attribute, IMPORTANT-RESULT, to indicate that the result
  of a function should be used.
o Add new FUNCTION-INFO slot, DESTROYED-CONSTANT-ARGS.  This holds a
  function for computing the constant or literal arguments which are
  destructively modified by the function.
o Add support functions for DESTROYED-CONSTANT-ARGS functions.
parent ebda7384
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -22,6 +22,7 @@
(export '(layout-invalid condition-function-name simple-control-error (export '(layout-invalid condition-function-name simple-control-error
simple-file-error simple-program-error simple-parse-error simple-file-error simple-program-error simple-parse-error
simple-style-warning simple-undefined-function simple-style-warning simple-undefined-function
constant-modified
#+stack-checking stack-overflow #+stack-checking stack-overflow
#+heap-overflow-check heap-overflow)) #+heap-overflow-check heap-overflow))
...@@ -1046,6 +1047,13 @@ ...@@ -1046,6 +1047,13 @@
(define-condition simple-undefined-function (simple-condition (define-condition simple-undefined-function (simple-condition
undefined-function) ()) 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) (define-condition arithmetic-error (error)
((operation :reader arithmetic-error-operation :initarg :operation ((operation :reader arithmetic-error-operation :initarg :operation
:initform nil) :initform nil)
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -401,8 +401,9 @@
(defknown reverse (sequence) consed-sequence (flushable) (defknown reverse (sequence) consed-sequence (flushable)
:derive-type #'result-type-first-arg/reverse) :derive-type #'result-type-first-arg/reverse)
(defknown nreverse (sequence) sequence () (defknown nreverse (sequence) sequence (important-result)
:derive-type #'result-type-first-arg/reverse) :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 (defknown make-sequence (type-specifier index &key (:initial-element t)) consed-sequence
(movable flushable unsafe) (movable flushable unsafe)
...@@ -424,7 +425,8 @@ ...@@ -424,7 +425,8 @@
(defknown map-into (sequence callable &rest sequence) (defknown map-into (sequence callable &rest sequence)
sequence sequence
(call dynamic-extent-closure-safe) (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... ;;; Returns predicate result...
(defknown some (callable sequence &rest sequence) t (defknown some (callable sequence &rest sequence) t
...@@ -441,12 +443,14 @@ ...@@ -441,12 +443,14 @@
(defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence (defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence
(unsafe) (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) (defknown replace (sequence sequence &key (:start1 index) (:end1 sequence-end)
(:start2 index) (:end2 sequence-end)) (:start2 index) (:end2 sequence-end))
sequence () sequence ()
:derive-type #'result-type-first-arg) :derive-type #'result-type-first-arg
:destroyed-constant-args (nth-constant-nonempty-sequence-args 1))
(defknown remove (defknown remove
(t sequence &key (:from-end t) (:test callable) (t sequence &key (:from-end t) (:test callable)
...@@ -483,8 +487,9 @@ ...@@ -483,8 +487,9 @@
(:test-not callable) (:start index) (:end sequence-end) (:test-not callable) (:start index) (:end sequence-end)
(:count sequence-count) (:key callable)) (:count sequence-count) (:key callable))
sequence sequence
(flushable call dynamic-extent-closure-safe) (flushable call dynamic-extent-closure-safe important-result)
:derive-type (sequence-result-nth-arg 2)) :derive-type (sequence-result-nth-arg 2)
:destroyed-constant-args (nth-constant-nonempty-sequence-args 2))
(defknown nsubstitute (defknown nsubstitute
(t t sequence &key (:from-end t) (:test callable) (t t sequence &key (:from-end t) (:test callable)
...@@ -492,21 +497,24 @@ ...@@ -492,21 +497,24 @@
(:count sequence-count) (:key callable)) (:count sequence-count) (:key callable))
sequence sequence
(flushable call dynamic-extent-closure-safe) (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) (defknown (delete-if delete-if-not)
(callable sequence &key (:from-end t) (:start index) (:end sequence-end) (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
(:count sequence-count) (:key callable)) (:count sequence-count) (:key callable))
sequence sequence
(flushable call dynamic-extent-closure-safe) (flushable call dynamic-extent-closure-safe important-result)
:derive-type (sequence-result-nth-arg 2)) :derive-type (sequence-result-nth-arg 2)
:destroyed-constant-args (nth-constant-nonempty-sequence-args 2))
(defknown (nsubstitute-if nsubstitute-if-not) (defknown (nsubstitute-if nsubstitute-if-not)
(t callable sequence &key (:from-end t) (:start index) (:end sequence-end) (t callable sequence &key (:from-end t) (:start index) (:end sequence-end)
(:count sequence-count) (:key callable)) (:count sequence-count) (:key callable))
sequence sequence
(flushable call dynamic-extent-closure-safe) (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 (defknown remove-duplicates
(sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t)
...@@ -519,8 +527,9 @@ ...@@ -519,8 +527,9 @@
(sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t)
(:end sequence-end) (:key callable)) (:end sequence-end) (:key callable))
sequence sequence
(flushable call dynamic-extent-closure-safe) (flushable call dynamic-extent-closure-safe important-result)
:derive-type (sequence-result-nth-arg 1)) :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) (defknown find (t sequence &key (:test callable) (:test-not callable)
(:start index) (:from-end t) (:end sequence-end) (:key callable)) (:start index) (:from-end t) (:end sequence-end) (:key callable))
...@@ -567,13 +576,15 @@ ...@@ -567,13 +576,15 @@
;;; Not flushable, since vector sort guaranteed in-place... ;;; Not flushable, since vector sort guaranteed in-place...
(defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence (defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence
(call dynamic-extent-closure-safe) (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 (defknown merge (type-specifier sequence sequence callable
&key (:key callable)) &key (:key callable))
sequence sequence
(flushable call dynamic-extent-closure-safe) (flushable call dynamic-extent-closure-safe important-result)
:derive-type (result-type-specifier-nth-arg 1)) :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) (defknown read-sequence (sequence stream &key (:start index)
(:end sequence-end) (:end sequence-end)
...@@ -616,25 +627,40 @@ ...@@ -616,25 +627,40 @@
(defknown copy-alist (list) list (flushable)) (defknown copy-alist (list) list (flushable))
(defknown copy-tree (t) t (flushable)) (defknown copy-tree (t) t (flushable))
(defknown revappend (list t) t (flushable)) (defknown revappend (list t) t (flushable))
(defknown nconc (&rest t) t ()) (defknown nconc (&rest t) t ()
(defknown nreconc (list t) list ()) :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 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 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)) (: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) (defknown (subst-if subst-if-not nsubst-if nsubst-if-not)
(t t t &key (:key callable)) (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)) (:test-not callable))
list (flushable unsafe call dynamic-extent-closure-safe)) 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) (defknown member (t list &key (:key callable) (:test callable)
(:test-not callable)) (:test-not callable))
list (foldable flushable call dynamic-extent-closure-safe)) list (foldable flushable call dynamic-extent-closure-safe))
...@@ -655,7 +681,8 @@ ...@@ -655,7 +681,8 @@
(defknown (nunion nintersection nset-difference nset-exclusive-or) (defknown (nunion nintersection nset-difference nset-exclusive-or)
(list list &key (:key callable) (:test callable) (:test-not callable)) (list list &key (:key callable) (:test callable) (:test-not callable))
list 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) (defknown subsetp (list list &key (:key callable) (:test callable)
(:test-not callable)) (:test-not callable))
...@@ -673,7 +700,8 @@ ...@@ -673,7 +700,8 @@
(foldable flushable call dynamic-extent-closure-safe)) (foldable flushable call dynamic-extent-closure-safe))
(defknown (memq assq) (t list) list (foldable flushable unsafe)) (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: ;;;; In the "Hash Tables" chapter:
...@@ -688,11 +716,14 @@ ...@@ -688,11 +716,14 @@
(defknown hash-table-p (t) boolean (movable foldable flushable)) (defknown hash-table-p (t) boolean (movable foldable flushable))
(defknown gethash (t hash-table &optional t) (values t boolean) (defknown gethash (t hash-table &optional t) (values t boolean)
(foldable flushable unsafe)) (foldable flushable unsafe))
(defknown %puthash (t hash-table t) t (unsafe)) (defknown %puthash (t hash-table t) t (unsafe)
(defknown remhash (t hash-table) boolean ()) :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 (defknown maphash (callable hash-table) null
(foldable flushable call dynamic-extent-closure-safe)) (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-count (hash-table) index (foldable flushable))
(defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0))) (defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0)))
(foldable flushable)) (foldable flushable))
...@@ -732,6 +763,7 @@ ...@@ -732,6 +763,7 @@
(defknown bit ((array bit) &rest index) bit (foldable flushable)) (defknown bit ((array bit) &rest index) bit (foldable flushable))
(defknown sbit ((simple-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 (defknown (bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
bit-orc1 bit-orc2) bit-orc1 bit-orc2)
((array bit) (array bit) &optional (or (array bit) (member nil t))) ((array bit) (array bit) &optional (or (array bit) (member nil t)))
...@@ -746,10 +778,16 @@ ...@@ -746,10 +778,16 @@
(defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable)) (defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable))
(defknown fill-pointer (vector) index (foldable flushable)) (defknown fill-pointer (vector) index (foldable flushable))
(defknown vector-push (t vector) (or index null) ()) (defknown vector-push (t vector) (or index null) ()
(defknown vector-push-extend (t vector &optional index) index ()) :destroyed-constant-args (nth-constant-args 2))
(defknown vector-pop (vector) t ()) (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 (defknown adjust-array
(array (or index list) &key (:element-type type-specifier) (array (or index list) &key (:element-type type-specifier)
(:initial-element t) (:initial-contents t) (:initial-element t) (:initial-contents t)
...@@ -793,7 +831,8 @@ ...@@ -793,7 +831,8 @@
(defknown (nstring-upcase nstring-downcase nstring-capitalize) (defknown (nstring-upcase nstring-downcase nstring-capitalize)
(string &key (:start index) (:end sequence-end)) (string &key (:start index) (:end sequence-end))
string ()) string ()
:destroyed-constant-args (nth-constant-nonempty-sequence-args 1))
(defknown string (stringable) string (defknown string (stringable) string
(flushable explicit-check)) (flushable explicit-check))
...@@ -939,6 +978,7 @@ ...@@ -939,6 +978,7 @@
(defknown write-byte (integer stream) integer (defknown write-byte (integer stream) integer
(explicit-check)) (explicit-check))
;;; FIXME: complicated :DESTROYED-CONSTANT-ARGS
(defknown format ((or streamlike string) (or string function) &rest t) (defknown format ((or streamlike string) (or string function) &rest t)
(or string null) (or string null)
(explicit-check)) (explicit-check))
...@@ -1201,25 +1241,36 @@ ...@@ -1201,25 +1241,36 @@
;;;; Setf inverses: ;;;; Setf inverses:
(defknown %aset (array &rest t) t (unsafe)) (defknown %aset (array &rest t) t (unsafe)
(defknown %set-row-major-aref (array index t) t (unsafe)) :destroyed-constant-args (nth-constant-args 1))
(defknown %rplaca (cons t) t (unsafe)) (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 %rplacd (cons t) t (unsafe))
(defknown %put (symbol t t) t (unsafe)) (defknown %put (symbol t t) t (unsafe))
(defknown %setelt (sequence index t) t (unsafe)) (defknown %setelt (sequence index t) t (unsafe)
(defknown %svset (simple-vector index t) t (unsafe)) :destroyed-constant-args (nth-constant-args 1))
(defknown %bitset ((array bit) &rest index) bit (unsafe)) (defknown %svset (simple-vector index t) t (unsafe)
(defknown %sbitset ((simple-array bit) &rest index) bit (unsafe)) :destroyed-constant-args (nth-constant-args 1))
(defknown %charset (string index character) character (unsafe)) (defknown %bitset ((array bit) &rest index) bit (unsafe)
(defknown %scharset (simple-string index character) character (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 %set-symbol-value (symbol t) t (unsafe))
(defknown fset (symbol function) function (unsafe)) (defknown fset (symbol function) function (unsafe))
(defknown %set-symbol-plist (symbol t) t (unsafe)) (defknown %set-symbol-plist (symbol t) t (unsafe))
(defknown (setf documentation) ((or string null) t symbol) (defknown (setf documentation) ((or string null) t symbol)
(or string null) (or string null)
()) ())
(defknown %setnth (index list t) t (unsafe)) (defknown %setnth (index list t) t (unsafe)
(defknown %set-fill-pointer (vector index) index (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: ;;;; Internal type predicates:
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -754,6 +754,15 @@
(dolist (merge (merges)) (dolist (merge (merges))
(merge-tail-sets merge)))))))) (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: ;;;; Combination IR1 optimization:
...@@ -785,6 +794,19 @@ ...@@ -785,6 +794,19 @@
(when arg (when arg
(setf (continuation-reoptimize arg) nil))) (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))) (let ((attr (function-info-attributes kind)))
(when (and (ir1-attributep attr foldable) (when (and (ir1-attributep attr foldable)
(not (ir1-attributep attr call)) (not (ir1-attributep attr call))
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -80,7 +80,12 @@
explicit-check explicit-check
;; ;;
;; Safe to stack-allocate function args that are closures. ;; 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 (defstruct (function-info
(:print-function %print-function-info) (:print-function %print-function-info)
...@@ -129,7 +134,11 @@ ...@@ -129,7 +134,11 @@
;; If non-null, use this function to generate the byte code for this known ;; 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 ;; 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. ;; 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 (defprinter function-info
(transforms :test transforms) (transforms :test transforms)
...@@ -201,13 +210,14 @@ ...@@ -201,13 +210,14 @@
;;; Make a function-info structure with the specified type, attributes and ;;; Make a function-info structure with the specified type, attributes and
;;; optimizers. ;;; 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) (declare (list names type) (type attributes attributes)
(type (or function null) derive-type optimizer)) (type (or function null) derive-type optimizer))
(let ((ctype (specifier-type type)) (let ((ctype (specifier-type type))
(info (make-function-info :attributes attributes (info (make-function-info :attributes attributes
:derive-type derive-type :derive-type derive-type
:optimizer optimizer)) :optimizer optimizer
:destroyed-constant-args destroyed-constant-args))
(target-env (or (backend-info-environment *target-backend*) (target-env (or (backend-info-environment *target-backend*)
*info-environment*))) *info-environment*)))
(dolist (name names) (dolist (name names)
...@@ -383,3 +393,44 @@ ...@@ -383,3 +393,44 @@
(eq if-does-not-exist nil)) (eq if-does-not-exist nil))
(specifier-type `(or null ,class)) (specifier-type `(or null ,class))
(specifier-type 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)))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment