From 746c4003dd76ea67647c87176e4c818f512d59b7 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 25 Sep 2012 13:52:23 +0300 Subject: [PATCH] bind and clear *SEEN-FUNS* and *SEEN-BLOCKS* in CHECK-IR1-CONSISTENCY --- src/compiler/debug.lisp | 149 ++++++++++++++++++++++++----------------------- src/compiler/main.lisp | 4 +- 2 files changed, 76 insertions(+), 77 deletions(-) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 2997e90..d38b355 100644 --- 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))) ;;;; function consistency checking diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 4190d37..9dbe9bc 100644 --- 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 -- 1.7.10.4