X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=78ae5a8d21fd0a9fd516151a4e7b3db21b5f207f;hb=66cff1e1319861c080d563359afea284614b3a7f;hp=e820b58456f446898ed20495e89f49fb79d4b200;hpb=731da68c7e3b7f2c4bc310aa75fc75f5aead24d2;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index e820b58..78ae5a8 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -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))
@@ -840,6 +843,12 @@
              (:inline t)
              (:no-chance nil)
              ((nil :maybe-inline) (policy call (zerop space))))
+           ;; FIXME & KLUDGE: This LET-CONVERSION check was added as a
+           ;; half-assed workaround for the bug for which the test
+           ;; case :HIGH-DEBUG-KNOWN-FUNCTION-INLINING checks in
+           ;; compiler.pure.lisp. The _real_ culprit seems to be
+           ;; the insertion of BIND/UNBIND-SENTINEL vops.
+           (policy call (plusp let-conversion))
            (defined-fun-p leaf)
            (defined-fun-inline-expansion leaf)
            (let ((fun (defined-fun-functional leaf)))
@@ -1116,9 +1125,24 @@
   (aver (and (legal-fun-name-p source-name)
              (not (eql source-name '.anonymous.))))
   (node-ends-block call)
+  ;; The internal variables of a transform are not going to be
+  ;; interesting to the debugger, so there's no sense in
+  ;; suppressing the substitution of variables with only one use
+  ;; (the extra variables can slow down constraint propagation).
+  ;;
+  ;; This needs to be done before the WITH-IR1-ENVIRONMENT-FROM-NODE,
+  ;; so that it will bind *LEXENV* to the right environment.
+  (setf (combination-lexenv call)
+        (make-lexenv :default (combination-lexenv call)
+                     :policy (process-optimize-decl
+                              '(optimize
+                                (preserve-single-use-debug-variables 0))
+                              (lexenv-policy
+                                   (combination-lexenv call)))))
   (with-ir1-environment-from-node call
     (with-component-last-block (*current-component*
                                 (block-next (node-block call)))
+
       (let ((new-fun (ir1-convert-inline-lambda
                       res
                       :debug-name (debug-name 'lambda-inlined source-name)
@@ -1126,17 +1150,6 @@
             (ref (lvar-use (combination-fun call))))
         (change-ref-leaf ref new-fun)
         (setf (combination-kind call) :full)
-        ;; The internal variables of a transform are not going to be
-        ;; interesting to the debugger, so there's no sense in
-        ;; suppressing the substitution of variables with only one use
-        ;; (the extra variables can slow down constraint propagation).
-        (setf (combination-lexenv call)
-              (make-lexenv :default (combination-lexenv call)
-                           :policy (process-optimize-decl
-                                    '(optimize
-                                      (preserve-single-use-debug-variables 0))
-                                    (lexenv-policy
-                                     (combination-lexenv call)))))
         (locall-analyze-component *current-component*))))
   (values))
 
@@ -1830,6 +1843,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 +1862,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))