- (loc-confs (svref (finite-sb-conflicts sb) this-offset))
- (loc-live (svref (finite-sb-always-live sb) this-offset)))
- (cond
- ((eq kind :component)
- (dotimes (num (ir2-block-count *component-being-compiled*))
- (declare (type index num))
- (setf (sbit loc-live num) 1)
- (set-bit-vector (svref loc-confs num))))
- (confs
- (do ((conf confs (global-conflicts-next-tnwise conf)))
- ((null conf))
- (let* ((block (global-conflicts-block conf))
- (num (ir2-block-number block))
- (local-confs (svref loc-confs num)))
- (declare (type local-tn-bit-vector local-confs))
- (setf (sbit loc-live num) 1)
- (if (eq (global-conflicts-kind conf) :live)
- (set-bit-vector local-confs)
- (bit-ior local-confs (global-conflicts-conflicts conf) t)))))
- (t
- (let ((num (ir2-block-number (tn-local tn))))
- (setf (sbit loc-live num) 1)
- (bit-ior (the local-tn-bit-vector (svref loc-confs num))
- (tn-local-conflicts tn) t))))
- ;; Calculating ALWAYS-LIVE-COUNT is moderately expensive, and
- ;; currently the information isn't used unless (> SPEED
- ;; COMPILE-SPEED).
- (when optimize
- (setf (svref (finite-sb-always-live-count sb) this-offset)
- (find-location-usage sb this-offset))))))
+ (loc-confs (svref (finite-sb-conflicts sb) this-offset))
+ (loc-live (svref (finite-sb-always-live sb) this-offset)))
+ (cond
+ ((eq kind :component)
+ (dotimes (num (ir2-block-count *component-being-compiled*))
+ (declare (type index num))
+ (setf (sbit loc-live num) 1)
+ (set-bit-vector (svref loc-confs num))))
+ (confs
+ (do ((conf confs (global-conflicts-next-tnwise conf)))
+ ((null conf))
+ (let* ((block (global-conflicts-block conf))
+ (num (ir2-block-number block))
+ (local-confs (svref loc-confs num)))
+ (declare (type local-tn-bit-vector local-confs))
+ (setf (sbit loc-live num) 1)
+ (if (eq (global-conflicts-kind conf) :live)
+ (set-bit-vector local-confs)
+ (bit-ior local-confs (global-conflicts-conflicts conf) t)))))
+ (t
+ (let ((num (ir2-block-number (tn-local tn))))
+ (setf (sbit loc-live num) 1)
+ (bit-ior (the local-tn-bit-vector (svref loc-confs num))
+ (tn-local-conflicts tn) t))))
+ ;; Calculating ALWAYS-LIVE-COUNT is moderately expensive, and
+ ;; currently the information isn't used unless (> SPEED
+ ;; COMPILE-SPEED).
+ (when optimize
+ (setf (svref (finite-sb-always-live-count sb) this-offset)
+ (find-location-usage sb this-offset))))))
- (let* ((conflicts (finite-sb-conflicts sb))
- (always-live (finite-sb-always-live sb))
- (always-live-count (finite-sb-always-live-count sb))
- (max-locs (length conflicts))
- (last-count (finite-sb-last-block-count sb)))
- (unless (zerop max-locs)
- (let ((current-size (length (the simple-vector
- (svref conflicts 0)))))
- (cond
- ((> nblocks current-size)
- (let ((new-size (max nblocks (* current-size 2))))
- (declare (type index new-size))
- (dotimes (i max-locs)
- (declare (type index i))
- (let ((new-vec (make-array new-size)))
- (let ((old (svref conflicts i)))
- (declare (simple-vector old))
- (dotimes (j current-size)
- (declare (type index j))
- (setf (svref new-vec j)
- (clear-bit-vector (svref old j)))))
-
- (do ((j current-size (1+ j)))
- ((= j new-size))
- (declare (type index j))
- (setf (svref new-vec j)
- (make-array local-tn-limit :element-type 'bit
- :initial-element 0)))
- (setf (svref conflicts i) new-vec))
- (setf (svref always-live i)
- (make-array new-size :element-type 'bit
- :initial-element 0))
- (setf (svref always-live-count i) 0))))
- (t
- (dotimes (i (finite-sb-current-size sb))
- (declare (type index i))
- (let ((conf (svref conflicts i)))
- (declare (simple-vector conf))
- (dotimes (j last-count)
- (declare (type index j))
- (clear-bit-vector (svref conf j))))
- (clear-bit-vector (svref always-live i))
- (setf (svref always-live-count i) 0))))))
-
- (setf (finite-sb-last-block-count sb) nblocks)
- (setf (finite-sb-current-size sb) (sb-size sb))
- (setf (finite-sb-last-offset sb) 0))))))
+ (let* ((conflicts (finite-sb-conflicts sb))
+ (always-live (finite-sb-always-live sb))
+ (always-live-count (finite-sb-always-live-count sb))
+ (max-locs (length conflicts))
+ (last-count (finite-sb-last-block-count sb)))
+ (unless (zerop max-locs)
+ (let ((current-size (length (the simple-vector
+ (svref conflicts 0)))))
+ (cond
+ ((> nblocks current-size)
+ (let ((new-size (max nblocks (* current-size 2))))
+ (declare (type index new-size))
+ (dotimes (i max-locs)
+ (declare (type index i))
+ (let ((new-vec (make-array new-size)))
+ (let ((old (svref conflicts i)))
+ (declare (simple-vector old))
+ (dotimes (j current-size)
+ (declare (type index j))
+ (setf (svref new-vec j)
+ (clear-bit-vector (svref old j)))))
+
+ (do ((j current-size (1+ j)))
+ ((= j new-size))
+ (declare (type index j))
+ (setf (svref new-vec j)
+ (make-array local-tn-limit :element-type 'bit
+ :initial-element 0)))
+ (setf (svref conflicts i) new-vec))
+ (setf (svref always-live i)
+ (make-array new-size :element-type 'bit
+ :initial-element 0))
+ (setf (svref always-live-count i) 0))))
+ (t
+ (dotimes (i (finite-sb-current-size sb))
+ (declare (type index i))
+ (let ((conf (svref conflicts i)))
+ (declare (simple-vector conf))
+ (dotimes (j last-count)
+ (declare (type index j))
+ (clear-bit-vector (svref conf j))))
+ (clear-bit-vector (svref always-live i))
+ (setf (svref always-live-count i) 0))))))
+
+ (setf (finite-sb-last-block-count sb) nblocks)
+ (setf (finite-sb-current-size sb) (sb-size sb))
+ (setf (finite-sb-last-offset sb) 0))))))
- ((null vop))
- (let ((info (vop-info vop)))
- (case (vop-info-name info)
- (allocate-frame
- (aver skipping)
- (setq skipping nil))
- (note-environment-start
- (aver (not skipping))
- (dolist (save saves-list)
- (save-if-necessary save (vop-next vop) vop))
- (return-from optimized-emit-saves-block block)))
-
- (unless skipping
- (do ((write (vop-results vop) (tn-ref-across write)))
- ((null write))
- (let* ((tn (tn-ref-tn write))
- (num (tn-number tn)))
- (unless (zerop (sbit restores num))
- (setf (sbit restores num) 0)
- (setq restores-list
- (delete tn restores-list :test #'eq)))
- (unless (zerop (sbit saves num))
- (setf (sbit saves num) 0)
- (save-if-necessary tn (vop-next vop) vop)
- (setq saves-list
- (delete tn saves-list :test #'eq))))))
-
- (macrolet (;; Do stuff to note a read of TN, for
- ;; OPTIMIZED-EMIT-SAVES-BLOCK.
- (save-note-read (tn)
- `(let* ((tn ,tn)
- (num (tn-number tn)))
- (when (and (sc-save-p (tn-sc tn))
- (zerop (sbit restores num))
- (not (eq (tn-kind tn) :component)))
- (setf (sbit restores num) 1)
- (push tn restores-list)))))
-
- (case (vop-info-save-p info)
- ((t)
- (dolist (tn restores-list)
- (restore-tn tn (vop-next vop) vop)
- (let ((num (tn-number tn)))
- (when (zerop (sbit saves num))
- (push tn saves-list)
- (setf (sbit saves num) 1))))
- (setq restores-list nil)
- (clear-bit-vector restores))
- (:compute-only
- (cond ((policy (vop-node vop) (= speed 3))
- (do-live-tns (tn (vop-save-set vop) block)
- (when (zerop (sbit restores (tn-number tn)))
- (note-spilled-tn tn vop))))
- (t
- (do-live-tns (tn (vop-save-set vop) block)
- (save-note-read tn))))))
-
- (if (eq (vop-info-move-args info) :local-call)
- (setq skipping t)
- (do ((read (vop-args vop) (tn-ref-across read)))
- ((null read))
- (save-note-read (tn-ref-tn read))))))))))
+ ((null vop))
+ (let ((info (vop-info vop)))
+ (case (vop-info-name info)
+ (allocate-frame
+ (aver skipping)
+ (setq skipping nil))
+ (note-environment-start
+ (aver (not skipping))
+ (dolist (save saves-list)
+ (save-if-necessary save (vop-next vop) vop))
+ (return-from optimized-emit-saves-block block)))
+
+ (unless skipping
+ (do ((write (vop-results vop) (tn-ref-across write)))
+ ((null write))
+ (let* ((tn (tn-ref-tn write))
+ (num (tn-number tn)))
+ (unless (zerop (sbit restores num))
+ (setf (sbit restores num) 0)
+ (setq restores-list
+ (delete tn restores-list :test #'eq)))
+ (unless (zerop (sbit saves num))
+ (setf (sbit saves num) 0)
+ (save-if-necessary tn (vop-next vop) vop)
+ (setq saves-list
+ (delete tn saves-list :test #'eq))))))
+
+ (macrolet (;; Do stuff to note a read of TN, for
+ ;; OPTIMIZED-EMIT-SAVES-BLOCK.
+ (save-note-read (tn)
+ `(let* ((tn ,tn)
+ (num (tn-number tn)))
+ (when (and (sc-save-p (tn-sc tn))
+ (zerop (sbit restores num))
+ (not (eq (tn-kind tn) :component)))
+ (setf (sbit restores num) 1)
+ (push tn restores-list)))))
+
+ (case (vop-info-save-p info)
+ ((t)
+ (dolist (tn restores-list)
+ (restore-tn tn (vop-next vop) vop)
+ (let ((num (tn-number tn)))
+ (when (zerop (sbit saves num))
+ (push tn saves-list)
+ (setf (sbit saves num) 1))))
+ (setq restores-list nil)
+ (clear-bit-vector restores))
+ (:compute-only
+ (cond ((policy (vop-node vop) (= speed 3))
+ (do-live-tns (tn (vop-save-set vop) block)
+ (when (zerop (sbit restores (tn-number tn)))
+ (note-spilled-tn tn vop))))
+ (t
+ (do-live-tns (tn (vop-save-set vop) block)
+ (save-note-read tn))))))
+
+ (if (eq (vop-info-move-args info) :local-call)
+ (setq skipping t)
+ (do ((read (vop-args vop) (tn-ref-across read)))
+ ((null read))
+ (save-note-read (tn-ref-tn read))))))))))
- (vop-next vop)))
- ((null vop))
- (flet ((find-all-tns (head-fun)
- (collect ((tns))
- (do ((ref (funcall head-fun vop) (tn-ref-across ref)))
- ((null ref))
- (tns (tn-ref-tn ref)))
- (tns))))
- (dolist (tn (nconc (find-all-tns #'vop-args)
- (find-all-tns #'vop-results)
- (find-all-tns #'vop-temps)
- ;; What does "references in this VOP
- ;; mean"? Probably something that isn't
- ;; useful in this context, since these
- ;; TN-REFs are linked with TN-REF-NEXT
- ;; instead of TN-REF-ACROSS. --JES
- ;; 2004-09-11
- ;; (find-all-tns #'vop-refs)
- ))
- (setf (tn-loop-depth tn)
- (max (tn-loop-depth tn)
- (let* ((ir1-block (ir2-block-block (vop-block vop)))
- (loop (block-loop ir1-block)))
- (if loop
- (loop-depth loop)
- 0))))))))))
+ (vop-next vop)))
+ ((null vop))
+ (flet ((find-all-tns (head-fun)
+ (collect ((tns))
+ (do ((ref (funcall head-fun vop) (tn-ref-across ref)))
+ ((null ref))
+ (tns (tn-ref-tn ref)))
+ (tns))))
+ (dolist (tn (nconc (find-all-tns #'vop-args)
+ (find-all-tns #'vop-results)
+ (find-all-tns #'vop-temps)
+ ;; What does "references in this VOP
+ ;; mean"? Probably something that isn't
+ ;; useful in this context, since these
+ ;; TN-REFs are linked with TN-REF-NEXT
+ ;; instead of TN-REF-ACROSS. --JES
+ ;; 2004-09-11
+ ;; (find-all-tns #'vop-refs)
+ ))
+ (setf (tn-loop-depth tn)
+ (max (tn-loop-depth tn)
+ (let* ((ir1-block (ir2-block-block (vop-block vop)))
+ (loop (block-loop ir1-block)))
+ (if loop
+ (loop-depth loop)
+ 0))))))))))
- (let ((sc (tn-sc tn))
- (tn-offset (tn-offset tn)))
- (when (and (eq (sc-sb sc) sb)
- (<= tn-offset offset)
- (< offset
- (the index
- (+ tn-offset (sc-element-size sc)))))
- tn)))
- (same (ref)
- (let ((tn (tn-ref-tn ref))
- (ltn (tn-ref-load-tn ref)))
- (or (tn-overlaps tn)
- (and ltn (tn-overlaps ltn)))))
- (is-op (ops)
- (do ((ops ops (tn-ref-across ops)))
- ((null ops) nil)
- (let ((found (same ops)))
- (when (and found (not (eq ops op)))
- (return found)))))
- (is-ref (refs end)
- (do ((refs refs (tn-ref-next-ref refs)))
- ((eq refs end) nil)
- (let ((found (same refs)))
- (when found (return found))))))
+ (let ((sc (tn-sc tn))
+ (tn-offset (tn-offset tn)))
+ (when (and (eq (sc-sb sc) sb)
+ (<= tn-offset offset)
+ (< offset
+ (the index
+ (+ tn-offset (sc-element-size sc)))))
+ tn)))
+ (same (ref)
+ (let ((tn (tn-ref-tn ref))
+ (ltn (tn-ref-load-tn ref)))
+ (or (tn-overlaps tn)
+ (and ltn (tn-overlaps ltn)))))
+ (is-op (ops)
+ (do ((ops ops (tn-ref-across ops)))
+ ((null ops) nil)
+ (let ((found (same ops)))
+ (when (and found (not (eq ops op)))
+ (return found)))))
+ (is-ref (refs end)
+ (do ((refs refs (tn-ref-next-ref refs)))
+ ((eq refs end) nil)
+ (let ((found (same refs)))
+ (when found (return found))))))
- (declare (type index loc))
- (block SKIP
- (collect ((victims nil adjoin))
- (do ((i loc (1+ i))
- (end (+ loc (sc-element-size sc))))
- ((= i end))
- (declare (type index i end))
- (let ((victim (svref (finite-sb-live-tns sb) i)))
- (when victim
- (unless (find-in #'tn-next victim normal-tns)
- (return-from SKIP))
- (victims victim))))
-
- (let ((conf (load-tn-conflicts-in-sc op sc loc t)))
- (cond ((not conf)
- (unpack-em (victims)))
- ((eq conf :overflow))
- ((not fallback)
- (cond ((find conf (victims))
- (setq fallback (victims)))
- ((find-in #'tn-next conf normal-tns)
- (setq fallback (list conf))))))))))
+ (declare (type index loc))
+ (block SKIP
+ (collect ((victims nil adjoin))
+ (do ((i loc (1+ i))
+ (end (+ loc (sc-element-size sc))))
+ ((= i end))
+ (declare (type index i end))
+ (let ((victim (svref (finite-sb-live-tns sb) i)))
+ (when victim
+ (unless (find-in #'tn-next victim normal-tns)
+ (return-from SKIP))
+ (victims victim))))
+
+ (let ((conf (load-tn-conflicts-in-sc op sc loc t)))
+ (cond ((not conf)
+ (unpack-em (victims)))
+ ((eq conf :overflow))
+ ((not fallback)
+ (cond ((find conf (victims))
+ (setq fallback (victims)))
+ ((find-in #'tn-next conf normal-tns)
+ (setq fallback (list conf))))))))))
- (fill (finite-sb-always-live sb) nil)
- (setf (finite-sb-always-live sb)
- (make-array size
- :initial-element
- #-sb-xc #*
- ;; The cross-compiler isn't very good at
- ;; dumping specialized arrays, so we delay
- ;; construction of this SIMPLE-BIT-VECTOR
- ;; until runtime.
- #+sb-xc (make-array 0 :element-type 'bit)))
- (setf (finite-sb-always-live-count sb)
- (make-array size
- :initial-element
- #-sb-xc #*
- ;; Ibid
- #+sb-xc (make-array 0 :element-type 'fixnum)))
-
- (fill (finite-sb-conflicts sb) nil)
- (setf (finite-sb-conflicts sb)
- (make-array size :initial-element '#()))
-
- (fill (finite-sb-live-tns sb) nil)
- (setf (finite-sb-live-tns sb)
- (make-array size :initial-element nil))))))
+ (fill (finite-sb-always-live sb) nil)
+ (setf (finite-sb-always-live sb)
+ (make-array size
+ :initial-element
+ #-sb-xc #*
+ ;; The cross-compiler isn't very good at
+ ;; dumping specialized arrays, so we delay
+ ;; construction of this SIMPLE-BIT-VECTOR
+ ;; until runtime.
+ #+sb-xc (make-array 0 :element-type 'bit)))
+ (setf (finite-sb-always-live-count sb)
+ (make-array size
+ :initial-element
+ #-sb-xc #*
+ ;; Ibid
+ #+sb-xc (make-array 0 :element-type 'fixnum)))
+
+ (fill (finite-sb-conflicts sb) nil)
+ (setf (finite-sb-conflicts sb)
+ (make-array size :initial-element '#()))
+
+ (fill (finite-sb-live-tns sb) nil)
+ (setf (finite-sb-live-tns sb)
+ (make-array size :initial-element nil))))))
- (2comp (component-info component)))
- (init-sb-vectors component)
-
- ;; Determine whether we want to do more expensive packing by
- ;; checking whether any blocks in the component have (> SPEED
- ;; COMPILE-SPEED).
- ;;
- ;; FIXME: This means that a declaration can have a minor
- ;; effect even outside its scope, and as the packing is done
- ;; component-globally it'd be tricky to use strict scoping. I
- ;; think this is still acceptable since it's just a tradeoff
- ;; between compilation speed and allocation quality and
- ;; doesn't affect the semantics of the generated code in any
- ;; way. -- JES 2004-10-06
- (do-ir2-blocks (block component)
- (when (policy (block-last (ir2-block-block block))
- (> speed compilation-speed))
- (setf optimize t)
- (return)))
-
- ;; Call the target functions.
- (do-ir2-blocks (block component)
- (do ((vop (ir2-block-start-vop block) (vop-next vop)))
- ((null vop))
- (let ((target-fun (vop-info-target-fun (vop-info vop))))
- (when target-fun
- (funcall target-fun vop)))))
-
- ;; Pack wired TNs first.
- (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
- ((null tn))
- (pack-wired-tn tn optimize))
-
- ;; Pack restricted component TNs.
- (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
- ((null tn))
- (when (eq (tn-kind tn) :component)
- (pack-tn tn t optimize)))
-
- ;; Pack other restricted TNs.
- (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
- ((null tn))
- (unless (tn-offset tn)
- (pack-tn tn t optimize)))
-
- ;; Assign costs to normal TNs so we know which ones should
- ;; always be packed on the stack.
- (when *pack-assign-costs*
- (assign-tn-costs component)
- (assign-tn-depths component))
-
- ;; Allocate normal TNs, starting with the TNs that are used
- ;; in deep loops.
- (collect ((tns))
- (do-ir2-blocks (block component)
- (let ((ltns (ir2-block-local-tns block)))
- (do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
- ((minusp i))
- (declare (fixnum i))
- (let ((tn (svref ltns i)))
- (unless (or (null tn)
- (eq tn :more)
- (tn-offset tn))
- ;; If loop analysis has been disabled we might as
- ;; well revert to the old behaviour of just
- ;; packing TNs linearly as they appear.
- (unless *loop-analyze*
- (pack-tn tn nil optimize))
- (tns tn))))))
- (dolist (tn (stable-sort (tns)
- (lambda (a b)
- (cond
- ((> (tn-loop-depth a)
- (tn-loop-depth b))
- t)
- ((= (tn-loop-depth a)
- (tn-loop-depth b))
- (> (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)))
-
- ;; Do load TN packing and emit saves.
- (let ((*repack-blocks* nil))
- (cond ((and optimize *pack-optimize-saves*)
- (optimized-emit-saves component)
- (do-ir2-blocks (block component)
- (pack-load-tns block)))
- (t
- (do-ir2-blocks (block component)
- (emit-saves block)
- (pack-load-tns block))))
- (when *repack-blocks*
- (loop
- (when (zerop (hash-table-count *repack-blocks*)) (return))
- (maphash (lambda (block v)
- (declare (ignore v))
- (remhash block *repack-blocks*)
- (event repack-block)
- (pack-load-tns block))
- *repack-blocks*))))
-
- (values))
+ (2comp (component-info component)))
+ (init-sb-vectors component)
+
+ ;; Determine whether we want to do more expensive packing by
+ ;; checking whether any blocks in the component have (> SPEED
+ ;; COMPILE-SPEED).
+ ;;
+ ;; FIXME: This means that a declaration can have a minor
+ ;; effect even outside its scope, and as the packing is done
+ ;; component-globally it'd be tricky to use strict scoping. I
+ ;; think this is still acceptable since it's just a tradeoff
+ ;; between compilation speed and allocation quality and
+ ;; doesn't affect the semantics of the generated code in any
+ ;; way. -- JES 2004-10-06
+ (do-ir2-blocks (block component)
+ (when (policy (block-last (ir2-block-block block))
+ (> speed compilation-speed))
+ (setf optimize t)
+ (return)))
+
+ ;; Call the target functions.
+ (do-ir2-blocks (block component)
+ (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+ ((null vop))
+ (let ((target-fun (vop-info-target-fun (vop-info vop))))
+ (when target-fun
+ (funcall target-fun vop)))))
+
+ ;; Pack wired TNs first.
+ (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (pack-wired-tn tn optimize))
+
+ ;; Pack restricted component TNs.
+ (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (when (eq (tn-kind tn) :component)
+ (pack-tn tn t optimize)))
+
+ ;; Pack other restricted TNs.
+ (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (unless (tn-offset tn)
+ (pack-tn tn t optimize)))
+
+ ;; Assign costs to normal TNs so we know which ones should
+ ;; always be packed on the stack.
+ (when *pack-assign-costs*
+ (assign-tn-costs component)
+ (assign-tn-depths component))
+
+ ;; Allocate normal TNs, starting with the TNs that are used
+ ;; in deep loops.
+ (collect ((tns))
+ (do-ir2-blocks (block component)
+ (let ((ltns (ir2-block-local-tns block)))
+ (do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
+ ((minusp i))
+ (declare (fixnum i))
+ (let ((tn (svref ltns i)))
+ (unless (or (null tn)
+ (eq tn :more)
+ (tn-offset tn))
+ ;; If loop analysis has been disabled we might as
+ ;; well revert to the old behaviour of just
+ ;; packing TNs linearly as they appear.
+ (unless *loop-analyze*
+ (pack-tn tn nil optimize))
+ (tns tn))))))
+ (dolist (tn (stable-sort (tns)
+ (lambda (a b)
+ (cond
+ ((> (tn-loop-depth a)
+ (tn-loop-depth b))
+ t)
+ ((= (tn-loop-depth a)
+ (tn-loop-depth b))
+ (> (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)))
+
+ ;; Do load TN packing and emit saves.
+ (let ((*repack-blocks* nil))
+ (cond ((and optimize *pack-optimize-saves*)
+ (optimized-emit-saves component)
+ (do-ir2-blocks (block component)
+ (pack-load-tns block)))
+ (t
+ (do-ir2-blocks (block component)
+ (emit-saves block)
+ (pack-load-tns block))))
+ (when *repack-blocks*
+ (loop
+ (when (zerop (hash-table-count *repack-blocks*)) (return))
+ (maphash (lambda (block v)
+ (declare (ignore v))
+ (remhash block *repack-blocks*)
+ (event repack-block)
+ (pack-load-tns block))
+ *repack-blocks*))))
+
+ (values))