From 31ddb6051e45f575129467f9ae7ed19b0b565177 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Wed, 19 Oct 2005 13:44:01 +0000
Subject: [PATCH] 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.
---
 code/error.lisp        |  10 ++-
 compiler/fndb.lisp     | 143 ++++++++++++++++++++++++++++-------------
 compiler/ir1opt.lisp   |  24 ++++++-
 compiler/knownfun.lisp |  61 ++++++++++++++++--
 4 files changed, 185 insertions(+), 53 deletions(-)

diff --git a/code/error.lisp b/code/error.lisp
index c06c742e6..b864890dd 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 27e316d91..ebdfb8122 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 600b9df58..c0dfeaaea 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 b019977e9..d5e6b130f 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)))))))
-- 
GitLab