Re: [cmucl-help] 19d pre1 tagged, binaries coming soon.

My testing has been confined to the previous tests that I sent you and
the (somewhat limited) use of weak-pointers and finalizations in
FREEDIUS.  Here is the latest version of the
weak-pointer/weak-hashtable test code:

_____________________________________________________________

#+cmu 
(eval-when (eval load compile)
  (pushnew :hack-swank *features*)
  )

#+hack-swank
(in-package :swank)

#+hack-swank
(eval-when (eval load compile)
(import '(ext::weak-pointer-p ext::weak-pointer-value ext::make-weak-pointer))
) ; end eval-when

#+hack-swank
(progn

(defun weak-value-gethash (key ht &optional default)  
  "Access hash-table with weak value."
  (multiple-value-bind (val foundp) (gethash key ht)
    (if foundp
	(values (if (weak-pointer-p val)
		    (weak-pointer-value val)
		    val)
		foundp)
	default)))

(defun (setf weak-value-gethash) (object key ht &optional default)  
  (declare (ignore default))
  "Access hash-table with weak value."
  (if (and object (not (weak-pointer-p object))) ; FIXME to selectively wrap with a weak-pointer.
      (setf (gethash key ht) (make-weak-pointer object))
      (setf (gethash key ht) object))
  object)

(defun save-presented-object (object)
  "Save OBJECT and return the assigned id.
If OBJECT was saved previously return the old id."
  (or (gethash object *object-to-presentation-id*)
      (let ((id (incf *presentation-counter*)))
        (setf (weak-value-gethash id *presentation-id-to-object*) object)
        (setf (gethash object *object-to-presentation-id*) id)
        id)))

(defun lookup-presented-object (id)
  "Retrieve the object corresponding to ID.
The secondary value indicates the absence of an entry."
  (weak-value-gethash id *presentation-id-to-object*))

) ; end #+hack-swank progn

(in-package :cl-user)

#+cmu
(progn

(import '(ext::make-weak-pointer ext::weak-pointer-p))

(defun make-weak-hash-table ()
  (make-hash-table :test #'eql :weak-p t))

(defun full-gc ()
  ;(time  (ext:gc :full t))
  (ext:gc :full t))

) ; end #+cmu progn

#+allegro
(progn

(defun make-weak-pointer (x)
  (let ((wv (excl::weak-vector 1)))
    (setf (aref wv 0) x)
    wv))

(defun make-weak-hash-table ()
  (make-hash-table :weak-keys t))

(defun full-gc ()
  (excl:gc t))

) ; end #+allegro progn

;; When CMUCL garbages a weak-pointer, this allows printing to be more informative.
(defun carefully-print-sexpr (x)
  (handler-case (format t "   ~s~%" x)
    (error ()
      (if (listp x)
	  (progn (write-char #\()
		 (loop for y in x
		       do (carefully-print-sexpr y)
			  (write-char #\space)
			  (write-char #\))))
	  (handler-case (progn (format t "<bad element: type = ~a>" (type-of x)) (force-output))
	    (error () (format t "<very bad type>") (force-output)))))))

(defun print-hash-table (ht)
  (maphash #'(lambda (key val) 
	       (format t "~s = " key)
	       (carefully-print-sexpr val))
	   ht))

(defparameter *WEAK-EVAL-CACHE-KEY-HT* (make-hash-table :test #'equal))

(defvar *key-lists* t)

(defun make-weak-eval-cache-key (key)
  (if *key-lists*
      (let ((key (list key)))
	;; make sure EQUAL keys are EQ.
	(or (gethash key *WEAK-EVAL-CACHE-KEY-HT*)
	    (setf (gethash key *WEAK-EVAL-CACHE-KEY-HT*) key)))
      key))


(defclass foo () ())

(defparameter *foo-instance-counter* 0)

;;; These make-a-foo varients are attempts to understand the nature of the bug.
;;; See test results below.

(defun make-a-foo (ht)
  (let* ((id (incf *foo-instance-counter*))
	 (key (make-weak-eval-cache-key id))
	 (o (make-instance 'foo)))
    (setf (gethash key ht) 
	  (make-weak-pointer o))
    o))

(defun make-a-foo-list-val (ht)
  (let* ((id (incf *foo-instance-counter*))
	 (o (make-instance 'foo))
	 (key (make-weak-eval-cache-key id)))
    (setf (gethash key ht) 
	  (list (make-weak-pointer o)))
    o))

(defparameter *foo-alist* nil)

;;; This builds the association of id with foo instance in an alist rather than a hash-table.
(defun alist-make-a-foo (ignore)
  (declare (ignore ignore))
  (let* ((id (incf *foo-instance-counter*))
	 (o (make-instance 'foo))
	 (key (make-weak-eval-cache-key id)))
    (push (cons key (make-weak-pointer o))
	  *foo-alist*)
    o))

(defun alist-make-a-foo-list-val (ignore) 
  (declare (ignore ignore))
  (let* ((id (incf *foo-instance-counter*))(o (make-instance 'foo))
	 (key (make-weak-eval-cache-key id)))
    (push (cons key (list (make-weak-pointer o)))
	  *foo-alist*)
    o))

(defvar *foo-ht*)

(defparameter *n-foos* 2)

(defun print-foos ()
  (if *foo-ht*
      (print-hash-table *foo-ht*)
      (carefully-print-sexpr *foo-alist*)))

(defparameter *cons-cnt* 100000)

(defun cons-a-lot (&optional (n *cons-cnt*))
  (loop repeat n collect nil))

;; This version (usually) works in all combinations of CMUCL/Allegro and SLIME/not SLIME.
;;   For some reason, CMUCL/not-SLIME fails all cases except (foo-test 'make-a-foo (make-hash-table))
;; With the call to print-foos removed , weak-pointers get broken.
;; Running interpreted runs sucessfully, compiled (sometimes) fails.
(defun foo-test (maker-fn &key (weak-p nil) (n *n-foos*) (key-lists t))
  (format t "Running (foo-test ~a :weak-p=~a :key-lists=~a)~%" maker-fn weak-p key-lists)
  (setq *foo-ht* (unless (eq maker-fn 'alist-make-a-foo)
		   (if weak-p (make-weak-hash-table ) (make-hash-table )))
	*foo-alist* nil)
  (let* ((*key-lists* key-lists)
	 (foos (loop for i from 0 below n
		     collect (funcall maker-fn *foo-ht*))))
    
    )
  (cons-a-lot) ; this is needed in order for the weak-pointers to break(recurse-deeply-to-clean-stack)
  ;;(recurse-deeply-to-clean-stack) ; this doesn't help
  (full-gc)
  *foo-ht*)

(defun print-one-foo ()
  (if *foo-ht*
      (loop for val being the hash-values of *foo-ht*
	    using (hash-key key)
	    repeat 1 
	    do (format t "~s =~%" key)
	       (carefully-print-sexpr val))
      (carefully-print-sexpr (first *foo-alist*))))

(defun recurse-deeply-to-clean-stack (&optional (n 100))
  (declare (optimize (debug 3))) ; force tail-call optimization off
  (when (> n 0)
    (recurse-deeply-to-clean-stack (1- n))))

(defun gc-and-print-foos (n)
  (progn (setq * nil ** nil *** nil 
	       ;; $ nil $$ nil $$$ nil 
	       / nil // nil /// nil)
	 (clrhash swank::*object-to-presentation-id*)
	 (clrhash swank::*presentation-id-to-object*) 
	 (swank::reset-inspector))
  (loop repeat n
	do (cons-a-lot)
	   (full-gc)
	   (print-foos)))


#|
(load (compile-file "/homedir/quam/lisp/cmucl-bugs/20060704-weak-bug6.lisp"))
#+cmu (setq ext::*gc-verbose* nil)

(foo-test 'alist-make-a-foo)
(gc-and-print-foos 5)

(foo-test 'alist-make-a-foo :key-lists nil)
(gc-and-print-foos 5)

(foo-test 'make-a-foo)
(gc-and-print-foos 5)

(foo-test 'make-a-foo-list-val)
(gc-and-print-foos 5)

(foo-test 'make-a-foo :key-lists nil)
(gc-and-print-foos 5)

(foo-test 'make-a-foo-list-val :key-lists nil)
(gc-and-print-foos 5)

(foo-test 'make-a-foo :weak-p t)
(gc-and-print-foos 5)

(foo-test 'make-a-foo-list-val :weak-p t)
(gc-and-print-foos 5)

|#
__________________________________________________________

>  
>  >>>>> "Lynn" == Lynn Quam <[email protected]> writes:
>  
>      Lynn> I wish to report that cmucl-19d-pre1-x86-linux (and
>      Lynn> cmucl-2006-10-x86-linux) appears to function properly with FREEDIUS, a
>      Lynn> large image/graphics intensive system.  My tests included the previous
>      Lynn> ones using weak pointers, weak hashtables, and finalization.
>  
>  That's really great news!  Are you only using weak key hashtables?  Or
>  are you also using some of the other weak hashtables?
>  
>  Thanks for testing this!
>  
>  Ray
>