+(defun pack (component)
+ (unwind-protect
+ (let ((optimize 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. 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)))
+ (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 :allow-unbounded-sc nil))
+ (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 :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))
+ (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))))
+ (loop
+ (unless *repack-blocks* (return))
+ (let ((orpb *repack-blocks*))
+ (setq *repack-blocks* nil)
+ (dolist (block orpb)
+ (event repack-block)
+ (pack-load-tns block)))))
+
+ (values))
+ (clean-up-pack-structures)))