(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))
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.
(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))
;;; 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.
(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))
;;; 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
(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))))
;;; 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
(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))
;;; 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.
(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)))
projects / sbcl.git / blobdiff