Microoptimise TN-LEXICAL-DEPTH

[sbcl.git] / src / compiler / pack.lisp

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index 3e5a57d..16ea3ab 100644 (file)
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -1351,13 +1351,14 @@
           (let ((locations (sc-locations sc)))
             (when optimize
               (setf locations
-                    (stable-sort (copy-list locations) #'>
-                                 :key (lambda (location-offset)
-                                        (loop for offset from location-offset
-                                              repeat element-size
-                                              maximize (svref
-                                                        (finite-sb-always-live-count sb)
-                                                        offset))))))
+                    (schwartzian-stable-sort-list
+                     locations '>
+                     :key (lambda (location-offset)
+                            (loop for offset from location-offset
+                                  repeat element-size
+                                  maximize (svref
+                                            (finite-sb-always-live-count sb)
+                                            offset))))))
             (dolist (offset locations)
               (when (or use-reserved-locs
                         (not (member offset
@@ -1374,6 +1375,15 @@
 \f
 ;;;; pack interface
 
+;; Misc. utilities
+(declaim (inline unbounded-sc-p))
+(defun unbounded-sc-p (sc)
+  (eq (sb-kind (sc-sb sc)) :unbounded))
+
+(defun unbounded-tn-p (tn)
+  (unbounded-sc-p (tn-sc tn)))
+(declaim (notinline unbounded-sc-p))
+
 ;;; Attempt to pack TN in all possible SCs, first in the SC chosen by
 ;;; representation selection, then in the alternate SCs in the order
 ;;; they were specified in the SC definition. If the TN-COST is
@@ -1536,9 +1546,10 @@
 (defun tn-lexical-depth (tn)
   (let ((path t)) ; dummy initial value
     (labels ((path (lambda)
-               (nreverse (loop while lambda
-                               collect lambda
-                               do (setf lambda (lambda-parent lambda)))))
+               (do ((acc '())
+                    (lambda lambda (lambda-parent lambda)))
+                   ((null lambda) acc)
+                 (push lambda acc)))
              (register-scope (lambda)
                (let ((new-path (path lambda)))
                  (setf path (if (eql path t)
@@ -1547,11 +1558,10 @@
                                         0 (mismatch path new-path))))))
              (walk-tn-refs (ref)
                (do ((ref ref (tn-ref-next ref)))
-                   ((null ref))
-                 (binding* ((node (vop-node (tn-ref-vop ref))
-                                  :exit-if-null))
-                   (register-scope (lexenv-lambda
-                                    (node-lexenv node)))))))
+                   ((or (null ref)
+                        (null path)))
+                 (awhen (vop-node (tn-ref-vop ref))
+                   (register-scope (lexenv-lambda (node-lexenv it)))))))
       (walk-tn-refs (tn-reads tn))
       (walk-tn-refs (tn-writes tn))
       (if (eql path t)