<html><head></head><body 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; color: rgb(0, 0, 0); font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; orphans: 2; text-align: auto; 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: 0; "><span class="Apple-style-span" style="border-collapse: separate; border-spacing: 0px 0px; color: rgb(0, 0, 0); font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; text-align: auto; -khtml-text-decorations-in-effect: none; text-indent: 0px; -apple-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; border-spacing: 0px 0px; color: rgb(0, 0, 0); font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; text-align: auto; -khtml-text-decorations-in-effect: none; text-indent: 0px; -apple-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; border-spacing: 0px 0px; color: rgb(0, 0, 0); font-family: Helvetica; font-size: 12px; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; text-align: auto; -khtml-text-decorations-in-effect: none; text-indent: 0px; -apple-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"><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></p><p style="margin: 0.0px 0.0px 0.0px 0.0px"><font face="Helvetica" size="3" style="font: 12.0px Helvetica"><br></font></p><p style="margin: 0.0px 0.0px 0.0px 0.0px"><font face="Helvetica" size="3" style="font: 12.0px Helvetica"><br></font></p><p style="margin: 0.0px 0.0px 0.0px 0.0px">;;;; ========== in case you want to run this, here is the queue.lisp file ======</p><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><p style="margin: 0.0px 0.0px 0.0px 0.0px"><font face="Helvetica" size="3" style="font: 12.0px Helvetica"><br></font></p><p style="margin: 0.0px 0.0px 0.0px 0.0px"><font face="Helvetica" size="3" style="font: 12.0px Helvetica">Prof. Alexander Repenning</font></p><p style="margin: 0.0px 0.0px 0.0px 0.0px"><br class="khtml-block-placeholder"></p><p style="margin: 0.0px 0.0px 0.0px 0.0px">University of Colorado</p><p style="margin: 0.0px 0.0px 0.0px 0.0px">Computer Science Department</p><p style="margin: 0.0px 0.0px 0.0px 0.0px">Boulder, CO 80309-430</p><p style="margin: 0.0px 0.0px 0.0px 0.0px"><br class="khtml-block-placeholder"></p><p style="margin: 0.0px 0.0px 0.0px 0.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></p><br class="Apple-interchange-newline"></span></span></span></span>
</div>
<br></body></html>