【Common Lisp】Go言語の goroutine っぽいものを作ってみたかった話

Lisp Advent Calendar 2019 23日目の記事です。

近頃仕事で書いている Go 言語の勉強も兼ねて「Go言語による並行処理」という本を買ったので Lisp を書いていくぞという内容です。goroutine っぽい cloutine なるものを Common Lisp 上で作ってみようという試みです。

www.oreilly.co.jp



できたもの(と制限)

github.com

  • 隠蔽された複数の実スレッドにいわゆる Green Thread(cloutine と命名)を投げ込んで並行処理を実現する
  • 非同期なチャネル

というようにできたのは一部分だけです。また、できたものについても下記の制限があります。

  • 色々実用に耐えない
    • 後述のように継続ライブラリ cl-cont を利用していますが、unwind-protect などいくつかのスペシャルフォームに対応していないので実用的に使うのは辛そうです
  • SBCL 上ではさらに実用的に耐えない
    • SBCL のエグい最適化と cl-cont のエグいコード変換がかち合って不安定だったり、コンパイルに異様に時間がかかったりします
    • 一応テストは SBCL, CCL の2処理系で行ってはいるものの...*1
  • チャネルについてはかろうじて単独で動作するだけで select のような高度で実用的な機能はできていない

技術要素

次のようなものを利用して作成しました。

  • マルチスレッド: bordeaux-threads
  • 限定継続: cl-cont
    • 簡単な使い方について「cl-cont: 限定継続」の項で簡単に解説しているので、興味のある方はそこだけ見てみると良いかもしれません
  • 非同期処理: Blackbird: いわゆる Promise を実現するライブラリ

参考

  • green-thread
    • シングルスレッド上での Green Thread を実現するライブラリです
    • 利用はしていませんが実装の参考にしています。bordeaux-threads 以外の技術要素は同じです

動かしてみる

現状 cloutine は quicklisp に登録していないので ql:quickload できるような位置にソースを持ってくることが必要です。Roswell を利用している場合は下記が簡単です。

$ ros install eshamster/cloutine

まずは次の Go のコードに相当する動作を試してみます。

package main

import (
    "fmt"
    "time"
)

func main() {
    ch := make(chan int)
    // go で goroutine を1つ立てる
    go func() {
        // チャネルがクローズされるまで値を取り出して出力し続ける
        for {
            val, ok := <-ch
            if !ok {
                break
            }
            fmt.Printf("%d\n", val)
        }
    }()
    go func() {
        // 0~4までの値をチャネルに投入した後、クローズする
        defer close(ch)
        for i := 0; i < 5; i++ {
            ch <- i
        }
    }()
    // 本来 wait group でやるところをサボり
    time.Sleep(1)
}

次のようになります。コメントに既につらみが見えています。

CL-USER> (ql:quickload :cloutine :silent t)
(:CLOUTINE)
CL-USER> (use-package :cloutine)
T
;; goroutine ぽいもの = cloutine を実行する実スレッドを2つ立ち上げる初期化処理
CL-USER> (init-cloutine 2)
#<CLOUTINE/REAL-THREADS::REAL-THREADS #x3020011BEDDD>
CL-USER> (let ((chan (make-channel)))
           ;; clt: cloutine を作成するマクロ
           (clt (loop
                   ;; チャネルに値が入ってくるのを待つ
                   (let ((x (<-chan chan)))
                     ;; 多値で「値, open-p」みたいに返してクローズ判定したいが、
                     ;; cl-cont との組み合わせがうまくいかないので苦しいクローズ判定...
                     (when (channel-closed-value-p x)
                       (return))
                     (print x))))
           (clt (dotimes (i 5)
                  ;; 値をチャネルに入れる
                  (chan<- chan i))
                ;; defer 相当のことをするために unwind-protect を利用するべきだが
                ;; cl-cont が対応していないので普通に close...
                (close-channel chan)))
NIL

0
1
2
3
4

念のため、init-cloutine の引数に指定する実スレッドの数は同時に立てられる cloutine の数を制限するものではないです。次の通り、3つの実スレッドに対して5 (+1) 個の cloutine を同時に立てることができています*2

CL-USER> (ql:quickload :cloutine :silent t)
(:CLOUTINE)
CL-USER> (use-package :cloutine)
T
;; bt = bordeaux-threads のニックネーム
CL-USER> (defparameter *lock* (bt:make-lock))
*LOCK*
CL-USER> (init-cloutine 3)
#<CLOUTINE/REAL-THREADS::REAL-THREADS #x3020011BECCD>
CL-USER> (let ((chan (make-channel)))
           (dotimes (i 5)
             (let ((i i))
               (clt (loop
                       ;; スレッドが切り代わり易いように適当に sleep を入れて動作を乱す
                       (sleep 0.001)
                       (let ((x (<-chan chan)))
                         (when (channel-closed-value-p x)
                           (return))
                         (bt:with-lock-held (*lock*)
                           ;; *real-thread-index* は実スレッドの番号
                           (format t "thread: ~D, cloutine: ~D, value: ~D~%"
                                   *real-thread-index* i x)))))))
           (clt (dotimes (i 15)
                  (chan<- chan i)
                  ;; 上に同じく適当に sleep を入れる
                  (when (= (mod i 5) 0)
                    (sleep 0.001)))
                (close-channel chan)))
NIL
thread: 2, cloutine: 1, value: 0
thread: 0, cloutine: 0, value: 1
thread: 2, cloutine: 1, value: 5
thread: 0, cloutine: 2, value: 2
thread: 2, cloutine: 1, value: 7
thread: 0, cloutine: 2, value: 8
thread: 1, cloutine: 3, value: 3
thread: 2, cloutine: 1, value: 9
thread: 0, cloutine: 2, value: 10
thread: 2, cloutine: 1, value: 11
thread: 1, cloutine: 3, value: 12
thread: 0, cloutine: 2, value: 13
thread: 2, cloutine: 1, value: 14
thread: 1, cloutine: 4, value: 4
thread: 0, cloutine: 0, value: 6

今回参考にした「Go言語による並行処理」第6章「ゴルーチンとGoランタイム」P.206 に次のような説明用のコードがあるので、同等のものを動かしてみます。

   fib = func(n int) <-chan int {
        result := make(chan int)
        go func() {
            defer close(result)
            if n <= 2 {
                result <- 1
                return
            }
            result <- <-fib(n-1) + <-fib(n-2)
        }()
        return result
    }

    fmt.Printf("fib(4) = %d", <-fib(4))

次のようになります。どうにか動作はするようです。

CL-USER> (ql:quickload :cloutine :silent t)
(:CLOUTINE)
CL-USER> (use-package :cloutine)
T
CL-USER> (defun fib (n)
           (let ((result (make-channel)))
             (clt (if (<= n 2)
                      (chan<- result 1)
                      (chan<- result
                              (+ (<-chan (fib (- n 1)))
                                 (<-chan (fib (- n 2))))))
                  ;; 前述の通り unwind-protect を使えないので普通に close...
                  (close-channel result))
             result))
;; warnings は見なかったことにする
;Compiler warnings :
;   In an anonymous lambda form inside an anonymous lambda form inside an anonymous lambda form inside an anonymous lambda form inside an anonymous lambda form inside FIB: Undefined function FIB
;   In an anonymous lambda form inside an anonymous lambda form inside FIB: Undefined function FIB
FIB

CL-USER> (init-cloutine 2)
#<CLOUTINE/REAL-THREADS::REAL-THREADS #x302000F9D86D>

;; channel を利用するには with-call/cc で囲う必要がある(clt マクロも内部で囲っている)
CL-USER> (cont:with-call/cc
           (print (<-chan (fib 4))))
#<PROMISE name: "attach: PROMISE" finished: NIL errored: NIL forward: NIL #x302000F9DA9D>

3

実装の基本的なアイディア

cloutine の生成と実行

goroutine っぽいもの = cloutine の裏で動作する実スレッドはそれぞれ下記のような処理を行います。この辺りは「Go言語による並行処理」第6章「ゴルーチンとGoランタイム」を参考にしています。

  • 各スレッドはキューを一つずつ持つ
  • 全てのキューが空のとき全てのスレッドは待ち状態になる
  • いずれかのキューに関数が入っているときスレッドの待ちが解除され次の動作をする
    1. 自身のキューを調べ、関数が入っていればそれを実行する
    2. 1で取得できない場合、他のキューを順に調べて関数を見つけ次第それを実行する

したがって、cloutine を生成する clt マクロの基本的な内容は、渡された処理を lambda で包んで関数化し、上記のキューに詰め込むだけです。基本的には各スレッドは自身のキューに関数を詰めて自身で実行するのですが、「他のキューを順に調べて関数を見つけ次第それを実行する」の動作があるため、空いているスレッドは人のキュー内の関数を盗んで実行することができます。

非同期なチャネル

上記の通り、cloutine の基本的な動作だけであればそれほど面倒なところはない *3 のですが、非同期なチャネルの実装が割と厄介です。「技術要素」の項で述べた限定継続ライブラリ cl-cont と、Promise ライブラリ Blackbird はいずれもここで出てきます。

分かり易く説明できる気がしないのですが、非同期な待ちは次のように実現します(※待ちが発生しない限りはほぼ単なるスレッドセーフなキュー)。以下は取り出し待ちの例ですが、チャネルのサイズを制限した場合の投入待ちの処理もおおむね同じになります。

  1. チャネル操作以降の処理を「継続」= 特定の形式の関数として取り出す(cl-cont)
  2. Promise を作成し、解決するための関数をチャネルに保管する(Blackbird)
  3. 2 で作成した Promise に、解決時の処理として 1 の継続を実行する処理を登録する
  4. チャネルに値を投入する際に 2 で保管した関数があれば呼び出して Promise を解決する
    • ここで、3で登録した継続が実行される

実装

queue: ただのキュー

https://github.com/eshamster/cloutine/blob/master/queue.lisp

特別なところはないただのキューなのでリンクだけ貼ります。head からの取り出しと tail への追加しかできない双方向リストとして実装しています。

こんな感じで利用します。

CL-USER> (use-package :cloutine/queue)
    T
CL-USER> (defparameter *q* (make-queue))
*Q*
CL-USER> (queue *q* 0)
0
CL-USER> (queue *q* 1)
1
CL-USER> (dequeue *q*)
0
CL-USER> (dequeue *q*)
1
CL-USER> (dequeue *q*)
NIL

この部分は12日目の記事「【Common Lisp】REPL 上で手軽にスレッドの動作を試すためのライブラリを作った」の repl-threads と全く同じです。というより、そもそも repl-threads は cloutine を書いていて思いついたものです。ついでに言うと、6日目の記事「cl-base + rove + Travis CI でテストする」は cloutine のテストで困ったことからできたものです。

multi-queue

https://github.com/eshamster/cloutine/blob/master/multi-queue.lisp

multi-queue は次のような特徴を持つ複数のキューのまとまりです。

  • 複数のキューを配列として持つ
  • 全てのキューが空のとき dequeue 操作は待たされる
  • いずれかのキューにデータがあるとき dequeue は次のように動作する
    1. 指定されたインデックスのキューを調べ、データがあればそれを取得する
    2. 1で取得できない場合、他のキューを順に調べデータを見つけ次第そこから取得する
      • ロック・セマフォにより適切に排他制御をかけることで、 2まで来て取得できないケースが出ないようにする

パッケージ定義を見ると、上記に必要な部品であるキュー・ロック・セマフォを import していることが分かります。

(defpackage cloutine/multi-queue
  (:use :cl)
  (:export :multi-queue
           :init-multi-queue
           :queue-into
           :dequeue-from)
  (:import-from :cloutine/queue
                :init-queue
                :queue
                :dequeue)
  (:import-from :bordeaux-threads
                :make-lock
                :make-semaphore
                :with-lock-held
                :wait-on-semaphore
                :signal-semaphore))
