X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fpack.lisp;h=87464f7bc763ce31ab47651202278f8368d003bf;hb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;hp=a911dbd106695f448777de3529941ecb197e02e6;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index a911dbd..87464f7 100644
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -607,20 +607,6 @@
                        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.
@@ -700,9 +686,7 @@
                   (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))
@@ -829,7 +813,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.
@@ -842,11 +826,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))
@@ -1052,7 +1047,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))))
 
@@ -1079,9 +1074,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))
@@ -1603,15 +1596,13 @@
                   (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)))