;;; 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.
;;; 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))))
- (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
(let ((leaf (ref-leaf node)))
(when (functional-p leaf)
(if (eq (functional-kind leaf) :toplevel-xep)
- (unless (eq (component-kind (block-component (node-block node)))
- :toplevel)
+ (unless (component-toplevelish-p (block-component (node-block node)))
(barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
node))
(check-fun-reached leaf node)))))
(symbol (block-or-lose (gethash thing *free-funs*)))))
;;; Print cN.
-(defun print-continuation (cont)
- (declare (type continuation cont))
- (format t " c~D" (cont-num cont))
- (values))
-
(defun print-ctran (cont)
(declare (type ctran cont))
(format t "c~D " (cont-num cont))
(case (cleanup-kind cleanup)
((:dynamic-extent)
(format t "entry DX~{ v~D~}"
- (mapcar #'cont-num (cleanup-info cleanup))))
+ (mapcar (lambda (lvar-or-cell)
+ (if (consp lvar-or-cell)
+ (cons (car lvar-or-cell)
+ (cont-num (cdr lvar-or-cell)))
+ (cont-num lvar-or-cell)))
+ (cleanup-info cleanup))))
(t
(format t "entry ~S" (entry-exits node))))))
(exit
projects / sbcl.git / blobdiff