Content-Type: multipart/appledouble;
	boundary=Apple-Mail-88--520575935
Content-Disposition: attachment


--Apple-Mail-88--520575935
Content-Transfer-Encoding: base64
Content-Type: application/applefile;
	name=queue-memory-test.lisp
Content-Disposition: attachment;
	filename=queue-memory-test.lisp

AAUWBwACAAAAAAAAAAAAAAAAAAAAAAAAAAMAAAAJAAAAPgAAAAoAAAADAAAASAAAABYAAAACAAAA
XgAAAc1URVhUQ0NMMgAAcXVldWUtbWVtb3J5LXRlc3QubGlzcAAAAQAAAAFvAAAAbwAAAF4AAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAKAAEABAkAAQAAAAAAAAlIUwZNb25hY28AAAAEAAAAAAAAAEgACU1vbmFjbwAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAYACAD8ACQD+QL1APwAJAP5AvUAAAAAAAAA6QAAAOkA
AAAAAQAAAAEAAAABbwAAAG8AAABeAAmQgAD5AAAAHABeAAFGUkVEAAIAEk1QU1IAAAA2AAL//wAA
AAAAAAAAAAP//wAAAA4AAAAAAAb//wAAABsAAAAAA+3//wAAACMAbNCg

--Apple-Mail-88--520575935
Content-Transfer-Encoding: 7bit
Content-Id: <9876A41E-C734-4F03-B46A-D5CC585BFAE8@local>
Content-Type: application/octet-stream; x-mac-type=54455854; x-unix-mode=0644; 
	x-mac-creator=43434C32; name=queue-memory-test.lisp
Content-Disposition: attachment;
	filename=queue-memory-test.lisp

;;; queue memory test
;;;
;;; this demonstrates that memory which has been allocated in a new thread is not released until the 
;;; thread itself has been released.
;;;
;;; all of sbcl 1.0.45, 1.0.50, and 1.0.55 retained the memory.

(in-package :cl-user)

(require :sb-concurrency)

(defparameter *queue-pointer* ())
(defparameter *queue-header* ())
(defparameter *page-count* 0)
(defparameter *thread-semaphore* (sb-concurrency::make-semaphore :name "thread semaphore" :count 0))
(defparameter *queue-semaphore* (sb-concurrency::make-semaphore :name "queue semaphore" :count 0))
(defvar *thread* nil)

(defun make-page (length width)
  (incf *page-count*)
  (make-array (list length width) :element-type 'fixnum))

(defun clear-q ()
  (setq *queue-header* (list nil))
  (setq *queue-pointer* *queue-header*))
  
(defun nq (data)
  (let ((elt (list data)))
    (setf (cdr *queue-pointer*) elt)
    #+sb-thread (sb-thread:barrier (:write))
    (setf *queue-pointer* elt))
  (sb-thread:signal-semaphore *queue-semaphore*)
  data)

(defun dq ()
  (sb-thread:wait-on-semaphore *queue-semaphore*)
  (if (eq *queue-pointer* *queue-header*)
    (error "released to an empty queue."))
  (let ((value (cadr *queue-header*)))
    (setf *queue-header* (cdr *queue-header*))
    value))

(defun fill-q (&key (count 1024))
  (dotimes (x count)
    (let ((page (make-page 512 6)))
      (dotimes (i (array-dimension page 0))
        (dotimes (j (array-dimension page 1))
          (setf (aref page i j) (* i j))))
      (nq page)))
  (nq nil))

(defun drain-q ()
  (loop for page = (dq)
        until (null page)
        sum (array-dimension page 0)))

(defun run-q-from-new (&key (count 4096) (wait t))
  (let ((thread (sb-thread:make-thread
                 #'(lambda ()
                     (fill-q :count count)
                     (when wait (sb-thread:wait-on-semaphore *thread-semaphore*))))))
    (drain-q)
    thread))

(defun run-q-to-new (&key (count 4096) (wait t))
  (let ((thread (sb-thread:make-thread
                 #'(lambda ()
                     (drain-q)
                     (when wait (sb-thread:wait-on-semaphore *thread-semaphore*))))))
    (fill-q :count count)
    thread))


;;; (clear-q)
;;; (setq *thread* (run-q-from-new))
;;; (sb-ext:gc :full t)  ; 4k+ arrays still appear in room
;;; (sb-thread:signal-semaphore *thread-semaphore*)
;;; (sb-ext:gc :full t)  ; the pages no longer appear
;;; (setq *thread* nil*) ; on occasion this was required in order to release the arrays


;;; alternatively
;;; (setq *thread* (run-q-to-new))


--Apple-Mail-88--520575935--