0.9.6.22:

[sbcl.git] / src / compiler / ir1opt.lisp

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index feadc4d..f2152d3 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -637,6 +637,14 @@
 #!+sb-show
 (defvar *show-transforms-p* nil)
 
+(defun check-important-result (node info)
+  (when (and (null (node-lvar node))
+             (ir1-attributep (fun-info-attributes info) important-result))
+    (let ((*compiler-error-context* node))
+      (compiler-style-warn
+       "The return value of ~A should not be discarded."
+       (lvar-fun-name (basic-combination-fun node))))))
+
 ;;; Do IR1 optimizations on a COMBINATION node.
 (declaim (ftype (function (combination) (values)) ir1-optimize-combination))
 (defun ir1-optimize-combination (node)
@@ -661,6 +669,17 @@
          (when arg
            (setf (lvar-reoptimize arg) nil)))
        (when info
+         (check-important-result node info)
+         (let ((fun (fun-info-destroyed-constant-args info)))
+           (when fun
+             (let ((destroyed-constant-args (funcall fun args)))
+               (when destroyed-constant-args
+                 (let ((*compiler-error-context* node))
+                   (warn 'constant-modified
+                         :fun-name (lvar-fun-name
+                                    (basic-combination-fun node)))
+                   (setf (basic-combination-kind node) :error)
+                   (return-from ir1-optimize-combination))))))
          (let ((fun (fun-info-derive-type info)))
            (when fun
              (let ((res (funcall fun node)))
@@ -672,6 +691,17 @@
        (dolist (arg args)
          (when arg
            (setf (lvar-reoptimize arg) nil)))
+       (check-important-result node info)
+       (let ((fun (fun-info-destroyed-constant-args info)))
+         (when fun
+           (let ((destroyed-constant-args (funcall fun args)))
+             (when destroyed-constant-args
+               (let ((*compiler-error-context* node))
+                 (warn 'constant-modified
+                       :fun-name (lvar-fun-name
+                                  (basic-combination-fun node)))
+                 (setf (basic-combination-kind node) :error)
+                 (return-from ir1-optimize-combination))))))
 
        (let ((attr (fun-info-attributes info)))
          (when (and (ir1-attributep attr foldable)