\f
;;;; conflict determination
-;;; Return true if the element at the specified offset in SB has a
-;;; conflict with TN:
+;;; Return true if the element at the specified offset, or in any of
+;;; the [size-1] subsequent offsets, in SB has a conflict with TN:
;;; -- If a component-live TN (:COMPONENT kind), then iterate over
;;; all the blocks. If the element at OFFSET is used anywhere in
;;; any of the component's blocks (always-live /= 0), then there
;;; that block.
;;; -- If TN is local, then we just check for a conflict in the block
;;; it is local to.
-(defun offset-conflicts-in-sb (tn sb offset)
- (declare (type tn tn) (type finite-sb sb) (type index offset))
+;;;
+;;; If there is a conflict, returns the first such conflicting offset.
+(defun offset-conflicts-in-sb (tn sb offset &key (size 1))
+ (declare (type tn tn) (type finite-sb sb) (type index offset size))
(let ((confs (tn-global-conflicts tn))
- (kind (tn-kind tn)))
- (cond
- ((eq kind :component)
- (let ((loc-live (svref (finite-sb-always-live sb) offset)))
- (dotimes (i (ir2-block-count *component-being-compiled*) nil)
- (when (/= (sbit loc-live i) 0)
- (return t)))))
- (confs
- (let ((loc-confs (svref (finite-sb-conflicts sb) offset))
- (loc-live (svref (finite-sb-always-live sb) offset)))
- (do ((conf confs (global-conflicts-next-tnwise conf)))
- ((null conf)
- nil)
- (let* ((block (global-conflicts-block conf))
- (num (ir2-block-number block)))
- (if (eq (global-conflicts-kind conf) :live)
- (when (/= (sbit loc-live num) 0)
- (return t))
- (when (/= (sbit (svref loc-confs num)
- (global-conflicts-number conf))
- 0)
- (return t)))))))
- (t
- (/= (sbit (svref (svref (finite-sb-conflicts sb) offset)
- (ir2-block-number (tn-local tn)))
- (tn-local-number tn))
- 0)))))
+ (kind (tn-kind tn))
+ (sb-conflicts (finite-sb-conflicts sb))
+ (sb-always-live (finite-sb-always-live sb)))
+ (macrolet ((do-offsets (&body body)
+ `(loop repeat size
+ for offset upfrom offset
+ thereis (progn ,@body))))
+ (cond
+ ((eq kind :component)
+ (do-offsets
+ (let ((loc-live (svref sb-always-live offset)))
+ (dotimes (i (ir2-block-count *component-being-compiled*))
+ (when (/= (sbit loc-live i) 0)
+ (return offset))))))
+ (confs
+ ;; TN is global, iterate over the blocks TN is live in.
+ (do ((conf confs (global-conflicts-next-tnwise conf)))
+ ((null conf)
+ nil)
+ (let* ((block (global-conflicts-block conf))
+ (num (ir2-block-number block)))
+ (if (eq (global-conflicts-kind conf) :live)
+ (do-offsets
+ (let ((loc-live (svref sb-always-live offset)))
+ (when (/= (sbit loc-live num) 0)
+ (return-from offset-conflicts-in-sb offset))))
+ (do-offsets
+ (let ((loc-confs (svref sb-conflicts offset)))
+ (when (/= (sbit (svref loc-confs num)
+ (global-conflicts-number conf))
+ 0)
+ (return-from offset-conflicts-in-sb offset))))))))
+ (t
+ (do-offsets
+ (and (/= (sbit (svref (svref sb-conflicts offset)
+ (ir2-block-number (tn-local tn)))
+ (tn-local-number tn))
+ 0)
+ offset)))))))
;;; Return true if TN has a conflict in SC at the specified offset.
+(declaim (ftype (function (tn sc index) (values (or null index) &optional))
+ conflicts-in-sc))
(defun conflicts-in-sc (tn sc offset)
(declare (type tn tn) (type sc sc) (type index offset))
- (let ((sb (sc-sb sc)))
- (dotimes (i (sc-element-size sc) nil)
- (when (offset-conflicts-in-sb tn sb (+ offset i))
- (return t)))))
+ (offset-conflicts-in-sb tn (sc-sb sc) offset
+ :size (sc-element-size sc)))
;;; Add TN's conflicts into the conflicts for the location at OFFSET
;;; in SC. We iterate over each location in TN, adding to the
(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))))
+ (let ((save-penalty *backend-register-save-penalty*))
+ (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) 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, storing the depth of the deepest loop
;;; that the TN is used in TN-LOOP-DEPTH.
((= 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))
(align-mask (1- alignment))
(size (finite-sb-current-size sb)))
(flet ((attempt-location (start-offset)
- (dotimes (i element-size
- (return-from select-location start-offset))
- (declare (type index i))
- (let ((offset (+ start-offset i)))
- (when (offset-conflicts-in-sb tn sb offset)
- (return (logandc2 (the index (+ (the index (1+ offset))
- align-mask))
- align-mask)))))))
+ (let ((conflict (conflicts-in-sc tn sc start-offset)))
+ (if conflict
+ (logandc2 (+ conflict align-mask 1)
+ align-mask)
+ (return-from select-location start-offset)))))
(if (eq (sb-kind sb) :unbounded)
(loop with offset = 0
until (> (+ offset element-size) size) do
(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