[Openmcl-devel] FUNCALL-IN-THREAD how to call a function in a different thread

[Alexander Repenning]

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).



(in-package :xlui)


(defclass THREAD-INTERFACE ()
  ((function-queue :accessor function-queue :initform (make-instance 'queue :size 100))
   (semaphore :accessor semaphore :initform (ccl::make-semaphore))
   (process :accessor process :initform nil :initarg :process)))


(defvar *Thread-Interfaces* (make-hash-table :test 'equal))


(defun FUNCALL-IN-THREAD (Thread-Name Function)
  (let ((Interface (or (gethash Thread-Name *Thread-Interfaces*)
                       (setf (gethash Thread-Name *Thread-Interfaces*) 
                             (make-instance 'thread-interface)))))
    ;; start process if needed
    (unless (process Interface)
      (setf (process Interface)
            (ccl::process-run-function 
             Thread-Name
             #'(lambda ()
                 (loop
                   (ccl::wait-on-semaphore (semaphore Interface))
                   (let ((User-Action (dequeue (function-queue Interface))))
                     (when User-Action 
                       (funcall User-Action))))))))
    ;; push function into queue and wake up thread
    (enqueue (function-queue Interface) Function)
    (ccl::signal-semaphore (semaphore Interface))))



#| Examples:


(funcall-in-thread "User Action" #'(lambda () (print ccl::*current-process*)))

(funcall-in-thread "Service 2" #'(lambda () (print ccl::*current-process*)))


|#


;;;; ========== in case you want to run this, here is the queue.lisp file ======

;;-*- Mode: Lisp; Package: xlui -*-
;*********************************************************************
;*                                                                   *
;*                      Q U E U E                                    *
;*                                                                   *
;*********************************************************************
   ;* Author    : Alexander Repenning (alexander at agentsheets.com)    *
   ;*             http://www.agentsheets.com                         *
   ;* Copyright : (c) 1996-2011, AgentSheets Inc.                    *
   ;* Filename  : queue.lisp                                         *
   ;* Updated   : 02/16/06                                           *
   ;* Version   :                                                    *
   ;*    1.0    : 02/16/06                                           *
   ;* HW/SW     : G4, OS X 10.4.4, MCL 5                             *
   ;* Abstract  : A generic, static (no GC) queue                    *
   ;* Portable  : white: plain Common Lisp                           *
   ;*                                                                *
   ;******************************************************************

(in-package :xlui)


(defclass QUEUE ()
  ((items :accessor items :initform nil :documentation "array of item")
   (size :accessor size :initform 50 :initarg :size :documentation "static allocation size for no GC queue")
   (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")
   (queue-lock :accessor queue-lock :initform nil)
   (in :accessor in :initform 0)
   (out :accessor out :initform 0))
  (:documentation "static queue with no GC: good for things such as event queues"))


(defclass NAMED-QUEUE-ITEM ()
  ((name :accessor name :initarg :name :type symbol :documentation "unique name of queue item")
   (value :accessor value :initarg :value :documentation "the actual item"))
  (:documentation "queue item with a name"))

;_____________________________________
; Specification                       |
;_____________________________________


(defgeneric ENQUEUE (Queue Item &key Unique-Name)
  (:documentation "Put <Item> into <Queue>. 
Items with a <Unique-Name> will overwrite previous items in queue with same name."))


(defgeneric DEQUEUE (Queue)
  (:documentation "Get <Item> from <Queue>"))


(defgeneric IS-EMPTY (Queue)
  (:documentation "true if there are no items left in queue"))


(defgeneric QUEUE-IS-FULL-HANDLER (Queue)
  (:documentation "called when queue got filled up. Default action is to do nothing"))

;_____________________________________
; Implementation                      |
;_____________________________________


(defmethod INITIALIZE-INSTANCE :after ((Self queue) &rest Initargs)
  (declare (ignore Initargs))
  (incf (size Self)) ;; need one more space to be able to differntiate between full and empty
  (setf (items Self) (make-array (size Self)))
  ;; dead with thread safety 
  (when (thread-safe-p Self)
    (setf (queue-lock Self) (ccl::make-lock "Queue Lock"))))


(defmethod GRAB-LOCK-IF-NECESSARY ((Self queue))
  (when (queue-lock Self) (ccl::grab-lock (queue-lock Self))))


(defmethod RELEASE-LOCK-IF-NECESSARY ((Self queue))
  (when (queue-lock Self) (ccl::release-lock (queue-lock Self))))


(defmethod IS-EMPTY ((Self queue))
  (grab-lock-if-necessary Self)
  (unwind-protect
      (= (in Self) (out Self))
    (release-lock-if-necessary Self)))


(defmethod UNPROTECTED-ENQUEUE ((Self queue) Item)
  (cond
   ((= (out Self) (mod (1+ (in Self)) (size Self)))
    (queue-is-full-handler Self))
   (t
    (setf (aref (items Self) (in Self)) Item)
    (setf (in Self) (mod (1+ (in Self)) (size Self))))))


(defmethod ENQUEUE ((Self queue) Item &key Unique-Name)
  (grab-lock-if-necessary Self)
  (unwind-protect
      (cond
       (Unique-Name
        (let ((Existing-Item (find Unique-Name (items Self) :key #'(lambda (x) (typecase x (named-queue-item (name x)) (t nil))))))
          (if Existing-Item
            (setf (value Existing-Item) Item)
            (unprotected-enqueue Self (make-instance 'named-queue-item :name Unique-Name :value Item)))))
       (t
        (unprotected-enqueue Self Item)))
    (release-lock-if-necessary Self)))
  

(defmethod DEQUEUE ((Self queue))
  (grab-lock-if-necessary Self)
  (unwind-protect
      (unless (is-empty Self)
        (prog1
            (let ((Item (aref (Items Self) (out Self))))
              (typecase Item
                (named-queue-item 
                 (setf  (aref (Items Self) (out Self)) nil) ;; need to get rid of the named items, otherwise enque will find it
                 (value Item))
                (t Item)))
          (setf (out  Self) (mod (1+ (out Self)) (size Self)))))
    (release-lock-if-necessary Self)))


(defmethod QUEUE-IS-FULL-HANDLER ((Self queue))
  (warn "queue is full"))



#| Examples:


(defparameter *Queue* (make-instance 'queue :size 4))

(enqueue *Queue* (random 100))

(dequeue *Queue*)

(is-empty *Queue*)


(defparameter *Queue* (make-instance 'queue :size 4 :thread-safe-p t))

(defparameter *Queue* (make-instance 'queue :size 10))

(enqueue *Queue* (print (random 100)) :unique-name :secret-code)

(dequeue *Queue*)






|#

Prof. Alexander Repenning

University of Colorado
Computer Science Department
Boulder, CO 80309-430

vCard: http://www.cs.colorado.edu/~ralex/AlexanderRepenning.vcf


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20110712/b95224e3/attachment.htm>