X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=4944949a4eb66534f674d0fd1b5eb9c6f3798084;hb=85483d976cc2d779493985f77f39efefb2ea622b;hp=feadc4d5324954f9d5e4bfb3c626e86f07915ddc;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index feadc4d..4944949 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -661,6 +661,15 @@
          (when arg
            (setf (lvar-reoptimize arg) nil)))
        (when info
+         (let ((fun (fun-info-destroyed-constant-args info)))
+           (when fun
+             (let ((destroyed-constant-args (funcall fun args)))
+               (when destroyed-constant-args
+                 (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)))
@@ -673,6 +682,16 @@
          (when arg
            (setf (lvar-reoptimize arg) nil)))
 
+       (let ((fun (fun-info-destroyed-constant-args info)))
+         (when fun
+           (let ((destroyed-constant-args (funcall fun args)))
+             (when destroyed-constant-args
+               (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)
                     ;; KLUDGE: The next test could be made more sensitive,