Guarded Suspension してみた

qnzmのGuarded Suspension - qnzm.log(クニジマログ)を読んでcommonlispでやってみた。
SBCL限定。
目標は
・SBCLでのスレッドの扱いの勉強
・あんまり触ってないCLOSでやる
・これもあんまり触ってないパッケージを切ってみる
の３つ。

でそれぞれの感想

「スレッド」
SBCLにはモニタがないみたい。セマフォとミューテックスしかない（たぶん）
セマフォでやってみたけど、あってんのかなぁ。

「CLOS」
メソッド名のプレフィクスにクラス名をつけるのが作法なのかなぁ、と思ってそうした。
が、いちいちfooclass-barみたいに書くのめんどくさ。

「パッケージ」
なんだかcommon lispのパッケージ分かりにくい。
慣れなのかなぁ。

lock-withとwaitforをマクロにしてみた。
あと、blocking-queuetって名前はjava.util.concurrentのパクリです。

以下コード

(defpackage "CL-CONCURRENT" 
  (:use    "COMMON-LISP" "SB-THREAD"))

(in-package "CL-CONCURRENT")
 
(export '(blocking-queue blocking-queue-p blocking-queue-put blocking-queue-get))

(defmacro with-lock(sem &body body)
  (let ((gsem (gensym)))
    `(let ((,gsem ,sem))
       (unwind-protect
           (progn
         (sb-thread::wait-on-semaphore ,gsem)
         ,@body)
         (sb-thread::signal-semaphore ,gsem)))))

(defmacro waitfor(sem test &body body)
  (let ((gsem (gensym)))
    `(let ((,gsem ,sem))
       (unwind-protect
           (progn
         (sb-thread::wait-on-semaphore ,gsem)
         (do ()
             (,test)
           (sb-thread::signal-semaphore ,gsem))
         ,@body)
         (sb-thread::signal-semaphore ,gsem)))))

(defclass blocking-queue ()
  ((q :accessor queue)
   (sm :accessor semaphore)))

(defmethod initialize-instance((q blocking-queue) &rest intargs)
  (setf (queue q) nil)
  (setf (semaphore q) (sb-thread::make-semaphore :name (symbol-name (gensym))))
  (sb-thread::signal-semaphore (semaphore q)))
  
(defmethod blocking-queue-p((q blocking-queue))
  (pprint (queue q)))

(defmethod blocking-queue-get((q blocking-queue))
  (waitfor (semaphore q) (queue q)
       (let ((r (car (queue q))))
         (setf (queue q) (cdr (queue q)))
         r)))

(defmethod blocking-queue-put((q blocking-queue) value)
  ;;(format t "put ~A~%" value)
  (with-lock (semaphore q) 
         (setf (queue q) (append (queue q) (list value)))))

;; ;;test
;; (setf q (make-instance 'blocking-queue))

;; (sb-thread::make-thread 
;;  #'(lambda ()
;;        (dotimes (x 10)
;;          (progn
;;            (format t "thread get ~A~%" (blocking-queue-get q))
;;            (sleep 3))))
;;  :name "test")

;; (do ()
;;     (nil 'NODE)
;;   (blocking-queue-put q (read-line)))