X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=b30b86d3a38fedfda23bd7b4869689b71b51ad8c;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=1673e940efbe5b2ebe2f8c85a73e89550cfaf800;hpb=0e03a9ac950b78d776c4869c809e202d9e929f39;p=sbcl.git diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 1673e94..b30b86d 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -215,24 +215,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 +245,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 +600,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)) @@ -813,7 +815,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. @@ -826,11 +828,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)) @@ -908,8 +921,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 @@ -1036,7 +1049,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)))) @@ -1046,9 +1059,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 @@ -1063,9 +1076,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)) @@ -1108,7 +1119,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. @@ -1340,7 +1351,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)) @@ -1353,12 +1364,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) @@ -1373,7 +1387,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, @@ -1485,6 +1499,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) @@ -1540,7 +1579,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))) @@ -1555,7 +1595,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) @@ -1568,14 +1608,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)) @@ -1591,11 +1653,9 @@ (unless *repack-blocks* (return)) (let ((orpb *repack-blocks*)) (setq *repack-blocks* nil) - (maphash (lambda (block v) - (declare (ignore v)) - (event repack-block) - (pack-load-tns block)) - orpb)))) + (dolist (block orpb) + (event repack-block) + (pack-load-tns block))))) (values)) (clean-up-pack-structures)))