(in-package :cloutine/multi-queue)

クラス定義は次のようになります。複数のキューと各キューに対応する複数のロック、そして1つのセマフォを持ちます。

(defclass multi-queue ()
  ((queues :initarg :queues :accessor mq-queues)
   (locks :initarg :locks :accessor mq-locks)
   (semaphore :initform (make-semaphore) :accessor mq-semaphore)))

(defun init-multi-queue (n)
  (let ((queues (make-array n))
        (locks (make-array n)))
    (dotimes (i n)
      (setf (aref queues i) (init-queue)
            (aref locks  i) (make-lock)))
    (make-instance 'multi-queue
                   :queues queues
                   :locks locks)))

queue-into では指定したインデックスのキューへ値を入れ、セマフォをインクリメントします。

(defmethod queue-into ((mq multi-queue) queue-index value)
  (assert (< queue-index (queue-count mq)))
  (with-lock-held ((aref (mq-locks mq) queue-index))
    (queue (aref (mq-queues mq) queue-index)
           value))
  (signal-semaphore (mq-semaphore mq)))

dequeue-from では前述の、指定されたインデックスのキューを優先した dequeue 操作を行います。ただし、queue 操作がない限りはセマフォがインクリメントされることはないので、全てのキューが空であれば入口で待たされます。

