(setq block (ir2-block-prev block)))))
;;; Iterate over the normal TNs, finding the cost of packing on the
-;;; stack in units of the number of references. We count all
-;;; references as +1, and subtract out REGISTER-SAVE-PENALTY for each
-;;; place where we would have to save a register.
+;;; stack in units of the number of references. We count all read
+;;; references as +1, write references as + *tn-write-cost*, and
+;;; subtract out REGISTER-SAVE-PENALTY for each place where we would
+;;; have to save a register.
+;;; The subtraction reflects the fact that having a value in a
+;;; register around a call means that code to spill and unspill must
+;;; be inserted.
+(defvar *tn-write-cost* 2)
(defun assign-tn-costs (component)
- (do-ir2-blocks (block component)
- (do ((vop (ir2-block-start-vop block) (vop-next vop)))
- ((null vop))
- (when (eq (vop-info-save-p (vop-info vop)) t)
- (do-live-tns (tn (vop-save-set vop) block)
- (decf (tn-cost tn) *backend-register-save-penalty*)))))
-
- (do ((tn (ir2-component-normal-tns (component-info component))
- (tn-next tn)))
- ((null tn))
- (let ((cost (tn-cost tn)))
- (declare (fixnum cost))
- (do ((ref (tn-reads tn) (tn-ref-next ref)))
- ((null ref))
- (incf cost))
- (do ((ref (tn-writes tn) (tn-ref-next ref)))
- ((null ref))
- (incf cost))
- (setf (tn-cost tn) cost))))
-
-;;; Iterate over the normal TNs, storing the depth of the deepest loop
-;;; that the TN is used in TN-LOOP-DEPTH.
-(defun assign-tn-depths (component)
- (when *loop-analyze*
+ (let ((save-penalty *backend-register-save-penalty*))
(do-ir2-blocks (block component)
- (do ((vop (ir2-block-start-vop block)
- (vop-next vop)))
+ (do ((vop (ir2-block-start-vop block) (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))))))))))
-
+ (when (eq (vop-info-save-p (vop-info vop)) t)
+ (do-live-tns (tn (vop-save-set vop) block)
+ (decf (tn-cost tn) save-penalty))))))
+
+ (let ((write-cost *tn-write-cost*))
+ (do ((tn (ir2-component-normal-tns (component-info component))
+ (tn-next tn)))
+ ((null tn))
+ (let ((cost (tn-cost tn)))
+ (declare (fixnum cost))
+ (do ((ref (tn-reads tn) (tn-ref-next ref)))
+ ((null ref))
+ (incf cost))
+ (do ((ref (tn-writes tn) (tn-ref-next ref)))
+ ((null ref))
+ (incf cost write-cost))
+ (setf (tn-cost tn) cost)))))
+
+;;; Iterate over the normal TNs, folding over the depth of the looops
+;;; that the TN is used in and storing the result in TN-LOOP-DEPTH.
+;;: reducer is the function used to join depth values together. #'max
+;;; gives the maximum depth, #'+ the sum.
+(defun assign-tn-depths (component &key (reducer #'max))
+ (declare (type function reducer))
+ (when *loop-analyze*
+ ;; We only use tn depth for normal TNs
+ (do ((tn (ir2-component-normal-tns (component-info component))
+ (tn-next tn)))
+ ((null tn))
+ (let ((depth 0))
+ (declare (type fixnum depth))
+ (flet ((frob (ref)
+ (declare (type (or null tn-ref) ref))
+ (do ((ref ref (tn-ref-next ref)))
+ ((null ref))
+ (let* ((vop (tn-ref-vop ref))
+ (block (ir2-block-block (vop-block vop)))
+ (loop (block-loop block)))
+ (setf depth (funcall reducer
+ depth
+ (if loop
+ (loop-depth loop)
+ 0)))))))
+ (frob (tn-reads tn))
+ (frob (tn-writes tn))
+ (setf (tn-loop-depth tn) depth))))))
\f
;;;; load TN packing
((= offset end))
(declare (type index offset end))
(setf (svref (finite-sb-live-tns sb) offset) tn))
- (assert (and (null (tn-reads tn))
- (null (tn-writes tn))))))))
+ (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))))
(setq *live-block* block)
(setq *live-vop* (ir2-block-last-vop block))
(or (= offset 0)
(= offset 1))))
(conflicts-in-sc original sc offset))
- (error "~S is wired to a location that it conflicts with." tn))
+ (error "~S is wired to location ~D in SC ~A of kind ~S that it conflicts with."
+ tn offset sc (tn-kind tn)))
(add-location-conflicts original sc offset optimize)))
projects / sbcl.git / blobdiff