X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=314bb79b0932a72bc3e8d4b718d01024f92b7a4f;hb=fe5d3fcb66a417311359101a77da4a691e649622;hp=b1c09f5978dd57fa14086af74ff0f5cf7f292c4c;hpb=51344a3364f2cd6b14985719a77f697c094ea14d;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index b1c09f5..314bb79 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.
@@ -850,11 +850,15 @@
              ;; called semi-inlining? A more descriptive name would
              ;; be nice. -- WHN 2002-01-07
              (frob ()
-               (let ((res (let ((*allow-instrumenting* t))
-                            (ir1-convert-lambda-for-defun
-                             (defined-fun-inline-expansion leaf)
-                             leaf t
-                             #'ir1-convert-inline-lambda))))
+               (let* ((name (leaf-source-name leaf))
+                      (res (ir1-convert-inline-expansion
+                            name
+                            (defined-fun-inline-expansion leaf)
+                            leaf
+                            inlinep
+                            (info :function :info name))))
+                 ;; allow backward references to this function from
+                 ;; following top level forms
                  (setf (defined-fun-functional leaf) res)
                  (change-ref-leaf ref res))))
         (if ir1-converting-not-optimizing-p
@@ -1117,10 +1121,22 @@
                                 (block-next (node-block call)))
       (let ((new-fun (ir1-convert-inline-lambda
                       res
-                      :debug-name (debug-name 'lambda-inlined source-name)))
+                      :debug-name (debug-name 'lambda-inlined source-name)
+                      :system-lambda t))
             (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))
 
@@ -1500,6 +1516,9 @@
                            leaf var)))
                  t)))))
         ((and (null (rest (leaf-refs var)))
+              ;; Don't substitute single-ref variables on high-debug /
+              ;; low speed, to improve the debugging experience.
+              (policy call (< preserve-single-use-debug-variables 3))
               (substitute-single-use-lvar arg var)))
         (t
          (propagate-to-refs var (lvar-type arg))))))
@@ -1811,6 +1830,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))
@@ -1819,11 +1849,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))