X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=d38b355a12a9d422f214029d9f215d2d16893b33;hb=746c4003dd76ea67647c87176e4c818f512d59b7;hp=7e2139806014d065d9c9d1f6fa11b8ae8e856056;hpb=5cf3c4259d529e180d75d4d140f344e600d2b06b;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 7e21398..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)))) - (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 @@ -463,8 +464,7 @@ (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))))) @@ -931,11 +931,6 @@ (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)) @@ -1009,7 +1004,12 @@ (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