\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
(let* ((sb (sc-sb sc))
(size (finite-sb-current-size sb))
(align-mask (1- (sc-alignment sc)))
- (inc (max (sb-size sb)
+ (inc (max (finite-sb-size-increment sb)
(+ (sc-element-size sc)
(- (logandc2 (+ size align-mask) align-mask)
size))
(- needed-size size)))
- (new-size (+ size inc))
+ (new-size (let ((align-mask (1- (finite-sb-size-alignment sb))))
+ (logandc2 (+ size inc align-mask) align-mask)))
(conflicts (finite-sb-conflicts sb))
(block-size (if (zerop (length conflicts))
(ir2-block-count *component-being-compiled*)
- (length (the simple-vector (svref conflicts 0))))))
- (declare (type index inc new-size))
+ (length (the simple-vector (svref conflicts 0)))))
+ (padded-size (ash 1 (integer-length (1- new-size)))))
+ (declare (type index inc new-size padded-size))
(aver (eq (sb-kind sb) :unbounded))
- (when (> new-size (length conflicts))
- (let ((new-conf (make-array new-size)))
+ (when (> padded-size (length conflicts))
+ (let ((new-conf (make-array padded-size)))
(replace new-conf conflicts)
(do ((i size (1+ i)))
- ((= i new-size))
+ ((= i padded-size))
(declare (type index i))
(let ((loc-confs (make-array block-size)))
(dotimes (j block-size)
(setf (svref new-conf i) loc-confs)))
(setf (finite-sb-conflicts sb) new-conf))
- (let ((new-live (make-array new-size)))
+ (let ((new-live (make-array padded-size)))
(replace new-live (finite-sb-always-live sb))
(do ((i size (1+ i)))
- ((= i new-size))
+ ((= i padded-size))
(setf (svref new-live i)
(make-array block-size
:initial-element 0
:element-type 'bit)))
(setf (finite-sb-always-live sb) new-live))
- (let ((new-live-count (make-array new-size)))
+ (let ((new-live-count (make-array padded-size)))
(declare (optimize speed)) ;; FILL deftransform
(replace new-live-count (finite-sb-always-live-count sb))
(fill new-live-count 0 :start size)
(setf (finite-sb-always-live-count sb) new-live-count))
- (let ((new-tns (make-array new-size :initial-element nil)))
+ (let ((new-tns (make-array padded-size :initial-element nil)))
(replace new-tns (finite-sb-live-tns sb))
(fill (finite-sb-live-tns sb) nil)
(setf (finite-sb-live-tns sb) new-tns)))
(values))
;;; Load the TN from its save location, allocating one if necessary.
-;;; The load is inserted BEFORE the specifier VOP. CONTEXT is a VOP
+;;; The load is inserted BEFORE the specified VOP. CONTEXT is a VOP
;;; used to tell which node/block to use for the new VOP.
(defun restore-tn (tn before context)
(declare (type tn tn) (type (or vop null) before) (type vop context))
(let* ((sc (tn-sc tn))
(sb (sc-sb sc)))
(when (eq (sb-kind sb) :finite)
- (do ((offset (tn-offset tn) (1+ offset))
- (end (+ (tn-offset tn) (sc-element-size sc))))
- ((= offset end))
- (declare (type index offset end))
- (setf (svref (finite-sb-live-tns sb) offset) tn)))))
+ ;; KLUDGE: we can have "live" TNs that are neither read
+ ;; to nor written from, due to more aggressive (type-
+ ;; directed) constant propagation. Such TNs will never
+ ;; be assigned an offset nor be in conflict with anything.
+ ;;
+ ;; Ideally, it seems to me we could make sure these TNs
+ ;; are never allocated in the first place in
+ ;; ASSIGN-LAMBDA-VAR-TNS.
+ (if (tn-offset tn)
+ (do ((offset (tn-offset tn) (1+ offset))
+ (end (+ (tn-offset tn) (sc-element-size sc))))
+ ((= offset end))
+ (declare (type index offset end))
+ (setf (svref (finite-sb-live-tns sb) offset) tn))
+ (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))))
(setq *live-block* block)
(setq *live-vop* (ir2-block-last-vop block))
;;; aren't any TN-REFs to represent the implicit reading of results or
;;; writing of arguments.
;;;
-;;; The second bullet corresponds conflicts with temporaries or between
-;;; arguments and results.
+;;; The second bullet corresponds to conflicts with temporaries or
+;;; between arguments and results.
;;;
;;; We consider both the TN-REF-TN and the TN-REF-LOAD-TN (if any) to
;;; be referenced simultaneously and in the same way. This causes
;;; This is called by PACK-LOAD-TN where there isn't any location free
;;; that we can pack into. What we do is move some live TN in one of
-;;; the specified SCs to memory, then mark this block all blocks that
-;;; reference the TN as needing repacking. If we succeed, we throw to
-;;; UNPACKED-TN. If we fail, we return NIL.
+;;; the specified SCs to memory, then mark all blocks that reference
+;;; the TN as needing repacking. If we succeed, we throw to UNPACKED-TN.
+;;; If we fail, we return NIL.
;;;
;;; We can unpack any live TN that appears in the NORMAL-TNs list
;;; (isn't wired or restricted.) We prefer to unpack TNs that are not
;;; if that location is in a SC not allowed by the primitive type.
;;; (The SC must still be allowed by the operand restriction.) This
;;; makes move VOPs more efficient, since we won't do a move from the
-;;; stack into a non-descriptor any-reg though a descriptor argument
+;;; stack into a non-descriptor any-reg through a descriptor argument
;;; load-TN. This does give targeting some real semantics, making it
;;; not a pure advisory to pack. It allows pack to do some packing it
;;; wouldn't have done before.
(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
;;; If we are attempting to pack in the SC of the save TN for a TN
;;; with a :SPECIFIED-SAVE TN, then we pack in that location, instead
;;; of allocating a new stack location.
-(defun pack-tn (tn restricted optimize)
+(defun pack-tn (tn restricted optimize &key (allow-unbounded-sc t))
(declare (type tn tn))
(let* ((original (original-tn tn))
(fsc (tn-sc tn))
(do ((sc fsc (pop alternates)))
((null sc)
(failed-to-pack-error tn restricted))
+ (unless (or allow-unbounded-sc
+ (neq (sb-kind (sc-sb sc)) :unbounded))
+ (return nil))
(when (eq sc specified-save-sc)
(unless (tn-offset save)
(pack-tn save nil optimize))
(setf (tn-offset tn) (tn-offset save))
(setf (tn-sc tn) (tn-sc save))
- (return))
+ (return t))
(when (or restricted
(not (and (minusp (tn-cost tn)) (sc-save-p sc))))
(let ((loc (or (find-ok-target-offset original sc)
(add-location-conflicts original sc loc optimize)
(setf (tn-sc tn) sc)
(setf (tn-offset tn) loc)
- (return))))))
+ (return t))))))
(values))
;;; Pack a wired TN, checking that the offset is in bounds for the SB,
(setf (finite-sb-live-tns sb)
(make-array size :initial-element nil))))))
+(defun tn-lexical-depth (tn)
+ (let ((path t)) ; dummy initial value
+ (labels ((path (lambda)
+ (nreverse (loop while lambda
+ collect lambda
+ do (setf lambda (lambda-parent lambda)))))
+ (register-scope (lambda)
+ (let ((new-path (path lambda)))
+ (setf path (if (eql path t)
+ new-path
+ (subseq path
+ 0 (mismatch path new-path))))))
+ (walk-tn-refs (ref)
+ (do ((ref ref (tn-ref-next ref)))
+ ((null ref))
+ (binding* ((node (vop-node (tn-ref-vop ref))
+ :exit-if-null))
+ (register-scope (lexenv-lambda
+ (node-lexenv node)))))))
+ (walk-tn-refs (tn-reads tn))
+ (walk-tn-refs (tn-writes tn))
+ (if (eql path t)
+ most-positive-fixnum
+ (length path)))))
+
(defun pack (component)
(unwind-protect
(let ((optimize nil)
(assign-tn-depths component))
;; Allocate normal TNs, starting with the TNs that are used
- ;; in deep loops.
+ ;; 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)))
;; well revert to the old behaviour of just
;; packing TNs linearly as they appear.
(unless *loop-analyze*
- (pack-tn tn nil optimize))
+ (pack-tn tn nil optimize :allow-unbounded-sc nil))
(tns tn))))))
(dolist (tn (stable-sort (tns)
(lambda (a 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)))
+ (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))
projects / sbcl.git / blobdiff