X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=2bdb4dedd65aaab3ac4456f6e19f88f3d3505304;hb=2063c1c13530ea18bf93cfaedb03bab755ea8970;hp=df05a08eb90ea1fa3bfd9e8a61377b7e8837fbb4;hpb=62b6c13eaaefa20b790e10a28d292e1821cd4446;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index df05a08..2bdb4de 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -724,17 +724,30 @@
 
        (let ((fun (fun-info-optimizer info)))
          (unless (and fun (funcall fun node))
-           (dolist (x (fun-info-transforms info))
-             #!+sb-show
-             (when *show-transforms-p*
-               (let* ((lvar (basic-combination-fun node))
-                      (fname (lvar-fun-name lvar t)))
-                 (/show "trying transform" x (transform-function x) "for" fname)))
-             (unless (ir1-transform node x)
-               #!+sb-show
-               (when *show-transforms-p*
-                 (/show "quitting because IR1-TRANSFORM result was NIL"))
-               (return))))))))
+           ;; First give the VM a peek at the call
+           (multiple-value-bind (style transform)
+               (combination-implementation-style node)
+             (ecase style
+               (:direct
+                ;; The VM knows how to handle this.
+                )
+               (:transform
+                ;; The VM mostly knows how to handle this.  We need
+                ;; to massage the call slightly, though.
+                (transform-call node transform (combination-fun-source-name node)))
+               (:default
+                ;; Let transforms have a crack at it.
+                (dolist (x (fun-info-transforms info))
+                  #!+sb-show
+                  (when *show-transforms-p*
+                    (let* ((lvar (basic-combination-fun node))
+                           (fname (lvar-fun-name lvar t)))
+                      (/show "trying transform" x (transform-function x) "for" fname)))
+                  (unless (ir1-transform node x)
+                    #!+sb-show
+                    (when *show-transforms-p*
+                      (/show "quitting because IR1-TRANSFORM result was NIL"))
+                    (return)))))))))))
 
   (values))
 
@@ -837,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
@@ -1104,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))
 
@@ -1487,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))))))