(defmethod dequeue-from ((mq multi-queue) prior-queue-index)
  (assert (< prior-queue-index (queue-count mq)))
  ;; 全てのキューが空なら待つ
  (wait-on-semaphore (mq-semaphore mq))
  (macrolet ((try-dequeue (index)
               `(with-lock-held ((aref (mq-locks mq) ,index))
                  (let ((value (dequeue (aref (mq-queues mq) ,index))))
                    (when value
                      (return-from dequeue-from value))))))
    ;; まずは指定されたインデックスのキューを調べる
    (try-dequeue prior-queue-index)
    ;; なければ別のキューを順番に見て値を取り出す
    (dotimes (i (queue-count mq))
      (unless (= i prior-queue-index)
        (try-dequeue i)))
    ;; 上記で取れないケースはあり得ないのでエラー
    (error "No value is there.")))

real-threads

https://github.com/eshamster/cloutine/blob/master/real-threads.lisp

real-threads はその名の通り実スレッドです。 multi-queue を利用して各スレッドは次のように動作します。いずれの動作も multi-queue の各動作に対応しています。

  • 各スレッドは multi-queue 内に対応するキューを1つずつ持つ
  • 全てのキューが空のとき全てのスレッドは待ち状態になる
  • いずれかのキューに関数が入っているときスレッドの待ちが解除され次の動作をする
    1. 自身のキューを調べ、関数が入っていればそれを実行する
    2. 1で取得できない場合、他のキューを順に調べて関数を見つけ次第それを実行する

上記を実現するため、先程の multi-queue の他、スレッド作成・破棄の関数を import します。セマフォ関連も import していますが、これは初期化時のみの利用で、本質的な処理には絡んでいません*4

(defpackage cloutine/real-threads
  (:use :cl)
  (:export :start-real-threads
           :destroy-real-threads
           :queue-promise)
  (:import-from :cloutine/multi-queue
                :multi-queue
                :init-multi-queue
                :queue-into
                :dequeue-from)
  (:import-from :bordeaux-threads
                :make-thread
                :destroy-thread
                :make-semaphore
                :wait-on-semaphore
                :signal-semaphore))
(in-package :cloutine/real-threads)

クラスの定義は次の通りです。

(defclass real-thread ()
  ((thread :initarg :instance :accessor thread-instance)
   (index :initarg :index :accessor thread-index)))

(defclass real-threads ()
  ((threads :initarg :rt-array :accessor threads-array)
   (multi-queue :initarg :mq :accessor threads-mq)
   (destroied-p :initform nil :accessor threads-destroied-p)))

初期化は引数で指定されたスレッド数に応じて、multi-queue を初期化し、後述の process-thread 関数を実行する実スレッドを作成します。一応初期化が完了するまではセマフォprocess-thread が走らないようにしています。

(defun start-real-threads (n)
  (let* ((mq (init-multi-queue n))
         (rt-arr (make-array n))
         (rts (make-instance 'real-threads :mq mq))
         (sem-to-wait-start (make-semaphore)))
    (dotimes (i n)
      (let ((rt (make-instance 'real-thread :index i)))
        (setf (thread-instance rt)
              (make-thread (lambda ()
                             (wait-on-semaphore sem-to-wait-start)
                             (process-thread rt rts))))
        (setf (aref rt-arr i) rt)))
    (setf (threads-array rts) rt-arr)
    (signal-semaphore sem-to-wait-start :count n)
    rts))

;; destroy-real-threads は略

次がその process-thread で、multi-queue から関数を取り出せたらそれを実行する、を繰り返すだけです。また、スペシャル変数 *real-thread-index* に自身のスレッド番号を束縛します。

(defvar *real-thread-index* nil)

(defmethod process-thread ((rt real-thread) (rts real-threads))
  (loop
     (let ((index (thread-index rt)))
       ;; dequeue-from は全てのキューが空であるうちは待たされる
       (let ((process (dequeue-from (threads-mq rts) index)))
         (assert (functionp process))
         (let ((*real-thread-index* index))
           (funcall process))))))

スレッドの外もしくは中からこのキューに関数を投げ込むメソッドが queue-process です。スレッド内からの場合は自身のインデックスのキューに投げます。そうでない場合は取りあえず 0 番目のキューに投げています(が乱数で選択した方が良い気もします)。

(defmethod queue-process ((rts real-threads) (process function))
  (when (threads-destroied-p rts)
    (error "The thread has been destroied."))
  (queue-into (threads-mq rts)
              (if *real-thread-index*
                  *real-thread-index*
                  0)
              process))

cloutine

https://github.com/eshamster/cloutine/blob/master/cloutine.lisp

本題の cloutine の実装ですが、処理の実体は real-threads が担っているので、ほぼそのラッパー程度の役割です。次のように real-threads の他に、後のチャネルの実装の仕込みとして cl-cont のシンボルをいくつか import します。

(defpackage :cloutine/cloutine
  (:use :cl)
  (:export :init-cloutine
           :destroy-cloutine
           :cloutine
           :clt)
  (:import-from :cloutine/real-threads
                :start-real-threads
                :destroy-real-threads
                :queue-process)
  (:import-from :cl-cont
                :with-call/cc
                :without-call/cc))
(in-package :cloutine/cloutine)

初期化関数は次の通りで、グローバルに real-threads を1つ作成します。

(defvar *real-threads* nil)

(defun init-cloutine (n)
  (setf *real-threads* (start-real-threads n)))

;; ※destroy-cloutine は省略

cloutine を作成する cloutine マクロとそのエイリアスclt マクロは次のようになります。ほぼ body 部を lambda で包んで real-threads の queue-process に渡すだけです。with-call/cc, without-call/cc については次のチャネルの項を参照してください。

(defmacro cloutine (&body body)
  `(queue-process *real-threads*
                  (without-call/cc
                    (lambda ()
                      (with-call/cc
                        ,@body)))))

(defmacro clt (&body body)
  `(cloutine ,@body))

channel

チャネルの実装の前に、限定継続ライブラリ cl-cont と Promise ライブラリ Blackbird について簡単に見ていきます。

cl-cont: 限定継続

限定継続についてざっくり感覚的な理解を得るには κeen さんの Common Lispで限定継続と遊ぶ などを見ながら cl-cont をいじってみるのが良いのかなと思います。自身も継続を使ってみるのは始めてでざっくりとした理解しかありませんが...。

ここでは継続とは何かという話は置いて、どの様な動きをするのかいくつかの例で見てみます。まずは単純に継続 = 「以降の処理」を取り出す様子を見てみます。

;; ※ややこしいので以降 print の出力のみ記載し、REPLの出力は省略します
CL-USER> (defparameter *cont* nil)
CL-USER> (cont:with-call/cc
           (print :start)
           ;; let/cc 以降の処理 = 継続が k に束縛される
           (cont:let/cc k
             (print :let-start)
             (setf *cont* k)
             (print :let-end))
           ;; ↓はまだ処理されない
           (print :end))

:START
:LET-START
:LET-END
;; 継続は関数として表されるので funcall できる
CL-USER> (funcall *cont*)

:END
;; もちろん何度でも呼べる
CL-USER> (funcall *cont*)

:END

この with-call/ccdefun を囲ったものが defun/cc で、次のように使えます。始めて試してみたときは、うわ本当に関数外の処理(継続)を引き込んで好きに扱える!と中々シビれました。

CL-USER> (defparameter *cont* nil)
CL-USER> (cont:defun/cc test-cc ()
           (cont:let/cc k
             (setf *cont* k)))
CL-USER> (cont:with-call/cc
           (print :start)
           (test-cc)
           (print :end))

:START
CL-USER> (funcall *cont*)

:END

さて、限定継続として取り出される関数は0個または1個の引数を取ります。ここまでは0引数の例でしたが、チャネルからの値の取り出し待ちをする継続は値を待っているので、そこに引数として渡してあげる必要があります。次のようにチャネルにまだ値がなかった場合の値取り出しの動作を模してみます。

CL-USER> (defparameter *cont* nil)
CL-USER> (cont:defun/cc like-waiting-chan ()
           (cont:let/cc k
             (setf *cont* k)))
CL-USER> (cont:with-call/cc
           (print :start)
           ;; まだチャネルに値が入っていないので残りの処理はどこか(*cont*)に格納しておいて
           ;; いったん処理は完了させる...という体
           (print (like-waiting-chan))
           (print :end))

:START
;; どこからかチャネルに値 100 が供給された...という体
CL-USER> (funcall *cont* 100)

100
:END

最後に実装時の細かい部分になりますが、 without-call/cc に触れます。ここまでに見たように、単純に with-call/cc を利用すると、 let/cc 以降の処理が全て束縛されてしまいます。実際にはもう少し範囲を絞りたいのですが、そのときの区切りとして利用するのが without-call/cc です。次のように使います。

CL-USER> (cont:with-call/cc
           (print :outer-start)
           (cont:without-call/cc
             (cont:with-call/cc
               (print :start)
               (cont:let/cc k
                 (setf *cont* k))
               ;; ここはまだ待って欲しい
               (print :end)))
           ;; ここはすぐ処理されて欲しい
           (print :outer-end))

:OUTER-START
:START
:OUTER-END
CL-USER> (funcall *cont*)

:END

Blackbird: Promise

Blackbird はいわゆる Promise(Future とも)を実現するライブラリで、非同期処理を実現するための部品として利用できます。次は resolve 済みの Promise を生成するだけの余り意味のない例です。

CL-USER> (ql:quickload :blackbird :silent t)
(:BLACKBIRD)
;; bb = blackbird
CL-USER> (let ((promise (bb:with-promise (resolve reject)
                          (resolve 100))))
           ;; promise が resolve されない限り attach された関数は実行されない
           ;; 今回は resolve 済みなのですぐ実行される
           (bb:attach promise
                      (lambda (x)
                        (format t "~&resolved: ~D~%" x))))
resolved: 100
;; ↓式自体は promise クラスを返している
#<PROMISE name: "attach: PROMISE" finished: T errored: NIL forward: NIL #x302000E6E2FD>

実際に非同期処理の文脈で利用するには大きく2つの方法があります。

  • cl-async のような非同期処理と組み合わせる
    • cl-async は libuv ベースの非同期処理ライブラリです
    • Blackbird 冒頭の例で紹介されている方法です
  • Promise 生成時に resolve 処理を外に保管しておいて後から resolve してもらう

今回とるのは後者の方法です。ここで、with-promiseresolve(と reject)は macrolet として定義されているため、そのまま外に渡すことはできません。こうした用途のためにはキーワード引数の resolve-fnreject-fn)が用意されているので、そちらを外に渡します。

CL-USER> (let* (resolver
                (promise (bb:with-promise (resolve reject :resolve-fn resolve-fn)
                           ;; resolve-fn を外に渡す
                           (setf resolver resolve-fn))))
           ;; promise が resolve されていないのですぐには実行されない
           ;; 名前の通り、resolve 時にやって欲しい処理を promise に atttach するだけ
           (bb:attach promise
                      (lambda (x)
                        (format t "~&resolved: ~D~%" x)))
           (print :after-attach)
           ;; ここで promise が resolve されるので上記の lambda も実行れる
           (funcall resolver 999)
           (print :after-resolve))

:AFTER-ATTACH
resolved: 999

:AFTER-RESOLVE
:AFTER-RESOLVE ; ← ※REPL の出力

これと cl-cont と組み合わせることでチャネルの待ちを実現できそうです。

  • チャネルに値が入っていないときは、resolve-fn を保管して Promise を生成し、残りの処理 = 継続を attach しておく
  • チャネルに値を入れる際に保管された resolve-fn に値を渡して attach された継続を実行する

実装

https://github.com/eshamster/cloutine/blob/master/sync/channel.lisp

問題の実装を見ていきます。パッケージ定義は以下の通りで、ここまでに説明した cl-cont, Blackbird を import しています。また、値を入れる容器として queue を、その排他制御のためにロック関連のシンボルを import しています。

(defpackage cloutine/sync/channel
  (:use :cl)
  (:export :make-channel
           :close-channel
           :<-chan
           :chan<-
           :ch-closed-p)
  (:import-from :cloutine/cloutine
                :clt)
  (:import-from :cloutine/queue
                :init-queue
                :queue
                :dequeue
                :queue-length)
  (:import-from :blackbird
                :attach
                :with-promise)
  (:import-from :bordeaux-threads
                :make-lock
                :acquire-lock
                :release-lock
                :with-lock-held)
  (:import-from :cl-cont
                :defun/cc
                :let/cc))
(in-package :cloutine/sync/channel)

クラス定義は次の通りです。3つのキューを持っているところが特徴的です。

  • queue: チャネルに投入されるデータを管理するキュー
    • 以降の説明で単に「キュー」と言った場合はこのキューのこと
  • queue-resolver-queue: 投入待ち(キューが一杯のとき)を表す Promise の resolver (resolve-fn) を管理するキュー
    • max-lengthnil の場合は利用されない
  • deqeueue-resolver-queue: 受け取り待ち(キューが空のとき)を表す Promise の resolver (resolve-fn) を管理するキュー
(defclass channel ()
  ((queue :initform (init-queue) :reader ch-queue)
   (queue-resolver-queue :initform (init-queue) :reader ch-queue-resolvers)
   (deqeueue-resolver-queue :initform (init-queue) :reader ch-dequeue-resolvers)
   (lock :initform (make-lock "Channel lock") :accessor ch-lock)
   (max-length :initarg :max-resource :reader ch-max-resource) ; param
   (closed-p :initform nil :accessor ch-closed-p)))

(defun make-channel (&optional max-resource)
  (make-instance 'channel :max-resource max-resource))

チャネルから値を取り出す関数 <-chan の実装は次のようになります。解説はソース中にコメントしていますが、色々とつらみが見え隠れします。

(defmacro with-release-lock ((lock) &body body)
  `(unwind-protect
        (progn ,@body)
     (release-lock ,lock)))

(defun/cc <-chan (ch)
  (let ((lock (ch-lock ch))
        (q (ch-queue ch)))
    ;; let/cc が unwind-protect に囲われてしまうとうまく動作しないので、
    ;; (内部に unwind-protect を含む)with-lock-held マクロは利用できない
    (acquire-lock lock)
    (cond ;; キューに値が入っているケース
          ((> (queue-length q) 0)
           (with-release-lock (lock)
             ;; 投入待ちがあれば resolve しておく
             ;; (一瞬 max-length を越えるがロック内で解消するのでまあ良いのでは...)
             (when (> (queue-length (ch-queue-resolvers ch)) 0)
               (funcall (dequeue (ch-queue-resolvers ch)) t))
             (dequeue q)))
          ;; ここから下はキューが空のケース
          ;; チャネルがクローズ済みなら待たずに終わる
          ((ch-closed-p ch)
           (with-release-lock (lock)
             (make-instance 'channel-closed-value)))
          ;; まだチャネルが開いていれば待つ
          (t (let ((promise (with-promise (resolve reject :resolve-fn resolver)
                              ;; 取り出し待ち解決のための resolver を溜めておく
                              (queue (ch-dequeue-resolvers ch) resolver))))
               (release-lock lock)
               (let/cc k
                 ;; 値取り出し後の処理を Promise に attach しておく
                 (attach promise
                         (lambda (val closed-p)
                           ;; closed-p をもらっているが、継続に多値をうまく渡す手段がなく
                           ;; 使えないままになっている...
                           (declare (ignore closed-p))
                           ;; 値を渡して新しい cloutine 上で継続を実行する
                           (clt (funcall k val))))))))))

チャネルへ値を投入する関数 <-chan の実装は次のようになります。こちらも色々つらい。

(defun/cc chan<- (ch value)
  (let ((lock (ch-lock ch))
        (q (ch-queue ch))
        (max-length (ch-max-resource ch)))
    ;; 上に同じく with-lock-held を使わずに頑張る
    (acquire-lock lock)
    (cond ((ch-closed-p ch) ; チャネルがクローズ済み
           (with-release-lock (lock)
             ;; 一応 error を返しているが、継続内ではうまく拾えない...
             (error "Error: Insert a value into a closed channel")))
          ;; 取り出し待ちがある場合
          ((> (queue-length (ch-dequeue-resolvers ch)) 0)
           (let (resolver)
             (with-release-lock (lock)
               (setf resolver (dequeue (ch-dequeue-resolvers ch))))
             ;; キューを介さずに直接値を渡す
             (funcall resolver value t)))
          ;; キューに空きがある = 投入可能な場合
          ((or (null max-length)
               (< (queue-length q) max-length))
           (with-release-lock (lock)
             (queue q value)))
          ;; キューに空きがない場合
          (t (let ((promise (with-promise (resolve reject :resolve-fn resolver)
                              ;; 投入待ち解決のための resolver を溜めておく
                              (queue (ch-queue-resolvers ch) resolver))))
               (release-lock lock)
               (let/cc k
                 ;; 値投入とその後の処理を Promise に attach しておく
                 (attach promise
                         (lambda (open-p)
                           (if open-p
                               (progn
                                 ;; キューに値を入れる
                                 ;; (ロックは resolver を呼び出した側でかけている)
                                 (queue q value)
                                 ;; 新しい cloutine 上で継続を実行する
                                 (clt (funcall k)))
                               (error "Error: Channel is closed when waiting to insert a value"))))))))))

最後に close-channel の実装も示します。残っている resolver を呼び出して全ての待ちを解決済みにします。

(defmethod close-channel ((ch channel))
  "Close channel and broadcast signal to all waiting readers and writers."
  (let ((lock (ch-lock ch)))
    (with-lock-held (lock)
      (setf (ch-closed-p ch) t)
      (dotimes (i (queue-length (ch-queue-resolvers ch)))
        (funcall (dequeue (ch-queue-resolvers ch)) nil))
      (dotimes (i (queue-length (ch-dequeue-resolvers ch)))
        (funcall (dequeue (ch-dequeue-resolvers ch)) nil nil)))))

*1:CCL上ではロックが recursive-lock として実装されているようで、少々雑にロック・アンロックをしても通ってしまうので、SBCL で検査しているといった理由もあります(なお、逆に SBCL には recursive-lock の実装がなさそう)

*2:同じ cloutine が必ず同じスレッドで実行されているのは意図通りではないので何かバグがあるかも...

*3:実際の goroutine のランタイムはもっと賢いことをしているはずですが

*4:抜き出した範囲では利用していないので抜いていますが、ロック関連も import しています。ただし、それらもデバッグ機能作成用であって、同じく本質的な処理には絡んでいません

【Common Lisp】REPL 上で手軽にスレッドの動作を試すためのライブラリを作った

Lisp Advent Calendar 2019 12日目の記事です。Commmon Lisp の REPL (Read Eval Print Loop) 上でお手軽にスレッドの動作を試すための小さなライブラリ repl-thread を作ってみた話です。

github.com



前置き

REPL駆動開発 *1 とも言われるように、Common Lisp 開発においては組み込み関数や自分で書いた関数の動作の確認に REPL を使い倒すことと思います。これの良いところは、きっちりとしたテストや動作確認用のプログラムを書くことなく、思いつくままにパパッと動作を試せるところにあります。

しかし、スレッドの動作を試そうと思った瞬間そう気軽にいかなくなります。スレッドが一度走り始めてしまうと介入できないので、例えばロックを試すために少なくとも2つの関数を用意して、この辺で止まっているときの動作を見たいのでこっちに sleep を入れあっちに sleep を入れ...という具合に計画性が求められるようになります。さらに、走り切った後は一気に流れた print ログを追いかけながら、これがこの順番で出てるから思った通りの順序で動いているはず...というように検証も面倒です。

そうした面倒臭さを多少とも避けて、気軽にあちらのスレッドでこれ動かして、続けてこちらのスレッドでこれを動かして...ということが REPL 上でできるちょっとしたライブラリ repl-threads を作ってみました。

動かしてみる

現状 repl-threads は quicklisp に登録していないので ql:quickload できるような位置にソースを持ってくることが必要です。Roswell を利用している場合は下記が簡単です。

$ ros install eshamster/repl-threads

REPL 上で quickload できたら準備完了です。

CL-USER> (ql:quickload :repl-threads)

まずは所望の数のスレッドを立ち上げます(rtsrepl-thraeds のニックネームです)。

CL-USER> (defparameter *rts* (rts:make-repl-threads 2))
*RTS*

スレッド内で指定の動作をさせるには、with-thread マクロに上記で作った repl-threads とスレッド番号(0からの連番)を指定して処理を書くだけです。

CL-USER> (rts:with-thread (*rts* 0)
           (print :test))
T
:TEST

これだけでは本当にスレッド内で動いているのか分からないので適当にロックをかけてみます。なお、bt は各種 Commmon Lisp 処理系のスレッド操作を抽象化している bordeaux-threads パッケージのニックネームです。repl-threads が依存しているので改めて quickload する必要はないです。

CL-USER> (defparameter *lock* (bt:make-lock))
*LOCK*
CL-USER> (rts:with-thread (*rts* 0)
           (bt:acquire-lock *lock*) ; まだ誰もロックを取っていないので
           (print :thread0))        ; ← の print はすぐ実行される
T
:THREAD0
CL-USER> (rts:with-thread (*rts* 1)
           (bt:acquire-lock *lock*) ; thread 0 にロックを取られているので
           (print :thread1)         ; ← の print は待たされる
           (bt:release-lock *lock*))
T
CL-USER> (rts:with-thread (*rts* 0)
           (bt:release-lock *lock*)) ; ← ロックを手放すと...
T
:THREAD1 ; ← 待たされていた thread 1 の print が実行される

また、スペシャル変数 *thread-index* にスレッド番号を格納しています。

CL-USER> (defun test ()
           (print rts:*thread-index*))
TEST
CL-USER> (rts:with-thread (*rts* 1)
           (test))
T
1

掃除は一関数で済みます。スレッドを破棄するだけで各種リソースの面倒まで見てくれるものではないですが...。

CL-USER> (rts:destroy-repl-methods *rts*)
NIL

中身

概要

基本的なアイディアは単純です。

  • 各スレッドはキューを持ち、関数が投げ込まれるのを待ち受ける
  • 投げ込まれた関数を順次実行する

REPL から各スレッドのキューに関数を投げ込むことで、任意の処理を後付けで実行できます。

ということで、次のような順序で作っていきます。

  1. queue: ただのキュー(スレッドアンセーフ)
  2. wait-queue: スレッドセーフなキュー
  3. repl-thread: 2 を利用して前述の動作をするスレッド
  4. repl-threads: 3 のスレッドを束ねるクラス

queue: ただのキュー

https://github.com/eshamster/repl-threads/blob/master/queue.lisp

特別なところはないただのキューなのでリンクだけ貼ります。head からの取り出しと tail への追加しかできない双方向リストとして実装しています。

こんな感じで利用します。

CL-USER> (use-package :repl-threads/queue)
T
CL-USER> (defparameter *q* (make-queue))
*Q*
CL-USER> (queue *q* 0)
0
CL-USER> (queue *q* 1)
1
CL-USER> (dequeue *q*)
0
CL-USER> (dequeue *q*)
1
CL-USER> (dequeue *q*)
NIL

wait-queue: スレッドセーフなキュー

https://github.com/eshamster/repl-threads/blob/master/wait-queue.lisp

先ほどのキューを使って次のようなキューを作ります。

  • スレッドセーフである
  • dequeue 時にキューが空なら queue されるまで待機する

まずは パッケージの定義ですが、先ほど作ったキューの他 bordeaux-threads から Lock, Condition Variable 関連の関数・マクロをインポートします。

(defpackage repl-threads/wait-queue
  (:use :cl)
  (:export :wait-queue
           :make-wait-queue
           :queue
           :dequeue)
  (:import-from :repl-threads/queue
                :make-queue
                :queue
                :dequeue
                :queue-length)
  (:import-from :bordeaux-threads
                :make-lock
                :with-lock-held
                :make-condition-variable
                :condition-notify
                :condition-wait))
(in-package :repl-threads/wait-queue)

クラス定義はこんな感じです。

(defclass wait-queue ()
  ((queue :initform (make-queue) :reader wq-queue)
   (cond-var :initform (make-condition-variable :name "WAIT QUEUE COND") :reader wq-cond-var)
   (wait-count :initform 0 :accessor wq-wait-count)
   (lock :initform (make-lock "WAIT QUEUE LOCK") :reader wq-lock)))

(defun make-wait-queue ()
  (make-instance 'wait-queue))

dequeue メソッドでは、キューに何か入っていればロックを取って値を取り出し、ロックを解放するだけです(when 内を通らないルート)。キューが空の場合は Condition variable を利用してキューに何か入るのを待ちます。 condition-wait は次のような動作をします。

  1. 渡されたロックを解放する
  2. 渡された Condition variable にシグナルが来るまで待つ
  3. シグナルが来たらロックを取得して次に進む
(defmethod dequeue ((wq wait-queue))
  (let ((lock (wq-lock wq))
        (q (wq-queue wq)))
    (with-lock-held (lock)
      (when (= (queue-length q) 0)
        (incf (wq-wait-count wq))
        ;; wait until some value is queued
        (condition-wait (wq-cond-var wq) lock))
      (assert (> (queue-length q) 0))
      (dequeue q))))

次に queue メソッドですが、基本的にはロックを取ってキューに値を詰め、ロックを解放するだけです。ただし、待ち状態の dequeue メソッドが存在する場合は、condition-notify でシグナルを出して待ちを解除します*2

(defmethod queue ((wq wait-queue) value)
  (let ((q (wq-queue wq)))
    (with-lock-held ((wq-lock wq))
      (queue q value)
      (when (> (wq-wait-count wq) 0)
        (decf (wq-wait-count wq))
        (condition-notify (wq-cond-var wq))))))

repl-thread: 投げ込まれた関数を実行するスレッド

https://github.com/eshamster/repl-threads/blob/master/repl-thread.lisp

パッケージの定義は次の通りです。ロック周りは wait-queue にお任せしているので、bordeaux-threads からはスレッドの生成・破棄関数だけを import します。

(defpackage repl-threads/repl-thread
  (:use :cl)
  (:export :make-repl-thread
           :queue-process
           :destroy-repl-thread)
  (:import-from :repl-threads/wait-queue
                :wait-queue
                :make-wait-queue
                :queue
                :dequeue)
  (:import-from :bordeaux-threads
                :make-thread
                :destroy-thread))
(in-package :repl-threads/repl-thread)

クラス定義と生成、破棄関数は次の通りです。

(defclass repl-thread ()
  ((thread :initarg :thread :reader rt-thread)
   (process-queue :initarg :process-queue  :reader rt-process-queue)))

(defun make-repl-thread ()
  (let ((q (make-instance 'wait-queue)))
    (make-instance 'repl-thread
                   :thread (make-thread (make-repl-thread-process q))
                   :process-queue q)))

(defmethod destroy-repl-thread ((rt repl-thread))
  (destroy-thread (rt-thread rt)))

次に、スレッド内で動作する関数を生成する make-repl-thread-process を見ます。といっても、dequeue で待ち、関数が来たら funcall で実行、を繰り返す関数を作るだけです。

(defmethod make-repl-thread-process ((process-queue wait-queue))
  (lambda ()
    (loop (funcall (dequeue process-queue)))))

そして、外部からスレッドに関数を供給するのが queue-process 関数です。受け取った関数をキューに詰め込むだけです。一応受け取ったものが関数かどうか程度のチェックはしていますが、引数ありの関数が funcall されるとスレッドが死んでしまうので、引数のチェックぐらいは追加しても良いかもしれません。

(defmethod queue-process ((rt repl-thread) process)
  (assert (functionp process))
  (queue (rt-process-queue rt) process)
  t)

repl-threads: repl-thread を束ねる

最後に repl-thread を束ねた repl-threads を作ります。パッケージの定義は次の通りです。repl-thread のラッパーなので、そこへだけ依存しています。

(defpackage repl-threads/repl-threads
  (:use :cl)
  (:export :make-repl-threads
           :queue-process-to
           :with-thread
           :destroy-repl-threads
           :*thread-index*)
  (:import-from :repl-threads/repl-thread
                :make-repl-thread
                :queue-process
                :destroy-repl-thread))
(in-package :repl-threads/repl-threads)

クラスとしては repl-thread の配列を持っているだけです。生成と破棄も素直に指定個数の repl-thread の生成と破棄をするだけです。

(defclass repl-threads ()
  ((threads :initarg :threads :reader rts-threads)))

(defun make-repl-threads (n)
  (let ((threads (loop :for i :from 0 :below n :collect (make-repl-thread))))
    (make-instance
     'repl-threads
     :threads (make-array n :initial-contents threads))))

(defmethod destroy-repl-threads ((rts repl-threads))
  (let ((threads (rts-threads rts)))
    (dotimes (i (length threads))
      (destroy-repl-thread (aref threads i)))))

queue-process-to は、インデックスで指定された repl-thread に対して queue-process を呼びます。

(defmethod queue-process-to ((rts repl-threads) thread-index process)
  (let ((threads (rts-threads rts)))
    (assert (< thread-index (length threads)))
    (queue-process (aref threads thread-index) process)))

これをラップしているのが with-thread マクロです。単純なラッパーとして動作するのに加えて、*thread-index* にスレッド番号を束縛する役割もあります。

(defvar *thread-index* -1)

(defmacro with-thread ((rts thread-index) &body body)
  (let ((g-thread-index (gensym "THREAD-INDEX")))
    `(let ((,g-thread-index ,thread-index))
       (queue-process-to ,rts ,g-thread-index
                         (lambda ()
                           (let ((*thread-index* ,g-thread-index))
                             (declare (ignorable *thread-index*))
                             ,@body))))))

おまけ: 色々試してみる

せっかく作ったので色々試してみます。

Recursive Lock

Recursive Lock は通常のロックと異なり、同一スレッド内であれば何度でも取得できるロックになります(解放はロックと同じ回数だけ必要)。なお、これは SBCL には実装されていないようです。下記は CCL 1.11.5 での動作例になります。

CL-USER> (defparameter *rts* (rts:make-repl-threads 2))
*RTS*
CL-USER> (defparameter *rec-lock* (bt:make-recursive-lock))
*REC-LOCK*
CL-USER> (rts:with-thread (*rts* 0)
           (bt:acquire-recursive-lock *rec-lock*)
           (print :thread0-1))
T
:THREAD0-1
CL-USER> (rts:with-thread (*rts* 0)
           (bt:acquire-recursive-lock *rec-lock*) ; 同じスレッド内なのでもう一度取れる
           (print :thread0-2))
T
:THREAD0-2
CL-USER> (rts:with-thread (*rts* 1)
           (bt:acquire-recursive-lock *rec-lock*) ; 別スレッドなので待たされる
           (print :thread1-1))
T
CL-USER> (rts:with-thread (*rts* 0)
           (bt:release-recursive-lock *rec-lock*))
T
CL-USER> (rts:with-thread (*rts* 0)
           (bt:release-recursive-lock *rec-lock*))
T
:THREAD1-1 ; 2回解放するとスレッド1が進めるようになる

Semaphore

セマフォ(Semaphore)は資源数に限りがある対象に触る場合に、同時に N 個のスレッドしか触れないようにする、といった操作を実現するために利用するものです。

CL-USER> (defparameter *rts* (rts:make-repl-threads 3))
*RTS*
;; 資源数2のセマフォをつくる
CL-USER> (defparameter *sem* (bt:make-semaphore :count 2))
*SEM*
CL-USER> (rts:with-thread (*rts* 0)
           (bt:wait-on-semaphore *sem*)
           (print :thread0))
T
:THREAD0
CL-USER> (rts:with-thread (*rts* 1)
           (bt:wait-on-semaphore *sem*)
           (print :thread1))

T
:THREAD1
;; 既に thread 0, 1 が資源を占有しているので待たされる
CL-USER> (rts:with-thread (*rts* 2)
           (bt:wait-on-semaphore *sem*)
           (print :thread2))
T
CL-USER> (rts:with-thread (*rts* 0)
           (bt:signal-semaphore *sem*))
T
:THREAD2 ; thread 0 が資源を手放したので thread 2 が動いた

Condition Variable

Condition Variable は wait-queue の実装でも利用したように、「何らかの条件が成立するまで待つ」(wait-queue であれば「キューに何か入るまで待つ」)用途で利用できます。ただし、こうした用途に適しているというだけで、Condition Variable 自体が何かの条件処理をしてくれる訳ではありません。

再掲すると、待ち側である condition-wait は下記のような動作をします。待ちを解除する condition-notify は単にシグナルを送るだけです。

  1. 渡されたロックを解放する
  2. 渡された Condition variable にシグナルが来るまで待つ
  3. シグナルが来たらロックを取得して次に進む

試してみます。

CL-USER> (defparameter *rts* (rts:make-repl-threads 2))
*RTS*
CL-USER> (defparameter *lock* (bt:make-lock))
*LOCK*
CL-USER> (defparameter *cond-var* (bt:make-condition-variable))
*COND-VAR*
CL-USER> (rts:with-thread (*rts* 0)
           (bt:acquire-lock *lock*)
           (print :thread0-before)
           ;; ここでロックが解除される
           (bt:condition-wait *cond-var* *lock*)
           (print :thread0-after)
           (bt:release-lock *lock*))
T
:THREAD0-BEFORE
CL-USER> (rts:with-thread (*rts* 1)
           ;; ロックを取れる
           (bt:acquire-lock *lock*)
           (bt:condition-notify *cond-var*)
           (print :thread1))
T
:THREAD1
;; ※condition-wait はロックを再取得できないのでまだ待たされる
CL-USER> (rts:with-thread (*rts* 1)
           (bt:release-lock *lock*))
T
:THREAD0-AFTER ; シグナルを受け取り、ロックも解除されたので進めた

wait queue

せっかくなので部品として作った wait-queue も試してみます。

CL-USER> (defparameter *rts* (rts:make-repl-threads 2))
*RTS*
CL-USER> (use-package :repl-threads/wait-queue)
T
CL-USER> (defparameter *wq* (make-wait-queue))
*WQ*
CL-USER> (rts:with-thread (*rts* 0)
           (queue *wq* 0)
           (queue *wq* 1))
T
CL-USER> (rts:with-thread (*rts* 1)
           (print (dequeue *wq*))
           (print (dequeue *wq*))
           ;; ↓2つしか入っていなかったので待たされる
           (print (dequeue *wq*)))
T
0
1
CL-USER> (rts:with-thread (*rts* 0)
           (queue *wq* 2))
T
2 ; ← 待たされたものが動いた

*1:検索すると Clojure 記事が多く出てきますが、用語自体は新しめなのでしょうか?

*2:bordeaux-thread のドキュメントによると、condition-notify は実装によって1つの待ちだけにシグナルを送るものと、全ての待ちにシグナルを送るものがあるとのことです。とはいえ基本的には前者とのことなのでその想定で実装しています

cl-base + rove + Travis CI でテストする

Lisp Advent Calendar 2019 6日目の記事です。小ネタです。



動機

かねてより Common Lispリポジトリでは Roswell を利用して SBCL, CCL の2処理系ぐらいで Travis CI 上で CI を回すようにしています(例: .travis.yml)。ただ、(依存している SBCL の更新の影響が多い印象ですが)ちょくちょく Roswell のインストールに失敗して CI が死ぬことがあります(最近死んだ原因)。

そこで、Roswell インストール済みの拙作 eshamster/cl-base コンテナ上でテストを走らせることで、この辺りの悩みからある程度解放されるのでは...という期待がこの記事の動機です。なお、この cl-base の latest は週1で自動ビルドされています。バージョンタグは...気紛れで更新されます(現在 2.4.1 が最新)。

他、記事タイトルの rove は深町さん作のテストライブラリです。 package-inferred-system に対応しているあたりを理由にいつも使わせて頂いています。

できたもの

本題に入る前に、下記のリポジトリを作って試行錯誤していました。CC0ライセンスなので万が一使いたい方が入れば適当にコピーして持っていってください。rove + Travis CI + SBCL & CCL な CI が目的であれば .travis.yml ファイルと test-docker フォルダをそのまま持っていけば動くはずです。(Roswellでインストール可能な)処理系を足し引きしたい場合は2箇所ほど手を入れれば動くはずです。

github.com

中身

本題は下記の4ファイルだけなのでササッと見ていきます。いずれも短いものなので全文コピーしています。

.
├── .travis.yml
└──test-docker
    ├── Dockerfile
    ├── run.sh
    └── test.sh

まずは入口になる .travis.yml を見ます。

https://github.com/eshamster/try-test-in-docker/blob/master/.travis.yml

services:
  - docker

env:
  matrix:
    - LISP=sbcl-bin
    - LISP=ccl-bin

before_install:
  - docker build -t test test-docker

script:
  - test-docker/run.sh
  • envmatrix で対象の処理系を指定します
    • 処理系の足し引きで要書き換えな箇所その1
  • before_installtest-docker フォルダのファイルで docker build するだけです
  • script も同フォルダのスクリプトを走らせるだけです

※2019/12/24 追記:警告が出ていたことに気付いたので若干修正しました

次に Dockerfile です。

https://github.com/eshamster/try-test-in-docker/blob/master/test-docker/Dockerfile

FROM eshamster/cl-base:2.4.1

ADD ./test.sh /root
RUN ros install ccl-bin && \
    ros install rove

CMD ["/root/test.sh"]
  • SBCL は Roswell と共に入るので、追加で CCL (ccl-bin) をインストールします
    • 処理系の足し引きで要書き換えな箇所その2

次にここの CMD で走らせる test.sh です。

https://github.com/eshamster/try-test-in-docker/blob/master/test-docker/test.sh

#!/bin/sh

set -eux

ros use ${LISP}

cd ~/.roswell/local-projects/target
rove *.asd
  • 基本的に後述の run.sh のお膳立てのもとに rove を走らせるだけです
    • お膳立て1: LISP 環境変数の供給
    • お膳立て2: ~/.roswell/local-projects/target へのプロジェクト設置
  • ここで ros install ${LISP} をすれば処理系足し引き時に Dockerfile の書き換えは不要になりますが build 時にやっておきたい気持ち

最後に run.sh です。

https://github.com/eshamster/try-test-in-docker/blob/master/test-docker/run.sh

#!/bin/sh

set -eux

base_dir=$(dirname ${0})
cd ${base_dir}/..
docker run -e LISP=${LISP} -v $(pwd):/root/.roswell/local-projects/target -t test
  • test.sh のためのお膳立てをして docker run します。

ということで小ネタでした。


【マクロ小ネタ】Common Lisp で defer してみる

時には実用を考えずにマクロを書いて遊んでいると楽しいというだけの記事です。

Go言語の defer が簡単に実装できそうな気がしたので書いてみました。と思っていたら、途中で記事後半の事実に気付いて思ったよりも長くなりました。



defer の単純な模倣

Go言語における defer の動作

Go言語において、defer を利用することで、関数スコープを抜けるときに実行する動作を記述することができます。リソースのクローズなどに利用しますが、ここではそうした実践的な例は捨ておき、次のような例のための例を見ます(以下は適宜抜粋したもの。動作するコードは https://play.golang.org/p/EWOSf5oa3_5

func test(x bool) {
    fmt.Println("before")
    defer fmt.Println("after")

    if !x {
        return
    }

    defer func() {
        fmt.Println("1")
        fmt.Println("2")
    }()
    fmt.Println("3")
}

この defer には次のような特徴があります。

  1. 複数の defer がある場合、通ったのとは逆順で実行される
  2. 実行時に通った defer のみが動作する

まず特徴1を見るため、test(true)として実行すると次のような出力になります。後ろにある "1", "2" を出力する defer の方が、"after" を出力する defer よりも先に実行されています。

before
3
1
2
after

次に特徴2を見るため、test(false)として実行すると次のような出力になります。途中で return して通過しなかった "1", "2" を出力する defer は実行されません。

before
after

マクロを書いて模倣する: with-defer

上で見たような特徴を持つ defer を利用することができるマクロ with-defer を作ってみます。

実装は後で見ますが、これを利用することで先程の test 関数と同じ動作の関数を次のように書けます。ただし、defer が実行されるのは関数スコープを抜けるときではなく、with-defer を抜けるときになります*1

(defun test (x)
  (with-defer
    (print 'before)
    (defer (print 'after))
    (unless x
      (return-from test))
    (defer (print 1) (print 2))
    (print 3)))

動かしてみます。まずは (test t) です。下記の通り、後に出てくる defer ("1", "2" を出力)が最初の defer("AFTER" を出力)よりも先に実行されます。

BEFORE
3
1
2
AFTER

次に (test nil) です。下記の通り、到達しなかった2つ目の defer は実行されません。

BEFORE
AFTER

さて肝心の実装ですが、下記の通り10行程度のマクロで実現できます。

(defmacro with-defer (&body body)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    `(push (lambda () ,@,g-body)
                           ,',g-defer-list)))
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

with-defer の中でのみ動作するローカルマクロ defer は、渡された g-body 部で無名関数を組み上げ、リスト g-defer-list に追加します。このリストに詰め込まれた無名関数は unwind-protect を抜けるとき(いわゆる try-finally の fianlly 部)に、リストに入れたのとは逆の順序で取り出されて実行されます。

という感じで、容易に動作を模倣することができました。

ちなみに、複数行に渡る動作を defer に渡す場合、Go言語では次のように明示的に無名関数で包んであげる必要があります。

   defer func() {
        fmt.Println("1")
        fmt.Println("2")
    }()

一方で、上で実装した defer は暗黙的に無名関数で包んでいるため、複数行に渡る動作も単に並べるだけで良いです。

(defer
  (print 1)
  (print 2))

deferの直接呼び出し形式における引数の先行評価

Go言語の場合

実は、上記で実装した defer では1つ模倣できていないことがあります。それは、直接呼び出し形式における引数の先行評価です...というと分かりにくいですが、例を見てみます( https://play.golang.org/p/HwOBMnxEe33 )。

func test() {
    for i := 0; i < 3; i++ {
        defer fmt.Printf("direct:  %d\n", i) // 直接呼び出す
    }
    for i := 0; i < 3; i++ {
        defer func() {
            fmt.Printf("closure: %d\n", i)   // クロージャに包んで呼び出す
        }()
    }
}

この test 関数を実行すると次のような結果になります*2。見ての通り、クロージャに包んだ方は、ループが回りきった後の i の値である3を出力し、直接呼び出した方は defer が評価された時点の i の値を出力します。

closure: 3
closure: 3
closure: 3
direct:  2
direct:  1
direct:  0

これは、直接呼び出しの場合に限り、引数をその場で評価することから来る動作のようです。次のようにすると、その動作がよりはっきりします( https://play.golang.org/p/z_m-Kr-pxsM )。

func f(s string) string {
    fmt.Println(s)
    return "inner"
}

func test() {
    defer f(f("outer"))
    fmt.Println("normal")
}

この test 関数を実行すると次のような結果になります。defer に渡した f(f("outer")) の「引数」である f("outer")defer を通過した時点で評価されます。このため、"normal" よりも先に "outer" の出力が来ることになります。

outer
normal
inner

引数の先行評価を模倣する: with-defer2

先程作成した with-defer マクロ内の defer は単にクロージャで包んでいるだけであるため、上で見たような先行評価を模倣することができていません。

(with-defer
  (dotimes (i 3)
    (defer (print i))))

上記を実行すると、ループ後の i の値3が取り出されています。

3
3
3

さて、引数の先行評価を模倣するにあたり、まずは実現方式を考えてみます。現在の with-defer を手で展開すると次のようになります。

(let (lst)
  (unwind-protect
       (dotimes (i 3)
         (push (lambda ()
                 (print i)) ; ← この i は...
               lst))
    (dolist (fn lst)
      (funcall fn))))       ; ← この funcall 時点まで評価されない

次のようにすることで、defer = push 時点で i を評価させることができます。

(let (lst)
  (unwind-protect
       (dotimes (i 3)
         (push (let ((x i)) ; ← この時点で i が評価される
                 (lambda ()
                    (print x)))
               lst))
    (dolist (fn lst)
      (funcall fn)))) ; ← x の評価はここだが、評価済みの i が入っている

上記の出力は目的通りの形になります。

2
1
0

後はこれをマクロとして実装するだけです。その前の準備として、ネストしたバッククォートを扱い続けるのはしんどいので、補助関数を切り出します。先程の with-defer と等価な実装は下記の通りです。

(defun defer% (defer-list body)
  `(push (lambda () ,@body)
         ,defer-list))

(defmacro with-defer (&body body)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    (defer% ',g-defer-list ,g-body))) ; ← ここを切り出した
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

できあがったものがこちらです。行数としては30行程度ですが、だいぶしんどい実装になっています。しんどい主な原因はGo言語の defer における「直接呼び出しで書けるのは関数呼び出しに限る」という制約がないためです。with-defer の場合、アトム, 関数, マクロ, スペシャルフォームのいずれも許容していますが、このうち単純に引数を評価してよいのは関数だけです。この辺りの振り分けをしているのが true-function-p です(たぶんバグがあります)。

(defun true-function-p (head env)
  (if (listp head)
      (functionp head)    ; ← (lambda (x) x) 形式を捕捉するため
      (and (fboundp head)
           (not (special-operator-p head))
           (not (macro-function head env)))))

(defun defer2% (defer-list body env)
  `(push ,(if (and (= (length body) 1) ; ← body部が1つのときだけ先行評価をする
                   (listp (car body))
                   (true-function-p (caar body) env))
              ;; ↓の部分は (fn x y z) を次のように展開する操作
              ;; (let ((a0 x)
              ;;       (a1 y)
              ;;       (a2 z))
              ;;   (fn a0 a1 a2))
              (let ((args (loop :for i :from 0 :below (length (cdar body))
                             :collect (intern (format nil "A~D" i)))))
                `(let ,(loop :for arg :in args
                             :for exp :in (cdar body)
                          :collect (list arg exp))
                   (lambda () (,(caar body) ,@args))))
              ;; ↓(いわゆる)else部は元の defer% と同じ
              `(lambda () ,@body))
         ,defer-list))

(defmacro with-defer2 (&body body &environment env)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    ;; ↓ここで defer2% を呼ぶことと、
                    ;;   引数に &environment を取っている以外は with-defer と同じ
                    (defer2% ',g-defer-list ,g-body ,env)))
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

ということで、下記のように呼び出してみると...

(with-defer2
  (dotimes (i 3)
    (defer (print i))))

所望の通り、先行評価できていることが分かります。

2
1
0

しかし、せっかく関数以外も受け入れられたり、複数行(= body部が2つ以上)を受け入れられたりするのに、次の例に見るように色々な制約があって今いちしっくりきません。

;; これは先行評価にならない(スペシャルフォーム let で包んだので)
(with-defer2
  (dotimes (i 3)
    (defer (let ()
             (print i)))))

;; これも先行評価にならない(body部が2つ以上あるので)
(with-defer2
  (dotimes (i 3)
    (defer (print i) (print i))))

関数以外の場合に、必要な部分だけ正しく先行評価をするのは結構大変です。複数行に渡って先行評価を行うようにすることはまだ容易ですが、関数以外への対応をしないまま導入しても、式によって先行評価されたりされなかったりとなって余り嬉しくはなさそうです。

別の道を探ってみる: with-defer!

さて、前節で実装した with-defer2 ですが、動作はGo言語を模倣しているものの今いちしっくりこない結果となってしまいました。

ここで、マクロ側に自動で先行評価の有無を判断させるという方向性を捨てて、マクロの利用者に先行評価をコントロールさせる道を考えてみます。Common Lisp は多大な自由を与える代わりにプログラマにその制御の責を負わせる傾向が強い言語であるため、こうした方向の方が馴染みそうです。

ということで、次のようにプレフィックス c! をつけたシンボルは先行評価された元の(=プレフィックスなしの)シンボルの値が入るような with-defer! マクロを書くことにします。

(with-defer!
  (dotimes (i 3)
    (defer (format t "~D:~D~%"
                   c!i   ; ← 先行評価した i の値が入る
                   i)))) ; ← 先行評価しない

実行結果は次のようになります。

2:3
1:3
0:3

実装は次のようになります。行数的には with-defer2 より若干長いですが、関数の判定といった辛い作業がないため、かなり気楽な実装になっています。なお、読んだことのある方は分かると思いますが、Let Over Lambdadefmacro! マクロの実装やインタフェースを多いに参考にしています*3

;; 補助関数:ネストしたリストをフラットなリストに変換する
;; Ex. (1 2 (3 4 (5)) 6 7) -> (1 2 3 4 5 6 7)
(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec
                       (car x)
                       (rec (cdr x) acc))))))
    (rec x nil)))

;; 補助関数:シンボル名に "c!" のプレフィックスがあるか判定する
(defun c!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "C!"
                :start1 0
                :end1 2)))

(defmacro with-defer! (&body body)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    (let (; ↓ "c!" プレフィックスつきのシンボルを抽出する
                          (syms (remove-duplicates
                                 (remove-if-not #'c!-symbol-p
                                                (flatten ,g-body)))))
                      ;; ↓ c!a, c!b, c!c を見つけたとすると、次のように変換される
                      ;;   (let ((c!a a)
                      ;;         (c!b b)
                      ;;         (c!c c))
                      ;;     ...)
                      `(push (let ,(mapcar (lambda (s)
                                             `(,s ,(intern (subseq
                                                            (symbol-name s)
                                                            2))))
                                           syms)
                               (lambda () ,@,g-body))
                             ,',g-defer-list))))
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

この方法であれば、defer の中に式が複数あるとダメとか let のようなスペシャルフォームで包むとダメといった制約はありません。

(with-defer!
  (dotimes (i 3)
    (defer (print c!i)
           (let ((x 100))
             (print (+ c!i x))))))
;; ↓実行結果
2
102
1
101
0
100

こうして様々な「構文」をいじって遊べるのは Lisp の面白いところですね。


*1:例ではやっていませんがネストさせることもできます

*2:ちなみに、クロージャの方は "loop variable i captured by func literal" と go vet に怒られます

*3:実装が似ているだけで動作的には無関係なので、defmacro! の詳細は略します

【小ネタ】 簡易な関数定義マクロ, マクロ定義マクロを自作してみる

defunまでマクロで出来ているということはユーザがその気になれば関数定義の構文に手を入れたりも出来るということだ。 ~中略~ このような設計はマクロで制御構造までも作れるから出来るのだ。関数定義構文をマクロで定義している言語はLisp以外に私は知らない。

マクロについて整理してみる | κeenのHappy Hacκing Blog

とあるように、多くの言語において言語の基本要素である関数定義構文すらマクロで作れてしまうという点は、Lisp の特異でありまた面白い点です。そんな訳で、ごく簡易なものであればほんの数行で作れてしまう、という所を実際の Common Lisp のコードで見てみたいと思います。

なお、記事中の出力例は Clozure CL 1.11.5 を利用しています。



my-defun

まずは、結局のところ defun による名前付き関数の定義とは何をしているのかを見てみます。

とりあえず関数を一個定義してみます。

CL-USER> (defun hoge (a b)
           (+ a b))
HOGE
CL-USER> (hoge 1 2)
3

少々天下り式になりますが、このとき hoge シンボルの関数領域に「関数の実体」がひもづけられます。これは symbol-function によって確認することができます。

CL-USER> (symbol-function 'hoge)
#<Compiled-function HOGE #x3020045173AF>
CL-USER> (funcall #<Compiled-function HOGE #x3020045173AF> 1 2)
3

いきなり結論になりますが、この「シンボルの関数領域への関数のひもづけ」が「名前つき関数の定義」という操作の本質的な部分です。実際、シンボルの関数領域へ直接無名関数をひもづけてみると、同シンボルを関数として扱うことができてしまいます。

CL-USER> (setf (symbol-function 'hoge2)
               (lambda (a b)
                 (- a b)))
#<Anonymous Function #x3020045F404F>
CL-USER> (hoge2 1 2)
-1

ということで、「シンボルの関数領域へ無名関数をひもづける」操作をマクロ化した my-defun を作ってみます。

CL-USER> (defmacro my-defun (name args &body body)
           `(setf (symbol-function ',name)
                  (lambda ,args
                    ,@body)))
MY-DEFUN

使ってみます。できていますね。

CL-USER> (my-defun hoge3 (a b)
           (* a b))
#<Anonymous Function #x30200460884F>
CL-USER> (hoge3 2 3)
6

もちろん、これは実際のdefun に比べると全然機能が足りません。例えば、block を置いていないので、関数の途中で return-from することができません。が、そのぐらいであれば簡単に my-defun へ追加できます。

CL-USER> (defmacro my-defun (name args &body body)
           `(setf (symbol-function ',name)
                  (lambda ,args
                    (block ,name ; ← これ
                      ,@body))))
MY-DEFUN

return-from してみます。

CL-USER> (my-defun hoge4 ()
           (return-from hoge4 100)
           0)
#<Anonymous Function #x3020045E972F>
CL-USER> (hoge4)
100

ついでに、一々 (return-from <関数名>) と書くの面倒臭い!と思ったと仮定して、関数名なしでreturnできる my-return を使えるようにしてみます。

CL-USER> (defmacro my-defun (name args &body body)
           `(setf (symbol-function ',name)
                  (lambda ,args
                    (block ,name
                      (macrolet ((my-return (&optional return-value) ; ← これ
                                   `(return-from ,',name ,return-value)))
                        ,@body)))))
MY-DEFUN

my-return してみます。

CL-USER> (my-defun hoge5 ()
           (my-return 100)
           0)
#<Anonymous Function #x30200462C7AF>
CL-USER> (hoge5)
100

こんな感じで、シンプルな操作から始めて、自分で必要十分なところまで自作関数定義マクロを定義できてしまうというのは実に面白いところです。

my-defmacro

この辺から少々気味が悪くなるような話です。

defun はマクロとして定義されていたので、自身で再定義することができました。では、マクロを定義するのに利用した defmacro が何者かというと...CLHS に「Macro DEFMACRO」と書かれています。そう、defmacro もマクロです。つまり、自身で再定義することができます。

さて、関数定義と同じように、(名前付きの)マクロを定義するとシンボルのマクロ関数領域に(特定の形式の)関数がひもづけられます。これは、macro-function によって確認できます。

CL-USER> (macro-function 'my-defun)
#<Compiled-function MY-DEFUN Macroexpander #x30200453175F>

これまた my-defun で見たのと同様に、マクロ関数領域に自身で関数をひもづけることができます。

CL-USER> (setf (macro-function 'my-defun2)
               (lambda (param env)
                 (declare (ignore env))
                 (destructuring-bind (name args &body body) (cdr param)
                   `(setf (symbol-function ',name)
                          (lambda ,args
                            ,@body)))))
#<Anonymous Function #x30200463142F>

ここでは2つの引数をとる関数をひもづけています。第1引数 param は先頭にマクロ自身の名前、それ以降((cdr param))にいわゆるマクロの引数が入っています。なので、引数を destructuring-bind で取り出しています。第2引数 env はレキシカルな環境の情報が入っていますが、ややこしいので無視します*1

使ってみます。さすがにSLIMEの構文解析が追いつかないのでインデントはおかしくなっていますが動いています。

CL-USER> (my-defun2 hoge6 (a b)
                    (/ a b))
#<Anonymous Function #x3020046254BF>
CL-USER> (hoge6 1 2)
1/2

ここでまた my-defun と同じように...といきたいところですが、defmacro を利用するのは本末転倒です。いったん立ち止まって、ここまでで何が分かったのかを考えてみると、次のようになります。

「任意の」マクロを定義する = macro-function 領域に「任意の」コードを出力する関数をひもづける

この「任意の」は本当に任意です。つまりネストすることもできます。この左辺がやりたいことです。

「任意のマクロを定義する」マクロを定義する
  = macro-function 領域に
   「macro-function 領域に任意のコードを出力する関数をひもづける」
   コードを出力する関数をひもづける

右辺をじっくり見ていると頭が痛くなりそうですが、深く考えずにコードの方もネストさせてみます。

CL-USER> (setf (macro-function 'my-defmacro)
               (lambda (param env)
                 (declare (ignore env))
                 (destructuring-bind (name lambda-list &body body) (cdr param)
                   `(setf (macro-function ',name)
                          (lambda (param env)
                            (declare (ignore env))
                            (destructuring-bind ,lambda-list (cdr param)
                              ,@body))))))
#<Anonymous Function #x30200464CD9F>

この my-defmacro を利用して改めて関数定義マクロを定義します。

CL-USER> (my-defmacro my-defun3 (name args &body body)
                      `(setf (symbol-function ',name)
                             (lambda ,args
                               ,@body)))
#<Anonymous Function #x3020045F928F>

確かに動いています。

CL-USER> (my-defun3 hoge7 (a b)
                    (+ a a b b))
#<Anonymous Function #x3020045E580F>
CL-USER> (hoge7 1 2)
6

そんな訳で、マクロを定義するマクロを自身で再定義することができました。マクロの実用的な面白さはどんなマクロを書けるのかという方向にある訳ですが、ときには逆方向を眺めてみるのも面白いですね。


*1:扱おうと思ったら、param 内の &environment を自前で解析して env を束縛してあげればできそうな気はします...が、試していません

【Emacs】 Docker 上で Go 開発環境を作ろうとしてハマった(ている)話

近頃お仕事で Go を書くことになり、Mac 上で Emacs + LSP(サーバ: gopls, クライアント: eglot)な環境を作りました。これには下記の記事に全面的に依拠しております。

そして、割と良い感じに動いているので、1年ぐらい前に作って放置していた Docker 開発環境にも反映させるか...と思ってだいぶハマったというのが本記事の内容です。一応の解決はしたつもりですが、どう見てもアドホックな方法なので、何か知っている人がいたら教えて欲しいというぐらいの精度です。

Docker 上では下記OSをゲストとして利用しています。

なお、現状確認できているのは、Mac 上に直接インストールした Emacs では問題なかったということと、Docker 上の Alpine Linux で問題があったということだけなので、実は Docker は関係ないかもしれないです。



問題1: eglot がインストールできない

現象

通常は (pacakge-install 'eglot) で何事もなく終わるはずの eglot (LSP クライアント)のインストールですが...以下のエラーでインストールに失敗しました。

error: Package `jsonrpc-1.0.7' is unavailable

なお、これを後述の方法で解決すると、今度は次のエラーで怒られるので同様に対処が必要です。

error: Package `flymake-1.0.5' is unavailable

再現手順

下記の手順で再現します。

$ docker run --name alp -it alpine:3.10 /bin/sh
# - 以下コンテナ内の操作 - #
$ cd
$ apk add --no-cache emacs
$ mkdir .emacs.d
$ cat<<EOF>.emacs.d/init.el
(require 'package nil t)
(add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/") t)
(package-initialize)
(package-refresh-contents)
(package-install 'eglot)
EOF

ここで、Emacs を起動すると *Warning* バッファに先程のエラーが表示されます。

$ emacs -nw

調査

調べてみたものの、類似の現象として straight.el という別パッケージでの下記 issue が引っかかったぐらいでした。

Can't install elpa package jsonrpc · Issue #293 · raxod502/straight.el

この issue によると、下記のような経緯で jsonrpc パッケージが見つからないようになってエラーになったようです。

  1. 当初は jsonrpc は独立したパッケージとして開発されていた
  2. これが Emacs 本体に取り込まれることになった
  3. そして、MELPA (Emacs のパッケージリポジトリの一つ) も本体に jsonrpc があることを期待するようになった
  4. しかし、Emacs 側はまだ開発段階であったので、2 の反映には次のバージョンアップを待つ必要があった

しかし、解決方法が straight.el 固有なものであることと、現在 (Emacs 26.2) では上記4の状況は解消されていることから、今回の現象の解決には利用できません。

ただ、jsonrpc にしても flymake にしても、Emacs 本体に存在するものであるという共通点はあり、原因の根はそこにありそうです。

追記:解決

記事を上げた後、Common Lisp 開発環境のcl-devel2 でビルドエラーが起きていたので調べていたのですが、ふと下記のメッセージが目につきました *1

Failed to download ‘gnu’ archive.

とりあえず、gnu アーカイブのURLを明示的に指定してみました。

$ docker run --name alp -it alpine:3.10 /bin/sh
# - 以下コンテナ内の操作 - #
$ cd
$ apk add --no-cache emacs
$ mkdir .emacs.d
$ cat<<EOF>.emacs.d/init.el
(require 'package nil t)
;; ----- ↓ これ ----- ;;
(add-to-list 'package-archives '("gnu" . "http://elpa.gnu.org/packages/"))
(add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/") t)
(package-initialize)
(package-refresh-contents)
(package-install 'eglot)
EOF
$ emacs -nw

通りました

Leaving directory `/root/.emacs.d/elpa/flymake-1.0.8'
^L
Compiling file /root/.emacs.d/elpa/flymake-1.0.8/flymake.el at Mon Jul 15 07:17:11 2019
Entering directory `/root/.emacs.d/elpa/flymake-1.0.8/'
^L
Compiling no file at Mon Jul 15 07:17:12 2019
Leaving directory `/root/.emacs.d/elpa/jsonrpc-1.0.7'
^L
Compiling file /root/.emacs.d/elpa/jsonrpc-1.0.7/jsonrpc.el at Mon Jul 15 07:17:12 2019
Entering directory `/root/.emacs.d/elpa/jsonrpc-1.0.7/'
^L
Compiling no file at Mon Jul 15 07:17:12 2019
Leaving directory `/root/.emacs.d/elpa/eglot-20190702.2158'
^L
Compiling file /root/.emacs.d/elpa/eglot-20190702.2158/eglot.el at Mon Jul 15 07:17:12 2019
Entering directory `/root/.emacs.d/elpa/eglot-20190702.2158/'
Warning (bytecomp): Unused lexical variable `desc'
Warning (bytecomp): Unused lexical variable `file1'

ただ、*Messages* バッファの方には依然として Failed to download ‘gnu’ archive. が出ているので、きっかけにはなりましたが別の現象のようです。

Obsolete: 解決?

上記の原因の根と思われるものの解明には至っておらず...力業で解決しました。ローカルに jsonrpc.el, flymake.el を落としてきて手ずからインストールする方法です。

まず、適当なフォルダに両ファイルを落としてきます(実際には下記に相当する操作を Dockerfile 側に書いています)。

$ emacs_src="~/.emacs.d/src/"
$ mkdir ${emacs_src}
$ cd ${emacs_src}
$ wget https://raw.githubusercontent.com/emacsmirror/jsonrpc/master/jsonrpc.el
$ wget https://raw.githubusercontent.com/emacsmirror/flymake/master/flymake.el

次に ~.emacs.d/init.el に下記の記述を加えて、両パッケージをインストールします*2。なお、各 .el を単に load-path するだけではパッケージマネージャが認識してくれないので不十分です。

(dolist (pack-name '("jsonrpc" "flymake"))
  (package-install-file
   (concat "~/.emacs.d/src/" pack-name ".el")))

これで、(package-install 'eglot) が無事通るようにはなり、eglot も無事動作しているようです。

問題2: gofmt が効かない

現象(・再現方法)

セーブ時に自動で goimports をかけるためには、下記のようにフックを設定します。

(use-package go-mode
  :commands go-mode
  :config
  (setq gofmt-command "goimports")
  (add-hook 'before-save-hook 'gofmt-before-save))

しかし、これまた Mac では起きていなかったエラーが発生しました...。

Invalid rcs patch or internal error in go--apply-rcs-patch

調査

取りあえずエラーメッセージでググってみたものの... go-mode.el ソースのエラーメッセージぐらいしかヒットしませんでした。

https://github.com/dominikh/go-mode.el/blob/35f6826e435c3004dabf134d0f2ae2f31ea7b6a2/go-mode.el#L1038 *3

(defun go--apply-rcs-patch (patch-buffer)
  "Apply an RCS-formatted diff from PATCH-BUFFER to the current buffer."
...
          (unless (looking-at "^\\([ad]\\)\\([0-9]+\\) \\([0-9]+\\)")
            (error "Invalid rcs patch or internal error in go--apply-rcs-patch"))
...

goimports した前後の差分をチェックして適用するみたいな動作をしているようです。チェックで落ちているようですが原因は良く分かりません。

解決?

マイナーっぽい問題をマジメに調査するのも辛いな...と思い、 gomimports をかける関数を自作することにしました。アドホックですね。

下記の my-gofmt-hookbefore-save-hook に設定して、セーブ前に動作させます。フック内でいったんセーブ(save-buffer)してしまってから goimports -w で直接ファイルを書き換えるという乱暴な方法をとっています*4。なお、フックをかけたままセーブしようとすると無限に save-buffer してしまうので、いったんフックを外してから最後にフックを戻すという操作をしています。アドホックですね。

(defun my-gofmt-hook ()
  (unwind-protect
      (progn
        (remove-hook 'before-save-hook 'my-gofmt-hook)
        (save-buffer)
        (shell-command (concat "goimports -w " (buffer-file-name)))
        (revert-buffer t t t))
    (add-hook 'before-save-hook 'my-gofmt-hook)))

実際にフックを設定しているのが下記です。セーブ後に revert-buffer でバッファを読み直さないと構文解析が狂ってしまうようだったので、after-save-hookrevert-buffer をかけています。アドホックですね。

(use-package go-mode
  :commands go-mode
  :defer t
  :config
  (add-hook 'before-save-hook 'my-gofmt-hook)
  ;; The following is required to avoid wrong analysis by LSP server.
  (add-hook 'after-save-hook
            '(lambda ()
               (revert-buffer t t t))))

*1:なお、cl-devel2 の方のエラーはこれとは無関係です

*2:この操作が終わった段階でwgetした.elファイルは消して良いと思いますが、念のため残しています

*3:一応、引用した同関数の末尾に同じエラーメッセージがありますが、パッと見た感じ引用部分が通っていれば末尾の方にいくことはなさそうに見えます

*4:慎重にやるのであれば、一時ファイルを作成してバッファの内容をコピーしてセーブ。一時ファイルに goimports をかけてから書き戻すようにするのが良さそうです。元々使おうとしていた go-mode のフックも大枠はそのような動作をしているように見えます(ちゃんと調査してませんが...)

proto-cl-client-side-rendering に画像描画機能を追加した話

前回記事でクライアントサイドレンダリング (2D) のためのライブラリを実装してみました。

eshamster.hatenablog.com

この時点では丸や四角といったプリミティブな図形の描画しかできませんでした。画像(テクスチャ)の描画機能も必要だろうなと思いつつ面倒なので後回しにしていました。そして、ようやく実装したというのが今回の話ですが、思った通り面倒だったので後から見返すためのメモを残しておこうという趣旨のメモ記事です。

見返し用に作ったセルフプルリク↓

github.com



面倒なところ

おおむね下記が面倒なところです。

  • 単一の画像ファイルに複数の画像が埋め込まれている
  • 透過処理のために2つの画像(元画像とアルファマップ)が必要になる
  • 層によってデータの形が異なる
    • ライブラリ外部へのインタフェース層
    • プロトコル
    • クライアント層

用語について

本題の前に、textureとimageという用語を勝手に定義して使ってしまっているのでその説明です。

  • texture: 物理的な画像ファイル1つ1つに対応する情報
    • 正確には、アルファマップがある場合は元画像 + アルファマップの2ファイルに対して1つのtextureが対応します
  • image: 1つのtextureに対して複数のimageが対応する。1つの画像ファイルは複数の画像を含む場合があり、どこからどこまでを1つの画像として扱うかという情報をimageで持っている

何となくtextureの方が具象的な印象があり、一方でimageの方が抽象的な印象があったのでこの名付けにしていますが、そんなに深くは考えていません。

うまく説明できている気がしないので具体例で見ます。

f:id:eshamster:20170812024633p:plain

「A」と「B」という2つの画像を含んだ1つの画像ファイルで、これが1つのtextureに対応します。実際に描画する際には、「A」は「A」、「B」は「B」で個別に扱いたいとします。そのためには2つのimageをこのtextureに対応づけます。1つ目のimageはtextureの左半分の領域を指定し、2つ目のimageはtextureの右半分の領域を指定します。そして、「A」を描画したいときには1つ目のimageを、「B」を描画したいときには2つ目のimageを選択して描画する、といった形になります。

各層の実装

下記の層を順番に見ていきます。

  • ライブラリ外部へのインタフェース層
  • プロトコル
  • クライアント層

ライブラリ外部へのインタフェース層

利用例として、ライブラリ配下に置いているサンプル sample/sample-texture.lisp を見てみます。

まず、画像ファイル = textureをロードする部分です。 multiple_image.png とそのアルファマップである multiple_image_alpha.png(パスの起点は後述)に :multiple-image という名前をつけてロードしています。

  (load-texture :name :multiple-image
                :path "multiple_image.png"
                :alpha-path "multiple_image_alpha.png")

これは先程も載せた、「A」と「B」を1つの画像ファイルにまとめたものです。

f:id:eshamster:20170812024633p:plain

ここから2つのimageを抽出します。1つは左半分を取り出した :a で、もう1つは右半分を取り出した :b です。取り出し範囲は、画像の左下を (0, 0)、右上を (1, 1) とする、いわゆる UV 座標系で指定します。

  (load-image :image-name :a
              :texture-name :multiple-image
              ;; 補足: デフォルトは x = 0, y = 0, width = 1, height = 1
              :uv (make-image-uv :width 0.5))
  (load-image :image-name :b
              :texture-name :multiple-image
              :uv (make-image-uv :x 0.5 :width 0.5))

こうして作成した image は次のように使います。:image-name として :a を指定し、あとは座標や大きさなど描画に必要な情報を指定します。

    (draw-image :id (incf id)
                :image-name :a
                :x 500 :y 300
                :width 50 :height 50
                :rotate (* -1/10 *temp-counter*)
                :depth 0 :color #xffffff)

この辺りのインタフェースは良い感じにできたんじゃないかなーと思ってます。

いったん飛ばした、画像指定時に起点となるパスはミドルウェアmiddleware.lisp)に渡す引数から決まり、<resource-root>/<image-relative-path> になります。先程のサンプルでは <proto-cl-client-side-renderingのルートパス>/sample/resource/img フォルダにしています。

(defun make-client-side-rendering-middleware (&key
                                                resource-root
                                                (image-relarive-path "img/"))
  (ensure-js-files  (merge-pathnames "js/" resource-root))
  (set-image-path resource-root image-relarive-path)
  ...

プロトコル

クライアントに情報を送付するプロトコル層ですが、ここはインタフェース層と大きくは変わりません。

これは protocol.lisp で定義していて、おおむねインタフェース層の load-texture, load-image, draw-image に対応していることが見てとれると思います(frame, index-in-frame は前回記事と同じなので詳細略)。

(defun send-load-texture (frame index-in-frame
                          &key path alpha-path texture-id)
  (send-message :load-texture frame index-in-frame
                `(:path ,path :alpha-path ,alpha-path :texture-id ,texture-id)))

(defun send-load-image (frame index-in-frame
                        &key texture-id image-id uv-x uv-y uv-width uv-height)
  (send-message :load-image frame index-in-frame
                `(:texture-id ,texture-id :image-id ,image-id
                  :uv-x ,uv-x :uv-y ,uv-y :uv-width ,uv-width :uv-height ,uv-height)))

(defun send-draw-image (frame index-in-frame
                        &key id image-id x y depth color width height rotate)
  (send-draw-message :draw-image frame index-in-frame
                     `(:image-id ,image-id :width ,width :height ,height :rotate ,rotate)
                     :id id
                     :x x :y y :depth depth :color color))

これらのプロトコルを抽象化してインタフェースとして提供する層が texture.lisp です。ざっくり次のような役割を持っています。

  • インタフェースの提供
    • load-texture
    • load-image
    • draw-image
  • texture, image それぞれについて、idと名前の対応付け
    • インタフェースとしては名前を利用する
    • プロトコルにはidの方を渡している
  • 適切なタイミングでの上記プロトコルのクライアントへの送信
    • send-load-texture, send-load-image
      • 接続済みのクライアントについては load-texture, load-image が呼ばれたタイミング
      • 後からつないできた新規接続のクライアントについては接続したタイミング
    • send-draw-image
      • (通常の描画命令と同じく)draw-image が呼ばれたタイミング

クライアント層

クライアント層は受け取ったプロトコルに応じて実際に画像をロードし、Three.js に適切にデータを渡して画像の描画を行います。

同じような処理は cl-web-2d-game でも一度書いたことがある...のですが、すっかり忘れていて調べ直したので、この機会に一度メモを残しておきたいところです。というのが今回の記事を書こうと思った大きな要因だったりします。

この辺りの処理は client/texture.lisp に書いています。

まずはデータ構造を整理します。

ゴールとなるデータ構造は THREE.Mesh です。これを、THREE.Scene に追加することで描画ができます。THREE.Mesh のコンストラクタには次の2つを渡します。

  • THREE.Geometry: ジオメトリ = 形状に関する情報
    • vertices: 頂点情報。THREE.Vector3 の配列
      • 今回は四角形にテクスチャを貼り付けるので4頂点必要
    • faces: ポリゴン情報。THREE.Face3 の配列
      • THREE.Face3vertices に登録したどの3頂点で三角形を構成するかを表す
      • 今回は2つの三角形で1つの四角形を表すので2つ必要
    • face-vertex-uvs: テクスチャの貼り方についての情報。THREE.Vector2 の2重配列
      • faces で指定した各頂点にテクスチャのどの部分を割り当てるかを UV 座標で表す
  • THREE.MeshBasicMaterial: マテリアル = 見た目に関する情報
    • map: THREE.Texture ≒ 画像を渡す
    • alpha-map: map に同じく THREE.Texture で、こちらはアルファマップ = 透過情報を示す画像を渡す
      • これを利用する場合は transparent を true にする
    • color: ベースとなる色
      • 画像の色に合成される

次にこのデータ構造と各種プロトコルの関係をみます。

  • :load-texture
    • THREE.TextureLoader により、マテリアルに渡す mapalpha-map をロードする
    • ロード後にテクスチャ情報をテーブルに保存しておく
  • :load-image
    • どの texture にひも付いているかと、ジオメトリに渡すUV座標の情報を保存する
      • load という名前ではあるが実は何もロードしていない
  • :draw-image
    • :load-texture, :load-image それぞれで保存した情報を使って、 実際にジオメトリとマテリアルを生成して THREE.Mesh をつくる

実装については、基本的に上記のプロトコル・構造に基づいて淡々と実装していくだけですが、画像ロード周りはどうしても非同期処理がからむのでそこだけ少々面倒です。

まず、:load-texture の部分です。Promiseを利用して、画像(下記の bitmap-image)とそのアルファマップ(下記のalpha-bitmap-image)をロードを非同期に待ってから、texture の情報(texture-info 構造体;定義略)をテーブルに保存します。

(defun.ps load-texture (&key path alpha-path id)
  (let* ((loader (new (#j.THREE.TextureLoader#)))
         (image-promise
          (make-texture-load-promise loader path))
         (alpha-image-promise
          (make-texture-load-promise loader alpha-path)))
    (chain -promise
           (all (list image-promise alpha-image-promise))
           (then (lambda (images)
                   (push (make-texture-info
                          :id id
                          :bitmap-image (aref images 0)
                          :alpha-bitmap-image (aref images 1))
                         *texture-info-buffer*))))))

(defun.ps make-texture-load-promise (loader path)
  (new (-promise
        (lambda (resolve reject)
          (if path
              (loader.load path
                           (lambda (bitmap-image)
                             (console.log (+ path " has been loaded"))
                             (funcall resolve bitmap-image))
                           (lambda (err)
                             (console.log err)
                             (funcall reject err)))
              (funcall resolve nil))))))

次に、:load-image については特に非同期的な要素はなく、単に image の情報(image-info 構造体;定義略)をテーブルに保存するだけです。

(defun.ps+ register-image (&key id texture-id
                                uv-x uv-y uv-width uv-height)
  (setf (gethash id *image-info-table*)
        (make-image-info :id id
                         :texture-id texture-id
                         :uv-x uv-x
                         :uv-y uv-y
                         :uv-width uv-width
                         :uv-height uv-height)))

最後の :draw-image も非同期的な要素があって少々面倒です。指定された image(にひもづくtexture)がロード済みか(image-loaded-p)で処理を変える必要があります。ロード済みの場合は素直にテクスチャーつきの THREE.Mesh を生成するだけです。ロード済みでない場合、いったん幅と高さを合わせたジオメトリと、単色のマテリアルで THREE.Mesh を生成します。そして、ロードが完了した段階で正式なジオメトリとマテリアルに差し替えます。

(defun.ps make-image-mesh (&key image-id width height color)
  (flet ((make-geometry-and-material ()
           (let ((img-info (find-image-info-by-image-id image-id))
                 (tex-info (find-tex-info-by-image-id image-id)))
             (values
              (with-slots (uv-x uv-y uv-width uv-height) img-info
                (make-image-geometry :width width
                                     :height height
                                     :uv-x uv-x
                                     :uv-y uv-y
                                     :uv-width uv-width
                                     :uv-height uv-height))
              (make-image-material :tex-info tex-info
                                   :color color)))))
    ;; If the image has not been loaded, returns a temoral mesh with
    ;; same width, height, and monochromatic. Then, rewrites by the image
    ;; after loading it.
    (unless (image-loaded-p image-id)
      (let ((result-mesh (new (#j.THREE.Mesh#  ; 仮のMesh
                               (make-image-geometry :width width
                                                    :height height)
                               (new (#j.THREE.MeshBasicMaterial#
                                     (create :color #x888888)))))))
        ;; 補足: register-func-with-pred は cl-ps-ecs
        ;; (https://github.com/eshamster/cl-ps-ecs) で定義している関数で、
        ;; フレーム開始時に第2引数で渡した条件をチェックして、条件を満たしていたら
        ;; 第1引数に渡した処理を実行する
        (register-func-with-pred
         (lambda ()
           ;; 正式なジオメトリとマテリアルに差し替える
           (multiple-value-bind (geometry material)
               (make-geometry-and-material)
             (setf result-mesh.geometry geometry
                   result-mesh.material material)))
         (lambda () (image-loaded-p image-id)))
        (return-from make-image-mesh
          result-mesh)))
    ;; The case where the image has been loaded.
    (multiple-value-bind (geometry material)
        (make-geometry-and-material)
      (new (#j.THREE.Mesh# geometry material)))))

なお、ここで利用している、ジオメトリを生成する make-image-geometry とマテリアルを生成する make-image-material は、前述のデータ構造に従って地道にデータを組み上げるだけです。

(defun.ps make-image-geometry (&key width height
                                    (uv-x 0) (uv-y 0) (uv-width 1) (uv-height 1))
  (let ((geometry (new (#j.THREE.Geometry#))))
    (setf geometry.vertices
          (list (new (#j.THREE.Vector3# 0 0 0))
                (new (#j.THREE.Vector3# width 0 0))
                (new (#j.THREE.Vector3# width height 0))
                (new (#j.THREE.Vector3# 0 height 0))))
    (setf geometry.faces
          (list (new (#j.THREE.Face3# 0 1 2))
                (new (#j.THREE.Face3# 2 3 0))))
    (let ((uv-x+ (+ uv-x uv-width))
          (uv-y+ (+ uv-y uv-height)))
      (setf (aref geometry.face-vertex-uvs 0)
            (list (list (new (#j.THREE.Vector2# uv-x  uv-y ))
                        (new (#j.THREE.Vector2# uv-x+ uv-y ))
                        (new (#j.THREE.Vector2# uv-x+ uv-y+)))
                  (list (new (#j.THREE.Vector2# uv-x+ uv-y+))
                        (new (#j.THREE.Vector2# uv-x  uv-y+))
                        (new (#j.THREE.Vector2# uv-x  uv-y ))))))
    (geometry.compute-face-normals)
    (geometry.compute-vertex-normals)
    (setf geometry.uvs-need-update t)
    geometry))

(defun.ps make-image-material (&key tex-info color)
  (let ((alpha-bitmap (texture-info-alpha-bitmap-image tex-info)))
    (new (#j.THREE.MeshBasicMaterial#
          (create map (texture-info-bitmap-image tex-info)
                  alpha-map alpha-bitmap
                  transparent (if alpha-bitmap true false)
                  color color)))))

おわりに

これは忘れる!