X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=0e93c72bb82185bab06bb7c92577e743dff4e80b;hb=8171400aa1d9ad318401a4d9c4c07f5f3b374556;hp=2255a9c5799f625fd124098afe2a9740990b5bc1;hpb=338ebb8ec835c255109363cbdf381867084f72fe;p=sbcl.git diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 2255a9c..0e93c72 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -790,39 +790,34 @@ (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. -(defun assign-tn-depths (component) +;;; 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* - (do-ir2-blocks (block component) - (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)))))))))) - + ;; 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 @@ -1269,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))) @@ -1294,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 @@ -1335,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 @@ -1358,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 @@ -1370,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))) @@ -1382,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) @@ -1393,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?")))))) @@ -1520,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) @@ -1531,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)