X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=cc5afac246ab0be6bce48eef983533db74638823;hb=19319c931fc1636835dbef71808cc10e252bcf45;hp=a911dbd106695f448777de3529941ecb197e02e6;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index a911dbd..cc5afac 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -24,8 +24,8 @@ ;;;; 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 @@ -39,44 +39,58 @@ ;;; 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 @@ -215,24 +229,26 @@ (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) @@ -243,23 +259,23 @@ (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))) @@ -598,7 +614,7 @@ (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)) @@ -607,20 +623,6 @@ save tn before)) (values)) -(eval-when (:compile-toplevel :execute) - -;;; Do stuff to note a read of TN, for OPTIMIZED-EMIT-SAVES-BLOCK. -(defmacro save-note-read (tn) - `(let* ((tn ,tn) - (num (tn-number tn))) - (when (and (sc-save-p (tn-sc tn)) - (zerop (sbit restores num)) - (not (eq (tn-kind tn) :component))) - (setf (sbit restores num) 1) - (push tn restores-list)))) - -) ; EVAL-WHEN - ;;; Start scanning backward at the end of BLOCK, looking which TNs are ;;; live and looking for places where we have to save. We manipulate ;;; two sets: SAVES and RESTORES. @@ -700,9 +702,7 @@ (setq saves-list (delete tn saves-list :test #'eq)))))) - (macrolet (;; Do stuff to note a read of TN, for - ;; OPTIMIZED-EMIT-SAVES-BLOCK. - (save-note-read (tn) + (macrolet ((save-note-read (tn) `(let* ((tn ,tn) (num (tn-number tn))) (when (and (sc-save-p (tn-sc tn)) @@ -829,7 +829,7 @@ ;;; sticking them in this hash-table. This is initially null. We ;;; create the hashtable if we do any unpacking. (defvar *repack-blocks*) -(declaim (type (or hash-table null) *repack-blocks*)) +(declaim (type list *repack-blocks*)) ;;; Set the LIVE-TNS vectors in all :FINITE SBs to represent the TNs ;;; live at the end of BLOCK. @@ -842,11 +842,22 @@ (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)) + (assert (and (null (tn-reads tn)) + (null (tn-writes tn)))))))) (setq *live-block* block) (setq *live-vop* (ir2-block-last-vop block)) @@ -924,8 +935,8 @@ ;;; 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 @@ -1052,7 +1063,7 @@ (let ((vop (tn-ref-vop ref))) (if (eq (vop-info-name (vop-info vop)) 'move-operand) (delete-vop vop) - (setf (gethash (vop-block vop) *repack-blocks*) t)))))) + (pushnew (vop-block vop) *repack-blocks*)))))) (zot (tn-reads tn)) (zot (tn-writes tn)))) @@ -1062,9 +1073,9 @@ ;;; 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 @@ -1079,9 +1090,7 @@ (node (vop-node (tn-ref-vop op))) (fallback nil)) (flet ((unpack-em (victims) - (unless *repack-blocks* - (setq *repack-blocks* (make-hash-table :test 'eq))) - (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t) + (pushnew (vop-block (tn-ref-vop op)) *repack-blocks*) (dolist (victim victims) (event unpack-tn node) (unpack-tn victim)) @@ -1124,7 +1133,7 @@ ;;; 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. @@ -1308,14 +1317,11 @@ (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 @@ -1356,7 +1362,7 @@ ;;; 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)) @@ -1369,12 +1375,15 @@ (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) @@ -1389,7 +1398,7 @@ (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, @@ -1501,6 +1510,31 @@ (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) @@ -1556,7 +1590,8 @@ (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))) @@ -1571,7 +1606,7 @@ ;; 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) @@ -1584,14 +1619,36 @@ (> (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)) @@ -1603,15 +1660,13 @@ (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*)))) + (loop + (unless *repack-blocks* (return)) + (let ((orpb *repack-blocks*)) + (setq *repack-blocks* nil) + (dolist (block orpb) + (event repack-block) + (pack-load-tns block))))) (values)) (clean-up-pack-structures)))