a bug affecting debugging in PCL

[rharris@rdrc.rpi.edu]

There is a bug in the implementation of *print-circle* that
causes some akcl debugging commands (including :bt and :bl)
to cause the following error when PCL is being used:
Unrecoverable error: value stack overflow.

If you are using PCL, add the following lines to the file
pcl/kcl-patches.lisp, after the (in-package "COMPILER") form:


;When a CLOS object is printed, travel_push_object ends up 
;traversing almost the whole class structure, thereby overflowing
;the value-stack.

;from lsp/debug.lsp.
;*print-circle* is badly implemented in kcl.
;it has two separate problems that should be fixed: 
;  1. it traverses the printed object putting all objects found
;     on the value stack (rather than in a hash table or some
;     other structure; this is a problem because the size of the value stack
;     is fixed, and a potentially unbounded number of objects 
;     need to be traversed), and 
;  2. it blindly traverses all slots of any
;     kind of structure including std-object structures.
;     This is safe, but not always necessary, and is very time-consuming
;     for CLOS objects (because it will always traverse every class).

;For now, avoid using *print-circle* T when it will cause problems.
(progn

(eval-when (compile eval)
(defmacro si::f (op &rest args)
    `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))

(defmacro si::fb (op &rest args)
    `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
)

(defun si::display-env (n env)
  (do ((v (reverse env) (cdr v)))
      ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))
    (or (and (consp (car v))
	     (listp (cdar v)))
	(return))
    (let ((*print-circle* (can-use-print-circle-p (cadar v))))
      (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))

(defun si::display-compiled-env ( plength ihs &aux
				      (base (si::ihs-vs ihs))
				      (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))
  (format si::*display-string* "")
  (do ((i base )
       (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))
      ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))
    (let ((*print-circle* (can-use-print-circle-p (si::vs i))))
    (format si::*display-string* "~a~@[~d~]=~s~@[,~]"
	    (or (car v)  'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)
	    (si::fb < (setq i (si::f + i 1)) end)))))

(defun can-use-print-circle-p (x)
  (typecase x
    (vector  (or (not (eq 't (array-element-type x)))
		 (every #'can-use-print-circle-p x)))
    (cons    (and (can-use-print-circle-p (car x))
		  (can-use-print-circle-p (cdr x))))
    (array   (or (not (eq 't (array-element-type x)))
		 (let* ((rank (array-rank x))
			(dimensions (make-list rank)))
		   (dotimes (i rank)
		     (setf (nth i dimensions) (array-dimension x i)))
		   (or (member 0 dimensions)
		       (do ((cursor (make-list rank :initial-element 0)))
			   (nil)
			 (declare (:dynamic-extent cursor))
			 (unless (can-use-print-circle-p (apply #'aref x cursor))
			   (return nil))
			 (when (si::increment-cursor cursor dimensions)
			   (return t)))))))
    (t (or (not (si:structurep x))
	   (let* ((def (si:structure-def x))
		  (name (si::s-data-name def))
		  (len (si::s-data-length def)))
	     (and (not (eq name 'pcl::std-instance))
		  (dotimes (i len t)
		    (unless (can-use-print-circle-p (si:structure-ref x name i))
		      (return nil)))))))))
)