+(defun pack (component)
+ (unwind-protect
+ (let ((optimize (policy *lexenv*
+ (or (>= speed compilation-speed)
+ (>= space compilation-speed))))
+ (2comp (component-info component)))
+ (init-sb-vectors component)
+
+ ;; 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))
+
+ ;; 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)))
+
+ ;; Pack other restricted TNs.
+ (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (unless (tn-offset tn)
+ (pack-tn tn t)))
+
+ ;; Assign costs to normal TNs so we know which ones should always
+ ;; be packed on the stack.
+ (when (and optimize *pack-assign-costs*)
+ (assign-tn-costs component))
+
+ ;; Pack normal TNs in the order that they appear in the code. This
+ ;; should have some tendency to pack important TNs first, since
+ ;; control analysis favors the drop-through. This should also help
+ ;; targeting, since we will pack the target TN soon after we
+ ;; determine the location of the targeting TN.
+ (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))
+ (pack-tn tn nil))))))
+
+ ;; 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)))
+
+ ;; 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))
+ (clean-up-pack-structures)))