CLでSRFI-18 — #:g1

Posted 2012-03-29 08:34:00 GMT

CLでSRFI、今回は、SRFI-18の「Multithreading support」です。
マルチスレッド関係を規定するSRFIです。

動作

(defun make-empty-mailbox ()
  (let ((mutex (make-mutex))
        (put-condvar (make-condition-variable))
        (get-condvar (make-condition-variable))
        (full? nil)
        (cell nil) )
    (labels ((put! (obj)
               (mutex-lock! mutex)
               (if full?
                   (progn
                     (mutex-unlock! mutex put-condvar)
                     (put! obj) )
                   (progn
                     (setq cell obj)
                     (setq full? 'T)
                     (condition-variable-signal! get-condvar)
                     (mutex-unlock! mutex) )))
             (get! ()
               (mutex-lock! mutex)
               (if (not full?)
                   (progn
                     (mutex-unlock! mutex get-condvar)
                     (get!) )
                   (let ((result cell))
                     (setq cell nil) ; avoid space leaks
                     (setq full? nil)
                     (condition-variable-signal! put-condvar)
                     (mutex-unlock! mutex) ))))
      (lambda (msg)
        (case msg
          ((put!) #'put!)
          ((get!) #'get!)
          (otherwise (error "unknown message")) )))))

(defun mailbox-put! (m obj) (funcall (funcall m 'put!) obj)) (defun mailbox-get! (m) (funcall (funcall m 'get!)))

;;; test (let ((th (make-thread (lambda () (handler-case (sb-ext:with-timeout 2 (let ((mb (make-empty-mailbox))) (mailbox-put! mb 'foo) (mailbox-get! mb) (mailbox-put! mb 'bar) t )) (sb-ext:timeout () nil) )) "mailbox" ))) (thread-start! th) (thread-join! th) ) ;=> T

移植について

結構低レイヤーなので厳しいです。
適当にSBCLで該当する機能がある範囲で似せる、という感じでお茶を濁しています。 ■

comments powered by Disqus