bind and clear *SEEN-FUNS* and *SEEN-BLOCKS* in CHECK-IR1-CONSISTENCY

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 2997e90..d38b355 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -56,8 +56,8 @@
 ;;; reached by recursing on top level functions.
 ;;; FIXME: Is it really only LAMBDAs, not e.g. FUNCTIONALs? Then
 ;;; shouldn't it be *SEEN-LAMBDAS*?
-(defvar *seen-blocks* (make-hash-table :test 'eq))
-(defvar *seen-funs* (make-hash-table :test 'eq))
+(defvar *seen-blocks*)
+(defvar *seen-funs*)
 
 ;;; Barf if NODE is in a block which wasn't reached during the graph
 ;;; walk.
@@ -79,78 +79,79 @@
 ;;; hashtables, looking for lossage.
 (declaim (ftype (function (list) (values)) check-ir1-consistency))
 (defun check-ir1-consistency (components)
-  (clrhash *seen-blocks*)
-  (clrhash *seen-funs*)
-  (dolist (c components)
-    (let* ((head (component-head c))
-           (tail (component-tail c)))
-      (unless (and (null (block-pred head))
-                   (null (block-succ tail)))
-        (barf "~S is malformed." c))
-
-      (do ((prev nil block)
-           (block head (block-next block)))
-          ((null block)
-           (unless (eq prev tail)
-             (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
-        (setf (gethash block *seen-blocks*) t)
-        (unless (eq (block-prev block) prev)
-          (barf "bad PREV for ~S, should be ~S" block prev))
-        (unless (or (eq block tail)
-                    (eq (block-component block) c))
-          (barf "~S is not in ~S." block c)))
-#|
-      (when (or (loop-blocks c) (loop-inferiors c))
-        (do-blocks (block c :both)
-          (setf (block-flag block) nil))
-        (check-loop-consistency c nil)
-        (do-blocks (block c :both)
-          (unless (block-flag block)
-            (barf "~S was not in any loop." block))))
-|#
-    ))
-
-  (check-fun-consistency components)
-
-  (dolist (c components)
-    (do ((block (block-next (component-head c)) (block-next block)))
-        ((null (block-next block)))
-      (check-block-consistency block)))
-
-  (maphash (lambda (k v)
-             (declare (ignore k))
-             (unless (or (constant-p v)
-                         (and (global-var-p v)
-                              (member (global-var-kind v)
-                                      '(:global :special :unknown))))
-               (barf "strange *FREE-VARS* entry: ~S" v))
-             (dolist (n (leaf-refs v))
-               (check-node-reached n))
-             (when (basic-var-p v)
-               (dolist (n (basic-var-sets v))
-                 (check-node-reached n))))
-           *free-vars*)
-
-  (maphash (lambda (k v)
-             (declare (ignore k))
-             (unless (constant-p v)
-               (barf "strange *CONSTANTS* entry: ~S" v))
-             (dolist (n (leaf-refs v))
-               (check-node-reached n)))
-           *constants*)
-
-  (maphash (lambda (k v)
-             (declare (ignore k))
-             (unless (or (functional-p v)
-                         (and (global-var-p v)
-                              (eq (global-var-kind v) :global-function)))
-               (barf "strange *FREE-FUNS* entry: ~S" v))
-             (dolist (n (leaf-refs v))
-               (check-node-reached n)))
-           *free-funs*)
-  (clrhash *seen-funs*)
-  (clrhash *seen-blocks*)
-  (values))
+  (let ((*seen-blocks* (make-hash-table :test 'eq))
+        (*seen-funs* (make-hash-table :test 'eq)))
+    (unwind-protect
+         (progn
+           (dolist (c components)
+             (let* ((head (component-head c))
+                    (tail (component-tail c)))
+               (unless (and (null (block-pred head))
+                            (null (block-succ tail)))
+                 (barf "~S is malformed." c))
+
+               (do ((prev nil block)
+                    (block head (block-next block)))
+                   ((null block)
+                    (unless (eq prev tail)
+                      (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
+                 (setf (gethash block *seen-blocks*) t)
+                 (unless (eq (block-prev block) prev)
+                   (barf "bad PREV for ~S, should be ~S" block prev))
+                 (unless (or (eq block tail)
+                             (eq (block-component block) c))
+                   (barf "~S is not in ~S." block c)))
+               #|
+               (when (or (loop-blocks c) (loop-inferiors c))
+               (do-blocks (block c :both)
+               (setf (block-flag block) nil))
+               (check-loop-consistency c nil)
+               (do-blocks (block c :both)
+               (unless (block-flag block)
+               (barf "~S was not in any loop." block))))
+               |#
+               ))
+           (check-fun-consistency components)
+
+           (dolist (c components)
+             (do ((block (block-next (component-head c)) (block-next block)))
+                 ((null (block-next block)))
+               (check-block-consistency block)))
+
+           (maphash (lambda (k v)
+                      (declare (ignore k))
+                      (unless (or (constant-p v)
+                                  (and (global-var-p v)
+                                       (member (global-var-kind v)
+                                               '(:global :special :unknown))))
+                        (barf "strange *FREE-VARS* entry: ~S" v))
+                      (dolist (n (leaf-refs v))
+                        (check-node-reached n))
+                      (when (basic-var-p v)
+                        (dolist (n (basic-var-sets v))
+                          (check-node-reached n))))
+                    *free-vars*)
+
+           (maphash (lambda (k v)
+                      (declare (ignore k))
+                      (unless (constant-p v)
+                        (barf "strange *CONSTANTS* entry: ~S" v))
+                      (dolist (n (leaf-refs v))
+                        (check-node-reached n)))
+                    *constants*)
+
+           (maphash (lambda (k v)
+                      (declare (ignore k))
+                      (unless (or (functional-p v)
+                                  (and (global-var-p v)
+                                       (eq (global-var-kind v) :global-function)))
+                        (barf "strange *FREE-FUNS* entry: ~S" v))
+                      (dolist (n (leaf-refs v))
+                        (check-node-reached n)))
+                    *free-funs*))
+      (clrhash *seen-blocks*)
+      (clrhash *seen-funs*))
+    (values)))
 \f
 ;;;; function consistency checking
 

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 4190d37..9dbe9bc 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -17,7 +17,7 @@
 (declaim (special *constants* *free-vars* *component-being-compiled*
                   *code-vector* *next-location* *result-fixups*
                   *free-funs* *source-paths*
-                  *seen-blocks* *seen-funs* *list-conflicts-table*
+                  *list-conflicts-table*
                   *continuation-number* *continuation-numbers*
                   *number-continuations* *tn-id* *tn-ids* *id-tns*
                   *label-ids* *label-id* *id-labels*
@@ -746,8 +746,6 @@ Examples:
 (defun clear-stuff (&optional (debug-too t))
 
   ;; Clear debug counters and tables.
-  (clrhash *seen-blocks*)
-  (clrhash *seen-funs*)
   (clrhash *list-conflicts-table*)
 
   (when debug-too