bind and clear *CONTINUATION-NUMBERS* &co in WITH-COMPILATION-VALUES

[sbcl.git] / src / compiler / debug.lisp

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index d38b355..6707533 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -877,15 +877,11 @@
 ;;;
 ;;; FIXME:
 ;;;   * Perhaps this machinery should be #!+SB-SHOW.
-;;;   * Probably the hash tables should either be weak hash tables,
-;;;     or only allocated within a single compilation unit. Otherwise
-;;;     there will be a tendency for them to grow without bound and
-;;;     keep garbage from being collected.
 (macrolet ((def (counter vto vfrom fto ffrom)
              `(progn
                 (declaim (type hash-table ,vto ,vfrom))
-                (defvar ,vto (make-hash-table :test 'eq))
-                (defvar ,vfrom (make-hash-table :test 'eql))
+                (defvar ,vto)
+                (defvar ,vfrom)
                 (declaim (type fixnum ,counter))
                 (defvar ,counter 0)
 
@@ -900,7 +896,7 @@
   (def *continuation-number* *continuation-numbers* *number-continuations*
        cont-num num-cont)
   (def *tn-id* *tn-ids* *id-tns* tn-id id-tn)
-  (def *label-id* *id-labels* *label-ids* label-id id-label))
+  (def *label-id* *label-ids* *id-labels* label-id id-label))
 
 ;;; Print a terse one-line description of LEAF.
 (defun print-leaf (leaf &optional (stream *standard-output*))
@@ -1198,7 +1194,6 @@
                (when k
                  (res k)))
              *list-conflicts-table*)
-    (clrhash *list-conflicts-table*)
     (res)))
 
 ;;; Return a list of a the TNs that conflict with TN. Sort of, kind
@@ -1207,24 +1202,26 @@
   (aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
   (let ((confs (tn-global-conflicts tn)))
     (cond (confs
-           (clrhash *list-conflicts-table*)
-           (do ((conf confs (global-conflicts-next-tnwise conf)))
-               ((null conf))
-             (format t "~&#<block ~D kind ~S>~%"
-                     (block-number (ir2-block-block (global-conflicts-block
-                                                     conf)))
-                     (global-conflicts-kind conf))
-             (let ((block (global-conflicts-block conf)))
-               (add-always-live-tns block tn)
-               (if (eq (global-conflicts-kind conf) :live)
-                   (add-all-local-tns block)
-                   (let ((bconf (global-conflicts-conflicts conf))
-                         (ltns (ir2-block-local-tns block)))
-                     (dotimes (i (ir2-block-local-tn-count block))
-                       (when (/= (sbit bconf i) 0)
-                         (setf (gethash (svref ltns i) *list-conflicts-table*)
-                               t)))))))
-           (listify-conflicts-table))
+           (let ((*list-conflicts-table* (make-hash-table :test 'eq)))
+             (unwind-protect
+                  (do ((conf confs (global-conflicts-next-tnwise conf)))
+                      ((null conf)
+                       (listify-conflicts-table))
+                    (format t "~&#<block ~D kind ~S>~%"
+                            (block-number (ir2-block-block (global-conflicts-block
+                                                            conf)))
+                            (global-conflicts-kind conf))
+                    (let ((block (global-conflicts-block conf)))
+                      (add-always-live-tns block tn)
+                      (if (eq (global-conflicts-kind conf) :live)
+                          (add-all-local-tns block)
+                          (let ((bconf (global-conflicts-conflicts conf))
+                                (ltns (ir2-block-local-tns block)))
+                            (dotimes (i (ir2-block-local-tn-count block))
+                              (when (/= (sbit bconf i) 0)
+                                (setf (gethash (svref ltns i) *list-conflicts-table*)
+                                      t)))))))
+               (clrhash *list-conflicts-table*))))
           (t
            (let* ((block (tn-local tn))
                   (ltns (ir2-block-local-tns block))