- (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))
+ (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.
+ (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))))
+ (loop
+ (unless *repack-blocks* (return))
+ (let ((orpb *repack-blocks*))
+ (setq *repack-blocks* nil)
+ (dolist (block orpb)
+ (event repack-block)
+ (pack-load-tns block)))))
+
+ (values))