X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f77ffec8fdaf5725f2261dee7f5c3f75de2bcc89;hb=9105a2e4a8701814db413aa9ac3c41fd79d5b4f1;hp=2bdb4dedd65aaab3ac4456f6e19f88f3d3505304;hpb=68165e850aa0700741756fead44a53642194aa39;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 2bdb4de..f77ffec 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -451,7 +451,7 @@
 ;;; appropriate.)
 ;;;
 ;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV
-;;; combination, which may change the succesor of the call to be the
+;;; combination, which may change the successor of the call to be the
 ;;; called function, and if so, checks if the call can become an
 ;;; assignment. If we convert to an assignment, we abort, since the
 ;;; RETURN has been deleted.
@@ -693,7 +693,10 @@
            (setf (lvar-reoptimize arg) nil)))
        (check-important-result node info)
        (let ((fun (fun-info-destroyed-constant-args info)))
-         (when fun
+         (when (and fun
+                    ;; If somebody is really sure that they want to modify
+                    ;; constants, let them.
+                    (policy node (> safety 0)))
            (let ((destroyed-constant-args (funcall fun args)))
              (when destroyed-constant-args
                (let ((*compiler-error-context* node))
@@ -1830,6 +1833,17 @@
 
 ;;; TODO:
 ;;; - CAST chains;
+(defun delete-cast (cast)
+  (declare (type cast cast))
+  (let ((value (cast-value cast))
+        (lvar (node-lvar cast)))
+    (delete-filter cast lvar value)
+    (when lvar
+      (reoptimize-lvar lvar)
+      (when (lvar-single-value-p lvar)
+        (note-single-valuified-lvar lvar)))
+    (values)))
+
 (defun ir1-optimize-cast (cast &optional do-not-optimize)
   (declare (type cast cast))
   (let ((value (cast-value cast))
@@ -1838,11 +1852,7 @@
       (let ((lvar (node-lvar cast)))
         (when (values-subtypep (lvar-derived-type value)
                                (cast-asserted-type cast))
-          (delete-filter cast lvar value)
-          (when lvar
-            (reoptimize-lvar lvar)
-            (when (lvar-single-value-p lvar)
-              (note-single-valuified-lvar lvar)))
+          (delete-cast cast)
           (return-from ir1-optimize-cast t))
 
         (when (and (listp (lvar-uses value))