From ec85d43264b8ed9dc236023b09e3ab8938c249ed Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Wed, 9 Nov 2005 01:50:44 +0000
Subject: [PATCH] Change how the important-result stuff is implemented.  We no
 longer use an IR1 attribute but allow arbitrary functions to determine if the
 result is used or not.  This allows us to handle SORT and ADJUST-ARRAY
 depending on the args.

Use 19c/boot-2005-11-1.lisp to bootstrap this change.

compiler/knownfun.lisp:
o Remove IMPORTANT-RESULT attribute.
o Add new slot to function-info the hold the function to indicate if
  the result is not used.
o Adjust %defknown with a new keyword arg :result-not-used for the new
  slot.
o Add functions for the result-not-used arg for
  o SORT-RESULT-NOT-USED-P: non-NIL if the sequence might be a list.
  o ADJUST-ARRAY-RESULT-NOT-USED-P: non-NIL if the array is not known
    to be adjustable.
  o FUNCTION-RESULT-NOT-USED-P:  non-NIL if function result must be
    used (for functions like nreverse).

compiler/ir1opt.lisp:
o Remove now unused function CHECK-IMPORTANT-RESULT
o Add check in IR1-OPTIMIZE-COMBINATION to see if function result
  should be used.

compiler/fndb.lisp:
o Remove IMPORTANT-RESULT attribute and replace with :result-not-used.
---
 bootfiles/19c/boot-2005-11-1.lisp | 121 ++++++++++++++++++++++++++++++
 compiler/fndb.lisp                |  43 ++++++-----
 compiler/ir1opt.lisp              |  19 ++---
 compiler/knownfun.lisp            |  50 +++++++++---
 4 files changed, 196 insertions(+), 37 deletions(-)
 create mode 100644 bootfiles/19c/boot-2005-11-1.lisp

diff --git a/bootfiles/19c/boot-2005-11-1.lisp b/bootfiles/19c/boot-2005-11-1.lisp
new file mode 100644
index 000000000..869107008
--- /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 ebdfb8122..d8249701e 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 c0dfeaaea..c8af5a390 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 d5e6b130f..5e2164f8f 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))))
-- 
GitLab