X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=0e93c72bb82185bab06bb7c92577e743dff4e80b;hb=8171400aa1d9ad318401a4d9c4c07f5f3b374556;hp=60d856535a89eea46b1a4b595641fe1c2b468794;hpb=eda83f00e869193cb69826be5fa1086b95d12ff7;p=sbcl.git diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 60d8565..0e93c72 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -759,63 +759,65 @@ (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)))))) ;;;; load TN packing @@ -1262,24 +1264,27 @@ nil))) ;;; Scan along the target path from TN, looking at readers or writers. -;;; When we find a packed TN, return CHECK-OK-TARGET of that TN. If -;;; there is no target, or if the TN has multiple readers (writers), -;;; then we return NIL. We also always return NIL after 10 iterations -;;; to get around potential circularity problems. +;;; When we find a TN, call CALLEE with that TN, and then resume +;;; walking down that TN's target. As soon as there is no target, or +;;; if the TN has multiple readers (writers), we stop walking the +;;; targetting chain. We also always stop after 10 iterations to get +;;; around potential circularity problems. ;;; -;;; FIXME: (30 minutes of reverse engineering?) It'd be nice to -;;; rewrite the header comment here to explain the interface and its -;;; motivation, and move remarks about implementation details (like -;;; 10!) inside. -(defun find-ok-target-offset (tn sc) - (declare (type tn tn) (type sc sc)) - (flet ((frob-slot (slot-fun) - (declare (type function slot-fun)) - (let ((count 10) +;;; Why the single-reader/writer constraint? As far as I can tell, +;;; this is concerned with straight pipeline of data, e.g. CASTs. In +;;; that case, limiting to chains of length 10 seems to be more than +;;; enough. +(declaim (inline %call-with-target-tns)) +(defun %call-with-target-tns (tn callee + &key (limit 10) (reads t) (writes t)) + (declare (type tn tn) (type function callee) (type index limit)) + (flet ((frob-slot (slot-function) + (declare (type function slot-function)) + (let ((count limit) (current tn)) (declare (type index count)) (loop - (let ((refs (funcall slot-fun current))) + (let ((refs (funcall slot-function current))) (unless (and (plusp count) refs (not (tn-ref-next refs))) @@ -1287,12 +1292,30 @@ (let ((target (tn-ref-target refs))) (unless target (return nil)) (setq current (tn-ref-tn target)) - (when (tn-offset current) - (return (check-ok-target current tn sc))) + (funcall callee current) (decf count))))))) - (declare (inline frob-slot)) ; until DYNAMIC-EXTENT works - (or (frob-slot #'tn-reads) - (frob-slot #'tn-writes)))) + (when reads + (frob-slot #'tn-reads)) + (when writes + (frob-slot #'tn-writes)) + nil)) + +(defmacro do-target-tns ((target-variable source-tn + &rest keys &key limit reads writes) + &body body) + (declare (ignore limit reads writes)) + (let ((callback (gensym "CALLBACK"))) + `(flet ((,callback (,target-variable) + ,@body)) + (declare (dynamic-extent #',callback)) + (%call-with-target-tns ,source-tn #',callback ,@keys)))) + +(defun find-ok-target-offset (tn sc) + (declare (type tn tn) (type sc sc)) + (do-target-tns (target tn) + (awhen (and (tn-offset target) + (check-ok-target target tn sc)) + (return-from find-ok-target-offset it)))) ;;;; location selection @@ -1328,13 +1351,14 @@ (let ((locations (sc-locations sc))) (when optimize (setf locations - (stable-sort (copy-list locations) #'> - :key (lambda (location-offset) - (loop for offset from location-offset - repeat element-size - maximize (svref - (finite-sb-always-live-count sb) - offset)))))) + (schwartzian-stable-sort-list + locations '> + :key (lambda (location-offset) + (loop for offset from location-offset + repeat element-size + maximize (svref + (finite-sb-always-live-count sb) + offset)))))) (dolist (offset locations) (when (or use-reserved-locs (not (member offset @@ -1351,6 +1375,15 @@ ;;;; pack interface +;; Misc. utilities +(declaim (inline unbounded-sc-p)) +(defun unbounded-sc-p (sc) + (eq (sb-kind (sc-sb sc)) :unbounded)) + +(defun unbounded-tn-p (tn) + (unbounded-sc-p (tn-sc tn))) +(declaim (notinline unbounded-sc-p)) + ;;; Attempt to pack TN in all possible SCs, first in the SC chosen by ;;; representation selection, then in the alternate SCs in the order ;;; they were specified in the SC definition. If the TN-COST is @@ -1363,6 +1396,7 @@ ;;; of allocating a new stack location. (defun pack-tn (tn restricted optimize &key (allow-unbounded-sc t)) (declare (type tn tn)) + (aver (not (tn-offset tn))) (let* ((original (original-tn tn)) (fsc (tn-sc tn)) (alternates (unless restricted (sc-alternate-scs fsc))) @@ -1375,7 +1409,7 @@ ((null sc) (failed-to-pack-error tn restricted)) (unless (or allow-unbounded-sc - (neq (sb-kind (sc-sb sc)) :unbounded)) + (not (unbounded-sc-p sc))) (return nil)) (when (eq sc specified-save-sc) (unless (tn-offset save) @@ -1386,10 +1420,11 @@ (when (or restricted (not (and (minusp (tn-cost tn)) (sc-save-p sc)))) (let ((loc (or (find-ok-target-offset original sc) - (select-location original sc) + (select-location original sc :optimize optimize) (and restricted - (select-location original sc :use-reserved-locs t)) - (when (eq (sb-kind (sc-sb sc)) :unbounded) + (select-location original sc :use-reserved-locs t + :optimize optimize)) + (when (unbounded-sc-p sc) (grow-sc sc) (or (select-location original sc) (error "failed to pack after growing SC?")))))) @@ -1458,7 +1493,8 @@ (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))) @@ -1512,9 +1548,10 @@ (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))))) + (do ((acc '()) + (lambda lambda (lambda-parent lambda))) + ((null lambda) acc) + (push lambda acc))) (register-scope (lambda) (let ((new-path (path lambda))) (setf path (if (eql path t) @@ -1523,11 +1560,10 @@ 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))))))) + ((or (null ref) + (null path))) + (awhen (vop-node (tn-ref-vop ref)) + (register-scope (lexenv-lambda (node-lexenv it))))))) (walk-tn-refs (tn-reads tn)) (walk-tn-refs (tn-writes tn)) (if (eql path t)