X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=5057a72b66f1581d156bace4b7a247a40e11bf23;hb=ff57884e206ac28660af6af34315bc9b81697f57;hp=b0a94674d3cf39a556dac91d16cb0fa47d1e4d59;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index b0a9467..5057a72 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -24,19 +24,21 @@ ;;;; conflict determination -;;; Return true if the element at the specified offset in SB has a conflict -;;; with TN: -;;; -- If an 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 is a conflict. -;;; -- If TN is global (Confs true), then iterate over the blocks TN is live in -;;; (using TN-Global-Conflicts). If the TN is live everywhere in the block -;;; (:Live), then there is a conflict if the element at offset is used -;;; anywhere in the block (Always-Live /= 0). Otherwise, we use the local -;;; TN number for TN in block to find whether TN has a conflict at Offset in +;;; Return true if the element at the specified offset 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 +;;; is a conflict. +;;; -- If TN is global (Confs true), then iterate over the blocks TN +;;; is live in (using TN-GLOBAL-CONFLICTS). If the TN is live +;;; everywhere in the block (:LIVE), then there is a conflict +;;; if the element at offset is used anywhere in the block +;;; (Always-Live /= 0). Otherwise, we use the local TN number for +;;; TN in block to find whether TN has a conflict at Offset in ;;; that block. -;;; -- If TN is local, then we just check for a conflict in the block it is -;;; local to. +;;; -- 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)) (let ((confs (tn-global-conflicts tn)) @@ -50,7 +52,7 @@ (confs (let ((loc-confs (svref (finite-sb-conflicts sb) offset)) (loc-live (svref (finite-sb-always-live sb) offset))) - (do ((conf confs (global-conflicts-tn-next conf))) + (do ((conf confs (global-conflicts-next-tnwise conf))) ((null conf) nil) (let* ((block (global-conflicts-block conf)) @@ -76,20 +78,20 @@ (when (offset-conflicts-in-sb tn sb (+ offset i)) (return t))))) -;;; Add TN's conflicts into the conflicts for the location at Offset in SC. -;;; We iterate over each location in TN, adding to the conflicts for that -;;; location: -;;; -- If TN is a :Component TN, then iterate over all the blocks, setting -;;; all of the local conflict bits and the always-live bit. This records a -;;; conflict with any TN that has a LTN number in the block, as well as with -;;; :Always-Live and :Environment TNs. +;;; Add TN's conflicts into the conflicts for the location at OFFSET +;;; in SC. We iterate over each location in TN, adding to the +;;; conflicts for that location: +;;; -- If TN is a :COMPONENT TN, then iterate over all the blocks, +;;; setting all of the local conflict bits and the always-live bit. +;;; This records a conflict with any TN that has a LTN number in +;;; the block, as well as with :ALWAYS-LIVE and :ENVIRONMENT TNs. ;;; -- If TN is global, then iterate over the blocks TN is live in. In -;;; addition to setting the always-live bit to represent the conflict with -;;; TNs live throughout the block, we also set bits in the local conflicts. -;;; If TN is :Always-Live in the block, we set all the bits, otherwise we or -;;; in the local conflict bits. -;;; -- If the TN is local, then we just do the block it is local to, setting -;;; always-live and OR'ing in the local conflicts. +;;; addition to setting the always-live bit to represent the conflict +;;; with TNs live throughout the block, we also set bits in the +;;; local conflicts. If TN is :ALWAYS-LIVE in the block, we set all +;;; the bits, otherwise we OR in the local conflict bits. +;;; -- If the TN is local, then we just do the block it is local to, +;;; setting always-live and OR'ing in the local conflicts. (defun add-location-conflicts (tn sc offset) (declare (type tn tn) (type sc sc) (type index offset)) (let ((confs (tn-global-conflicts tn)) @@ -102,12 +104,12 @@ (loc-live (svref (finite-sb-always-live sb) this-offset))) (cond ((eq kind :component) - (dotimes (num (ir2-block-count *component-being-compiled*) nil) + (dotimes (num (ir2-block-count *component-being-compiled*)) (declare (type index num)) (setf (sbit loc-live num) 1) (set-bit-vector (svref loc-confs num)))) (confs - (do ((conf confs (global-conflicts-tn-next conf))) + (do ((conf confs (global-conflicts-next-tnwise conf))) ((null conf)) (let* ((block (global-conflicts-block conf)) (num (ir2-block-number block)) @@ -123,7 +125,7 @@ (bit-ior (the local-tn-bit-vector (svref loc-confs num)) (tn-local-conflicts tn) t)))))))) -;;; Return the total number of IR2 blocks in Component. +;;; Return the total number of IR2-BLOCKs in COMPONENT. (defun ir2-block-count (component) (declare (type component component)) (do ((2block (block-info (block-next (component-head component))) @@ -133,7 +135,7 @@ (when (ir2-block-number 2block) (return (1+ (ir2-block-number 2block)))))) -;;; Ensure that the conflicts vectors for each :Finite SB are large +;;; Ensure that the conflicts vectors for each :FINITE SB are large ;;; enough for the number of blocks allocated. Also clear any old ;;; conflicts and reset the current size to the initial size. (defun init-sb-vectors (component) @@ -185,8 +187,8 @@ (setf (finite-sb-current-size sb) (sb-size sb)) (setf (finite-sb-last-offset sb) 0)))))) -;;; Expand the :Unbounded SB backing SC by either the initial size or -;;; the SC element size, whichever is larger. If Needed-Size is +;;; Expand the :UNBOUNDED SB backing SC by either the initial size or +;;; the SC element size, whichever is larger. If NEEDED-SIZE is ;;; larger, then use that size. (defun grow-sc (sc &optional (needed-size 0)) (declare (type sc sc) (type index needed-size)) @@ -252,21 +254,22 @@ (dolist (sb *backend-sb-list*) (unless (eq (sb-kind sb) :non-packed) (let ((size (sb-size sb))) - (fill nil (finite-sb-always-live sb)) + (fill (finite-sb-always-live sb) nil) (setf (finite-sb-always-live sb) (make-array size :initial-element #-sb-xc #* - ;; The cross-compiler isn't very good at dumping - ;; specialized arrays, so we delay construction of - ;; this SIMPLE-BIT-VECTOR until runtime. + ;; The cross-compiler isn't very good at + ;; dumping specialized arrays, so we delay + ;; construction of this SIMPLE-BIT-VECTOR + ;; until runtime. #+sb-xc (make-array 0 :element-type 'bit))) - (fill nil (finite-sb-conflicts sb)) + (fill (finite-sb-conflicts sb) nil) (setf (finite-sb-conflicts sb) (make-array size :initial-element '#())) - (fill nil (finite-sb-live-tns sb)) + (fill (finite-sb-live-tns sb) nil) (setf (finite-sb-live-tns sb) (make-array size :initial-element nil)))))) (values)) @@ -275,9 +278,9 @@ ;;;; internal errors -;;; Give someone a hard time because there isn't any load function defined -;;; to move from Src to Dest. -(defun no-load-function-error (src dest) +;;; Give someone a hard time because there isn't any load function +;;; defined to move from SRC to DEST. +(defun no-load-fun-error (src dest) (let* ((src-sc (tn-sc src)) (src-name (sc-name src-sc)) (dest-sc (tn-sc dest)) @@ -315,16 +318,16 @@ tn (sc-name sc))) (t (aver (not (find :unbounded scs - :key #'(lambda (x) (sb-kind (sc-sb x)))))) + :key (lambda (x) (sb-kind (sc-sb x)))))) (let ((ptype (tn-primitive-type tn))) (cond (ptype (aver (member (sc-number sc) (primitive-type-scs ptype))) - (error "SC ~S doesn't have any :Unbounded alternate SCs, but is~@ + (error "SC ~S doesn't have any :UNBOUNDED alternate SCs, but is~@ a SC for primitive-type ~S." (sc-name sc) (primitive-type-name ptype))) (t - (error "SC ~S doesn't have any :Unbounded alternate SCs." + (error "SC ~S doesn't have any :UNBOUNDED alternate SCs." (sc-name sc))))))))) ;;; Return a list of format arguments describing how TN is used in @@ -334,7 +337,7 @@ (args (vop-args vop)) (results (vop-results vop)) (name (with-output-to-string (stream) - (print-tn tn stream))) + (print-tn-guts tn stream))) (2comp (component-info *component-being-compiled*)) temp) (cond @@ -439,8 +442,9 @@ (pushnew tn (gethash vop (ir2-component-spilled-vops 2comp))))) (values)) -;;; Make a save TN for TN, pack it, and return it. We copy various conflict -;;; information from the TN so that pack does the right thing. +;;; Make a save TN for TN, pack it, and return it. We copy various +;;; conflict information from the TN so that pack does the right +;;; thing. (defun pack-save-tn (tn) (declare (type tn tn)) (let ((res (make-tn 0 :save nil nil))) @@ -462,9 +466,9 @@ (emit-load-template node block (template-or-lose 'move-operand) src dest - (list (or (svref (sc-move-functions (tn-sc dest)) + (list (or (svref (sc-move-funs (tn-sc dest)) (sc-number (tn-sc src))) - (no-load-function-error src dest))) + (no-load-fun-error src dest))) before) (values)) @@ -503,7 +507,7 @@ vop)) (emit-operand-load node block save tn next))) -;;; Return a VOP after which is an o.k. place to save the value of TN. +;;; Return a VOP after which is an OK place to save the value of TN. ;;; For correctness, it is only required that this location be after ;;; any possible write and before any possible restore location. ;;; @@ -569,8 +573,8 @@ (save-complex-writer-tn tn vop)))) (values)) -;;; Scan over the VOPs in Block, emiting saving code for TNs noted in the -;;; codegen info that are packed into saved SCs. +;;; Scan over the VOPs in BLOCK, emiting saving code for TNs noted in +;;; the codegen info that are packed into saved SCs. (defun emit-saves (block) (declare (type ir2-block block)) (do ((vop (ir2-block-start-vop block) (vop-next vop))) @@ -586,8 +590,8 @@ ;;;; optimized saving ;;; Save TN if it isn't a single-writer TN that has already been -;;; saved. If multi-write, we insert the save Before the specified -;;; VOP. Context is a VOP used to tell which node/block to use for the +;;; saved. If multi-write, we insert the save BEFORE the specified +;;; VOP. CONTEXT is a VOP used to tell which node/block to use for the ;;; new VOP. (defun save-if-necessary (tn before context) (declare (type tn tn) (type (or vop null) before) (type vop context)) @@ -602,7 +606,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 specifier 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)) @@ -645,10 +649,10 @@ ;;; ;;; SAVES and RESTORES are represented using both a list and a ;;; bit-vector so that we can quickly iterate and test for membership. -;;; The incoming Saves and Restores args are used for computing these +;;; The incoming SAVES and RESTORES args are used for computing these ;;; sets (the initial contents are ignored.) ;;; -;;; When we hit a VOP with :COMPUTE-ONLY Save-P (an internal error +;;; When we hit a VOP with :COMPUTE-ONLY SAVE-P (an internal error ;;; location), we pretend that all live TNs were read, unless (= speed ;;; 3), in which case we mark all the TNs that are live but not ;;; restored as spilled. @@ -739,10 +743,10 @@ (do ((read (vop-args vop) (tn-ref-across read))) ((null read)) (save-note-read (tn-ref-tn read)))))))))) - -;;; Like EMIT-SAVES, only different. We avoid redundant saving within -;;; the block, and don't restore values that aren't used before the -;;; next call. This function is just the top level loop over the + +;;; This is like EMIT-SAVES, only different. We avoid redundant saving +;;; within the block, and don't restore values that aren't used before +;;; the next call. This function is just the top level loop over the ;;; blocks in the component, which locates blocks that need saving ;;; done. (defun optimized-emit-saves (component) @@ -790,8 +794,8 @@ ;;;; load TN packing ;;; These variables indicate the last location at which we computed -;;; the Live-TNs. They hold the Block and VOP values that were passed -;;; to Compute-Live-TNs. +;;; the Live-TNs. They hold the BLOCK and VOP values that were passed +;;; to COMPUTE-LIVE-TNS. (defvar *live-block*) (defvar *live-vop*) @@ -801,8 +805,8 @@ (defvar *repack-blocks*) (declaim (type (or hash-table null) *repack-blocks*)) -;;; Set the Live-TNs vectors in all :Finite SBs to represent the TNs -;;; live at the end of Block. +;;; Set the LIVE-TNS vectors in all :FINITE SBs to represent the TNs +;;; live at the end of BLOCK. (defun init-live-tns (block) (dolist (sb *backend-sb-list*) (when (eq (sb-kind sb) :finite) @@ -823,8 +827,8 @@ (values)) -;;; Set the Live-TNs in :Finite SBs to represent the TNs live -;;; immediately after the evaluation of VOP in Block, excluding +;;; Set the LIVE-TNs in :FINITE SBs to represent the TNs live +;;; immediately after the evaluation of VOP in BLOCK, excluding ;;; results of the VOP. If VOP is null, then compute the live TNs at ;;; the beginning of the block. Sequential calls on the same block ;;; must be in reverse VOP order. @@ -878,7 +882,7 @@ (setq *live-vop* vop) (values)) -;;; This is kind of like Offset-Conflicts-In-SB, except that it uses +;;; This is kind of like OFFSET-CONFLICTS-IN-SB, except that it uses ;;; the VOP refs to determine whether a Load-TN for OP could be packed ;;; in the specified location, disregarding conflicts with TNs not ;;; referenced by this VOP. There is a conflict if either: @@ -960,7 +964,7 @@ (load-tn-offset-conflicts-in-sb op sb i)))) (when res (return res)))))) -;;; If a load-TN for Op is targeted to a legal location in SC, then +;;; If a load-TN for OP is targeted to a legal location in SC, then ;;; return the offset, otherwise return NIL. We see whether the target ;;; of the operand is packed, and try that location. There isn't any ;;; need to chain down the target path, since everything is packed @@ -1128,8 +1132,8 @@ (return res)))) (push sc allowed))))))))) -;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by -;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy +;;; Scan a list of load-SCs vectors and a list of TN-REFS threaded by +;;; TN-REF-ACROSS. When we find a reference whose TN doesn't satisfy ;;; the restriction, we pack a Load-TN and load the operand into it. ;;; If a load-tn has already been allocated, we can assume that the ;;; restriction is satisfied. @@ -1170,7 +1174,7 @@ (values)) -;;; Scan the VOPs in Block, looking for operands whose SC restrictions +;;; Scan the VOPs in BLOCK, looking for operands whose SC restrictions ;;; aren't satisfied. We do the results first, since they are ;;; evaluated later, and our conflict analysis is a backward scan. (defun pack-load-tns (block) @@ -1186,30 +1190,34 @@ (vop-args vop)))))) (values)) -;;;; location-selection, targeting & pack interface - ;;;; targeting -;;; Link the TN-Refs Read and Write together using the TN-Ref-Target when -;;; this seems like a good idea. Currently we always do, as this increases the -;;; success of load-TN targeting. +;;; Link the TN-REFS READ and WRITE together using the TN-REF-TARGET +;;; when this seems like a good idea. Currently we always do, as this +;;; increases the success of load-TN targeting. (defun target-if-desirable (read write) (declare (type tn-ref read write)) + ;; As per the comments at the definition of TN-REF-TARGET, read and + ;; write refs are always paired, with TARGET in the read pointing to + ;; the write and vice versa. + (aver (eq (tn-ref-write-p read) + (not (tn-ref-write-p write)))) (setf (tn-ref-target read) write) (setf (tn-ref-target write) read)) ;;; If TN can be packed into SC so as to honor a preference to TARGET, ;;; then return the offset to pack at, otherwise return NIL. TARGET -;;; must be already packed. We can honor a preference if: -;;; -- TARGET's location is in SC's locations. -;;; -- The element sizes of the two SCs are the same. -;;; -- TN doesn't conflict with target's location. +;;; must be already packed. (defun check-ok-target (target tn sc) (declare (type tn target tn) (type sc sc) (inline member)) (let* ((loc (tn-offset target)) (target-sc (tn-sc target)) (target-sb (sc-sb target-sc))) (declare (type index loc)) + ;; We can honor a preference if: + ;; -- TARGET's location is in SC's locations. + ;; -- The element sizes of the two SCs are the same. + ;; -- TN doesn't conflict with target's location. (if (and (eq target-sb (sc-sb sc)) (or (eq (sb-kind target-sb) :unbounded) (member loc (sc-locations sc))) @@ -1220,41 +1228,50 @@ 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 +;;; 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. -(macrolet ((frob (slot) - `(let ((count 10) - (current tn)) - (declare (type index count)) - (loop - (let ((refs (,slot current))) - (unless (and (plusp count) refs (not (tn-ref-next refs))) - (return nil)) - (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))) - (decf count))))))) - (defun find-ok-target-offset (tn sc) - (declare (type tn tn) (type sc sc)) - (or (frob tn-reads) - (frob tn-writes)))) - +;;; +;;; 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) + (current tn)) + (declare (type index count)) + (loop + (let ((refs (funcall slot-fun current))) + (unless (and (plusp count) + refs + (not (tn-ref-next refs))) + (return nil)) + (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))) + (decf count))))))) + (declare (inline frob-slot)) ; until DYNAMIC-EXTENT works + (or (frob-slot #'tn-reads) + (frob-slot #'tn-writes)))) + ;;;; location selection ;;; Select some location for TN in SC, returning the offset if we ;;; succeed, and NIL if we fail. We start scanning at the Last-Offset ;;; in an attempt to distribute the TNs across all storage. ;;; -;;; We call Offset-Conflicts-In-SB directly, rather than using -;;; Conflicts-In-SC. This allows us to more efficient in packing +;;; We call OFFSET-CONFLICTS-IN-SB directly, rather than using +;;; CONFLICTS-IN-SC. This allows us to more efficient in packing ;;; multi-location TNs: we don't have to multiply the number of tests -;;; by the TN size. This falls out natually, since we have to be aware -;;; of TN size anyway so that we don't call Conflicts-In-SC on a bogus -;;; offset. +;;; by the TN size. This falls out naturally, since we have to be +;;; aware of TN size anyway so that we don't call CONFLICTS-IN-SC on a +;;; bogus offset. ;;; ;;; We give up on finding a location after our current pointer has ;;; wrapped twice. This will result in testing some locations twice in @@ -1316,7 +1333,7 @@ (if (member (tn-kind tn) '(:save :save-once :specified-save)) (tn-save-tn tn) tn)) - + ;;;; pack interface ;;; Attempt to pack TN in all possible SCs, first in the SC chosen by @@ -1370,7 +1387,7 @@ ;;; Pack a wired TN, checking that the offset is in bounds for the SB, ;;; and that the TN doesn't conflict with some other TN already packed ;;; in that location. If the TN is wired to a location beyond the end -;;; of a :Unbounded SB, then grow the SB enough to hold the TN. +;;; of a :UNBOUNDED SB, then grow the SB enough to hold the TN. ;;; ;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs. ;;; This is kind of a hack to make specifying wired stack save @@ -1444,7 +1461,7 @@ (do-ir2-blocks (block component) (do ((vop (ir2-block-start-vop block) (vop-next vop))) ((null vop)) - (let ((target-fun (vop-info-target-function (vop-info vop)))) + (let ((target-fun (vop-info-target-fun (vop-info vop)))) (when target-fun (funcall target-fun vop))))) @@ -1505,11 +1522,11 @@ (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)) + (maphash (lambda (block v) + (declare (ignore v)) + (remhash block *repack-blocks*) + (event repack-block) + (pack-load-tns block)) *repack-blocks*))))) (values))