X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=cdc23187ba4644d7882741b404082706859acfb3;hb=3e3cd66f482339be3b2eab942e00147c3e343434;hp=1673e940efbe5b2ebe2f8c85a73e89550cfaf800;hpb=0e03a9ac950b78d776c4869c809e202d9e929f39;p=sbcl.git

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index 1673e94..cdc2318 100644
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -598,7 +598,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 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))
@@ -813,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.
@@ -826,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))
@@ -908,8 +919,8 @@
 ;;; 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
@@ -1036,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))))
 
@@ -1046,9 +1057,9 @@
 
 ;;; 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
@@ -1063,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))
@@ -1108,7 +1117,7 @@
 ;;; 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.
@@ -1591,11 +1600,9 @@
               (unless *repack-blocks* (return))
               (let ((orpb *repack-blocks*))
                 (setq *repack-blocks* nil)
-                (maphash (lambda (block v)
-                           (declare (ignore v))
-                           (event repack-block)
-                           (pack-load-tns block))
-                         orpb))))
+                (dolist (block orpb)
+                  (event repack-block)
+                  (pack-load-tns block)))))
 
          (values))
     (clean-up-pack-structures)))