X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=b30b86d3a38fedfda23bd7b4869689b71b51ad8c;hb=ba39d165a0bb6fabba6d6feb9b6fb88ae4d544ff;hp=51ebd365afced58a524190f262935102e1653848;hpb=a21899ff055c5c31184b277c01e52dafae4e5aa8;p=sbcl.git

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index 51ebd36..b30b86d 100644
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -1351,7 +1351,7 @@
 ;;; If we are attempting to pack in the SC of the save TN for a TN
 ;;; with a :SPECIFIED-SAVE TN, then we pack in that location, instead
 ;;; of allocating a new stack location.
-(defun pack-tn (tn restricted optimize)
+(defun pack-tn (tn restricted optimize &key (allow-unbounded-sc t))
   (declare (type tn tn))
   (let* ((original (original-tn tn))
          (fsc (tn-sc tn))
@@ -1364,12 +1364,15 @@
     (do ((sc fsc (pop alternates)))
         ((null sc)
          (failed-to-pack-error tn restricted))
+      (unless (or allow-unbounded-sc
+                  (neq (sb-kind (sc-sb sc)) :unbounded))
+        (return nil))
       (when (eq sc specified-save-sc)
         (unless (tn-offset save)
           (pack-tn save nil optimize))
         (setf (tn-offset tn) (tn-offset save))
         (setf (tn-sc tn) (tn-sc save))
-        (return))
+        (return t))
       (when (or restricted
                 (not (and (minusp (tn-cost tn)) (sc-save-p sc))))
         (let ((loc (or (find-ok-target-offset original sc)
@@ -1384,7 +1387,7 @@
             (add-location-conflicts original sc loc optimize)
             (setf (tn-sc tn) sc)
             (setf (tn-offset tn) loc)
-            (return))))))
+            (return t))))))
   (values))
 
 ;;; Pack a wired TN, checking that the offset is in bounds for the SB,
@@ -1496,6 +1499,31 @@
         (setf (finite-sb-live-tns sb)
               (make-array size :initial-element nil))))))
 
+(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)))))
+             (register-scope (lambda)
+               (let ((new-path (path lambda)))
+                 (setf path (if (eql path t)
+                                new-path
+                                (subseq path
+                                        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)))))))
+      (walk-tn-refs (tn-reads tn))
+      (walk-tn-refs (tn-writes tn))
+      (if (eql path t)
+          most-positive-fixnum
+          (length path)))))
+
 (defun pack (component)
   (unwind-protect
        (let ((optimize nil)
@@ -1551,7 +1579,8 @@
            (assign-tn-depths component))
 
          ;; Allocate normal TNs, starting with the TNs that are used
-         ;; in deep loops.
+         ;; in deep loops.  Only allocate in finite SCs (i.e. not on
+         ;; the stack).
          (collect ((tns))
            (do-ir2-blocks (block component)
              (let ((ltns (ir2-block-local-tns block)))
@@ -1566,7 +1595,7 @@
                      ;; well revert to the old behaviour of just
                      ;; packing TNs linearly as they appear.
                      (unless *loop-analyze*
-                       (pack-tn tn nil optimize))
+                       (pack-tn tn nil optimize :allow-unbounded-sc nil))
                      (tns tn))))))
            (dolist (tn (stable-sort (tns)
                                     (lambda (a b)
@@ -1579,14 +1608,36 @@
                                          (> (tn-cost a) (tn-cost b)))
                                         (t nil)))))
              (unless (tn-offset tn)
-               (pack-tn tn nil optimize))))
-
-         ;; Pack any leftover normal TNs. This is to deal with :MORE TNs,
-         ;; which could possibly not appear in any local TN map.
-         (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
-             ((null tn))
-           (unless (tn-offset tn)
-             (pack-tn tn nil optimize)))
+               (pack-tn tn nil optimize :allow-unbounded-sc nil))))
+
+         ;; Pack any leftover normal TNs that could not be allocated
+         ;; to finite SCs, or TNs that do not appear in any local TN
+         ;; map (e.g. :MORE TNs).  Since we'll likely be allocating
+         ;; on the stack, first allocate TNs that are associated with
+         ;; code at shallow lexical depths: this will allocate long
+         ;; live ranges (i.e. TNs with more conflicts) first, and
+         ;; hopefully minimise stack fragmentation.
+         ;;
+         ;; Collect in reverse order to give priority to older TNs.
+         (let ((contiguous-tns '())
+               (tns '()))
+           (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
+               ((null tn))
+             (unless (tn-offset tn)
+               (let ((key (cons tn (tn-lexical-depth tn))))
+                 (if (memq (tn-kind tn) '(:environment :debug-environment
+                                          :component))
+                     (push key contiguous-tns)
+                     (push key tns)))))
+           (flet ((pack-tns (tns)
+                    (dolist (tn (stable-sort tns #'< :key #'cdr))
+                      (let ((tn (car tn)))
+                        (unless (tn-offset tn)
+                          (pack-tn tn nil optimize))))))
+             ;; first pack TNs that are known to have simple
+             ;; live ranges (contiguous lexical scopes)
+             (pack-tns contiguous-tns)
+             (pack-tns tns)))
 
          ;; Do load TN packing and emit saves.
          (let ((*repack-blocks* nil))