<html><head></head><body style="word-wrap: break-word; -webkit-nbsp-mode: space; -webkit-line-break: after-white-space; ">Alex,<div><br></div><div>I have some code that implements a thread-safe queue that requires no synchronization between readers and writers (so a single reader and single writer never wait). Multiple readers will wait for exclusive read access before dequeuing and multiple writers will wait for exclusive write access before queuing something. If you think that would be useful to you let me know and I'll send it to you.<div><br></div><div>Paul</div><div><br><div><div>On Jul 12, 2011, at 10:14 AM, Alexander Repenning wrote:</div><br class="Apple-interchange-newline"><blockquote type="cite"><div style="word-wrap: break-word; -webkit-nbsp-mode: space; -webkit-line-break: after-white-space; "><div><span class="Apple-style-span" style="border-collapse: separate; font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; orphans: 2; text-indent: 0px; text-transform: none; white-space: normal; widows: 2; word-spacing: 0px; -webkit-border-horizontal-spacing: 0px; -webkit-border-vertical-spacing: 0px; -webkit-text-decorations-in-effect: none; -webkit-text-size-adjust: auto; -webkit-text-stroke-width: 0px; "><span class="Apple-style-span" style="border-collapse: separate; -webkit-border-horizontal-spacing: 0px; -webkit-border-vertical-spacing: 0px; font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; -webkit-text-decorations-in-effect: none; text-indent: 0px; -webkit-text-size-adjust: auto; text-transform: none; orphans: 2; white-space: normal; widows: 2; word-spacing: 0px; "><span class="Apple-style-span" style="border-collapse: separate; -webkit-border-horizontal-spacing: 0px; -webkit-border-vertical-spacing: 0px; font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; -webkit-text-decorations-in-effect: none; text-indent: 0px; -webkit-text-size-adjust: auto; text-transform: none; orphans: 2; white-space: normal; widows: 2; word-spacing: 0px; "><span class="Apple-style-span" style="border-collapse: separate; -webkit-border-horizontal-spacing: 0px; -webkit-border-vertical-spacing: 0px; font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; -webkit-text-decorations-in-effect: none; text-indent: 0px; -webkit-text-size-adjust: auto; text-transform: none; orphans: 2; white-space: normal; widows: 2; word-spacing: 0px; "><p style="margin: 0.0px 0.0px 0.0px 0.0px"><font face="Helvetica" size="3" style="font: 12.0px Helvetica"></font></p><font face="Helvetica" size="3" style="font: 12.0px Helvetica"><div><span class="Apple-style-span" style="font-size: medium;">Does somebody have some good code to funcall a function in a different thread? Here is an attempt that kind of works using a semaphore and a queue. That other tread should get started if it does not exist but it should not burn any cpu after the function is called. Especially when piping high frequency gui events (e.g., mouse moved) through this it is simple to overrun the buffer which can be really bad (e.g., missing a mouse up of a drag and drop).</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;">(in-package :xlui)</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;">(defclass THREAD-INTERFACE ()</span></div><div><span class="Apple-style-span" style="font-size: medium;"> ((function-queue :accessor function-queue :initform (make-instance 'queue :size 100))</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (semaphore :accessor semaphore :initform (ccl::make-semaphore))</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (process :accessor process :initform nil :initarg :process)))</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;">(defvar *Thread-Interfaces* (make-hash-table :test 'equal))</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;">(defun FUNCALL-IN-THREAD (Thread-Name Function)</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (let ((Interface (or (gethash Thread-Name *Thread-Interfaces*)</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (setf (gethash Thread-Name *Thread-Interfaces*) </span></div><div><span class="Apple-style-span" style="font-size: medium;"> (make-instance 'thread-interface)))))</span></div><div><span class="Apple-style-span" style="font-size: medium;"> ;; start process if needed</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (unless (process Interface)</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (setf (process Interface)</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (ccl::process-run-function </span></div><div><span class="Apple-style-span" style="font-size: medium;"> Thread-Name</span></div><div><span class="Apple-style-span" style="font-size: medium;"> #'(lambda ()</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (loop</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (ccl::wait-on-semaphore (semaphore Interface))</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (let ((User-Action (dequeue (function-queue Interface))))</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (when User-Action </span></div><div><span class="Apple-style-span" style="font-size: medium;"> (funcall User-Action))))))))</span></div><div><span class="Apple-style-span" style="font-size: medium;"> ;; push function into queue and wake up thread</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (enqueue (function-queue Interface) Function)</span></div><div><span class="Apple-style-span" style="font-size: medium;"> (ccl::signal-semaphore (semaphore Interface))))</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;">#| Examples:</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;">(funcall-in-thread "User Action" #'(lambda () (print ccl::*current-process*)))</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;">(funcall-in-thread "Service 2" #'(lambda () (print ccl::*current-process*)))</span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><div><span class="Apple-style-span" style="font-size: medium;"><br></span></div><span class="Apple-style-span" style="font-size: medium;">|#</span></font><div><br class="webkit-block-placeholder"></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; "><font face="Helvetica" size="3" style="font: 12.0px Helvetica"><br></font></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; "><font face="Helvetica" size="3" style="font: 12.0px Helvetica"><br></font></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; ">;;;; ========== in case you want to run this, here is the queue.lisp file ======</div><div><br></div><div><div>;;-*- Mode: Lisp; Package: xlui -*-</div><div>;*********************************************************************</div><div>;* *</div><div>;* Q U E U E *</div><div>;* *</div><div>;*********************************************************************</div><div> ;* Author : Alexander Repenning (<a href="mailto:alexander@agentsheets.com">alexander@agentsheets.com</a>) *</div><div> ;* <a href="http://www.agentsheets.com/">http://www.agentsheets.com</a> *</div><div> ;* Copyright : (c) 1996-2011, AgentSheets Inc. *</div><div> ;* Filename : queue.lisp *</div><div> ;* Updated : 02/16/06 *</div><div> ;* Version : *</div><div> ;* 1.0 : 02/16/06 *</div><div> ;* HW/SW : G4, OS X 10.4.4, MCL 5 *</div><div> ;* Abstract : A generic, static (no GC) queue *</div><div> ;* Portable : white: plain Common Lisp *</div><div> ;* *</div><div> ;******************************************************************</div><div><br></div><div>(in-package :xlui)</div><div><br></div><div><br></div><div>(defclass QUEUE ()</div><div> ((items :accessor items :initform nil :documentation "array of item")</div><div> (size :accessor size :initform 50 :initarg :size :documentation "static allocation size for no GC queue")</div><div> (thread-safe-p :accessor thread-safe-p :initform nil :initarg :thread-safe-p :documentation "If true uses a lock to make the queue thread safe")</div><div> (queue-lock :accessor queue-lock :initform nil)</div><div> (in :accessor in :initform 0)</div><div> (out :accessor out :initform 0))</div><div> (:documentation "static queue with no GC: good for things such as event queues"))</div><div><br></div><div><br></div><div>(defclass NAMED-QUEUE-ITEM ()</div><div> ((name :accessor name :initarg :name :type symbol :documentation "unique name of queue item")</div><div> (value :accessor value :initarg :value :documentation "the actual item"))</div><div> (:documentation "queue item with a name"))</div><div><br></div><div>;_____________________________________</div><div>; Specification |</div><div>;_____________________________________</div><div><br></div><div><br></div><div>(defgeneric ENQUEUE (Queue Item &key Unique-Name)</div><div> (:documentation "Put <Item> into <Queue>. </div><div>Items with a <Unique-Name> will overwrite previous items in queue with same name."))</div><div><br></div><div><br></div><div>(defgeneric DEQUEUE (Queue)</div><div> (:documentation "Get <Item> from <Queue>"))</div><div><br></div><div><br></div><div>(defgeneric IS-EMPTY (Queue)</div><div> (:documentation "true if there are no items left in queue"))</div><div><br></div><div><br></div><div>(defgeneric QUEUE-IS-FULL-HANDLER (Queue)</div><div> (:documentation "called when queue got filled up. Default action is to do nothing"))</div><div><br></div><div>;_____________________________________</div><div>; Implementation |</div><div>;_____________________________________</div><div><br></div><div><br></div><div>(defmethod INITIALIZE-INSTANCE :after ((Self queue) &rest Initargs)</div><div> (declare (ignore Initargs))</div><div> (incf (size Self)) ;; need one more space to be able to differntiate between full and empty</div><div> (setf (items Self) (make-array (size Self)))</div><div> ;; dead with thread safety </div><div> (when (thread-safe-p Self)</div><div> (setf (queue-lock Self) (ccl::make-lock "Queue Lock"))))</div><div><br></div><div><br></div><div>(defmethod GRAB-LOCK-IF-NECESSARY ((Self queue))</div><div> (when (queue-lock Self) (ccl::grab-lock (queue-lock Self))))</div><div><br></div><div><br></div><div>(defmethod RELEASE-LOCK-IF-NECESSARY ((Self queue))</div><div> (when (queue-lock Self) (ccl::release-lock (queue-lock Self))))</div><div><br></div><div><br></div><div>(defmethod IS-EMPTY ((Self queue))</div><div> (grab-lock-if-necessary Self)</div><div> (unwind-protect</div><div> (= (in Self) (out Self))</div><div> (release-lock-if-necessary Self)))</div><div><br></div><div><br></div><div>(defmethod UNPROTECTED-ENQUEUE ((Self queue) Item)</div><div> (cond</div><div> ((= (out Self) (mod (1+ (in Self)) (size Self)))</div><div> (queue-is-full-handler Self))</div><div> (t</div><div> (setf (aref (items Self) (in Self)) Item)</div><div> (setf (in Self) (mod (1+ (in Self)) (size Self))))))</div><div><br></div><div><br></div><div>(defmethod ENQUEUE ((Self queue) Item &key Unique-Name)</div><div> (grab-lock-if-necessary Self)</div><div> (unwind-protect</div><div> (cond</div><div> (Unique-Name</div><div> (let ((Existing-Item (find Unique-Name (items Self) :key #'(lambda (x) (typecase x (named-queue-item (name x)) (t nil))))))</div><div> (if Existing-Item</div><div> (setf (value Existing-Item) Item)</div><div> (unprotected-enqueue Self (make-instance 'named-queue-item :name Unique-Name :value Item)))))</div><div> (t</div><div> (unprotected-enqueue Self Item)))</div><div> (release-lock-if-necessary Self)))</div><div> </div><div><br></div><div>(defmethod DEQUEUE ((Self queue))</div><div> (grab-lock-if-necessary Self)</div><div> (unwind-protect</div><div> (unless (is-empty Self)</div><div> (prog1</div><div> (let ((Item (aref (Items Self) (out Self))))</div><div> (typecase Item</div><div> (named-queue-item </div><div> (setf (aref (Items Self) (out Self)) nil) ;; need to get rid of the named items, otherwise enque will find it</div><div> (value Item))</div><div> (t Item)))</div><div> (setf (out Self) (mod (1+ (out Self)) (size Self)))))</div><div> (release-lock-if-necessary Self)))</div><div><br></div><div><br></div><div>(defmethod QUEUE-IS-FULL-HANDLER ((Self queue))</div><div> (warn "queue is full"))</div><div><br></div><div><br></div><div><br></div><div>#| Examples:</div><div><br></div><div><br></div><div>(defparameter *Queue* (make-instance 'queue :size 4))</div><div><br></div><div>(enqueue *Queue* (random 100))</div><div><br></div><div>(dequeue *Queue*)</div><div><br></div><div>(is-empty *Queue*)</div><div><br></div><div><br></div><div>(defparameter *Queue* (make-instance 'queue :size 4 :thread-safe-p t))</div><div><br></div><div>(defparameter *Queue* (make-instance 'queue :size 10))</div><div><br></div><div>(enqueue *Queue* (print (random 100)) :unique-name :secret-code)</div><div><br></div><div>(dequeue *Queue*)</div><div><br></div><div><br></div><div><br></div><div><br></div><div><br></div><div><br></div><div>|#</div></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; "><font face="Helvetica" size="3" style="font: 12.0px Helvetica"><br></font></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; "><font face="Helvetica" size="3" style="font: 12.0px Helvetica">Prof. Alexander Repenning</font></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; "><br class="khtml-block-placeholder"></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; ">University of Colorado</div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; ">Computer Science Department</div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; ">Boulder, CO 80309-430</div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; "><br class="khtml-block-placeholder"></div><div style="margin-top: 0px; margin-right: 0px; margin-bottom: 0px; margin-left: 0px; "><font face="Helvetica" size="3" style="font: 12.0px Helvetica">vCard: <a href="http://www.cs.colorado.edu/~ralex/AlexanderRepenning.vcf">http://www.cs.colorado.edu/~ralex/AlexanderRepenning.vcf</a></font></div><br class="Apple-interchange-newline"></span></span></span></span>
</div>
<br></div>_______________________________________________<br>Openmcl-devel mailing list<br><a href="mailto:Openmcl-devel@clozure.com">Openmcl-devel@clozure.com</a><br>http://clozure.com/mailman/listinfo/openmcl-devel<br></blockquote></div><br></div></div></body></html>