Common Lisp (Parenscript) で GAS を書く
GAS (Google Apps Script) を Common Lisp (Parenscript) で書けるようにしたという話です。テンプレートを作ったのでその使い方やら中身の話やらを簡単に書いていきます。
なお、個人で実際に利用しているものとしては日報メールを生成する下記のリポジトリがあります。1年ぐらい非 Git 管理の純 JavaScript な GAS として利用していたものを、clasp で Git 管理下に置くついでに Common Lisp 化したものです。
使い方
ros template 用のテンプレートを作成したのでその使い方についてです。
なお、ros template 自体について詳細を知りたい場合は過去記事参照です。
インストール
まずはテンプレートを clone & import します。
$ git clone https://github.com/eshamster/template-cl-gas.git
$ cd template-cl-gas/src
$ ros template import
うまく行っていれば ros template checkout コマンドで次のように candiates: に cl-gas テンプレートが見えるはずです。
$ ros template checkout current default is "default" candidates: default. cl-gas
また、依存パッケージの ps-experiment が quicklisp リポジトリに登録されていない *1 のでインストールしておきます（コンソールコマンドがある訳ではないので ql:quickload できるようになれば別の方法でも良いです）。
$ ros install eshamster/ps-experiment
npm 側の準備としては @google/clasp をインストールしてログインしておくだけです。ちなみに、リモートサーバ上で開発しているような場合は clasp login --no-localhost でログインすると良いようです（参考）。
$ npm i @google/clasp -g
$ clasp login
プロジェクト作成
プロジェクト作成は次のようにします
ql:quickloadが認識できる場所に空のフォルダを作成します$ cd ~/.roswell/local-projects $ mkdir sample-cl-gasclasp createでプロジェクトを初期化します$ cd ~/.roswell/local-projects/sample-cl-gas $ clasp create sample-cl-gas --type standalone $ find . . ./.clasp.json ./appsscript.jsonros init cl-gasでcl-gasテンプレートからプロジェクトを作成します$ cd ~/.roswell/local-projects/sample-cl-gas $ ros init cl-gas sample-cl-gas \ --license LLGPL \ --description "This is a sample using template-cl-gas." $ find . . ./.clasp.json ./appsscript.json ./.gitignore ./.claspignore ./.clasp.json.in ./src ./src/main.lisp ./src/compile.lisp ./main.lisp ./compile.ros ./sample-cl-gas.asd ./README.markdown ./Makefile
トラブルシューティング
ros init 時に cl-gas テンプレートがうまく適用されずに cl-gas.ros が生成されて終わってしまう場合があります。
$ ros init cl-gas sample-cl-gas \
--license LLGPL \
--description "This is a sample using template-cl-gas."
Successfully generated: cl-gas.ros
$ ls
.
./.clasp.json
./appsscript.json
./cl-gas.ros # ← これができただけ
原因解明に至っていないですが、回避方法は以下を実行することです。これで、次に ros init を実行した際にリコンパイルが走ってひとまずテンプレートが正常に適用されるようになります。
touch /usr/local/etc/roswell/init.ros
気が向いたらきちんと調査して解決なり issue 化なりしたいですが、何しろ上記の通りリコンパイルが走った段階で直ってしまうので printf デバッグすら簡単でなく中々辛い...。
アップロード・編集
ここまでの準備をした段階で取りあえず動くものができています。 make push-new で main.js の生成と GAS へのアップロードを行います。
$ make push-new
GAS の画面から実行してみると、ログに "Hello GAS on Lisp" が表示されるはずです。
以降、ファイルを変更した場合は同様に make push-new することで反映できます。
さて、ファイルを編集する場合ですが、先程の "Hello GAS on Lisp" を出力するコードに対応するのが src/main.lisp です。
(defpackage sample-cl-gas/src/main (:use :cl :ps-experiment :parenscript) (:export :main)) (in-package :sample-cl-gas/src/main) (defun.ps main () (-logger.log "Hello GAS on Lisp"))
通常の Common Lisp 開発に近いサイクルで開発できることのデモとして、 src/hoge.lisp ファイル追加してみます。
(defpackage sample-cl-gas/src/hoge (:use :cl :ps-experiment :parenscript) (:export :hoge)) (in-package :sample-cl-gas/src/hoge) (defun.ps hoge () (-logger.log "Hello hoge on Lisp"))
そして、src/main.lisp を以下のように編集します。 :export や :import-from が通常の作法で行えることが分かるかと思います。出力される JavasScript 上でも Common Lisp のパッケージ・シンボルシステムに従った名前空間の分割をしているので、別パッケージとの名前衝突も気にする必要はありません。
(defpackage sample-cl-gas/src/main (:use :cl :ps-experiment :parenscript) (:export :main) (:import-from :sample-cl-gas/src/hoge :hoge)) (in-package :sample-cl-gas/src/main) (defun.ps+ main () (hoge))
これを make push-new して改めて実行することで、ログに "Hello hoge on Lisp" が表示されます。
付録：Parenscript + ps-experiment 上での開発概略
Parenscript + ps-experiment の開発サイクルを記事にしたことがない気がするので簡単に書くと、下記ぐらいを注意しておけば結構 Common Lisp ライクに書けるのではないでしょうか*2。先程見たようにパッケージ分割も Common Lisp の作法に則っています。
clに加えてparenscript,ps-experimentを:useするdefXXXの代わりにdefXXX.psまたはdefXXX.ps+を利用する- 用意があるのは
defvar,defparameter,defun,defmacro,defgeneric,defmethod,defstructです .psと.ps+の違いは、前者が JavaScript 用の定義のみを行うのに対し、後者は加えて同等の Common Lisp コードも定義する点です- Common Lisp コンパイラのエラー・警告という恩恵を得られるので可能な限り
.ps+を利用するのが良いです defun.ps,defgeneric.ps,defmethod.psについては空の Common Lisp コードも生成するので、 それらで定義したものを.ps+系から利用してもコンパイルエラーにはなりません（実行時エラーになります）
- Common Lisp コンパイラのエラー・警告という恩恵を得られるので可能な限り
- 用意があるのは
他、どうしても JavaScript との差異を意識しないといけない場面はあります。目立つものは下記でしょうか。
- 「ハイフン+文字」が大文字と解釈される。例:
ps-experiment→psExperiment（Parenscript の仕様）- JavaScript 側で定義されたものを呼び出す際に意識が必要な点になります
- 大文字が連続するようなケースで煩わしい場合は
(enable-ps-experiment-syntax)を利用すると#j.psExperiment#のように書けます
- 空リストと
nil(JavaScript上のnull) は同一ではない- Common Lisp 上のリストの初期化は良く
nilで行いますが(list)のようにする必要があります
- Common Lisp 上のリストの初期化は良く
- 0 が false 扱い
defvar.psなどで定義した変数はコピーが export される- そのため値の変更が反映されないという罠があります（気づかないとデバッグに結構手間がかかる...）
- 特にマクロ内で展開される変数でやりがちです
- パッケージ外に露出するものについては getter, setter を用意するのが無難です
- そのため値の変更が反映されないという罠があります（気づかないとデバッグに結構手間がかかる...）
- Parenscript 上で用意されていない Common Lisp 関数は結構ある
- ps-experiment/ps-macros-for-compatibility でマクロとして補っているものもありますが、気まぐれで追加しているので網羅性は全くないです...
実現方法
実現方法について1ファイルの Roswell スクリプトで行う方法を見てみます。テンプレートとして提供しているものは、適宜分割をしたり asd ファイルを追加してプロジェクト化したりと整えただけで、ベースの実現方法は1ファイルの場合と変わりません。
まずは少しダメな例です。
#!/bin/sh #|-*- mode:lisp -*-|# #| exec ros -Q -- $0 "$@" |# (progn ;;init forms (ros:ensure-asdf) #+quicklisp(ql:quickload '(:parenscript :ps-experiment :split-sequence) :silent t) ) (defpackage :ros.script.test.3797433527 (:use :cl :parenscript :ps-experiment)) (in-package :ros.script.test.3797433527) (defun.ps test () (-logger.log "Hello GAS on Lisp")) (defun main (&rest argv) (declare (ignorable argv)) (with-open-file (out "main.js" :direction :output :if-exists :supersede :if-does-not-exist :create) (princ (with-use-ps-pack (:this) (test)) out)))
with-use-ps-pack はパッケージ間の依存性を見つつ、export, import も適宜行いつつ JavaScript コードを文字列として出力する ps-experiment のマクロです*3。ちなみに、この辺りの細かい（細か過ぎる）話は過去に記事にしています。
さて、その with-use-ps-pack の出力を素直に princ している訳ですが何がダメかというと...
var psExperiment_defines_defmethod = (function() { /* ※ defgeneric, defmethod 実現のためのコード群なので略 */ })(); var ros_script_test_3797433527 = (function() { /* --- import symbols --- */ /* --- define objects --- */ function test() { __PS_MV_REG = []; return Logger.log('Hello GAS on Lisp'); }; function __psMainFunc__() { __PS_MV_REG = []; return test(); }; /* --- extern symbols --- */ return { '_internal': { 'test': test, '__psMainFunc__': __psMainFunc__, } }; })(); ros_script_test_3797433527._internal.__psMainFunc__();
with-use-ps-pack 内に書いた処理は __psMainFunc__ 関数として出力していますが、末尾でこれをそのまま実行してしまっています。GAS としてはこの __psMainFunc__ 関数を実行する関数が欲しいところです。
ということで、Roswell スクリプトの main 関数を下記のように変更します。
(defun main (&rest argv) (declare (ignorable argv)) (let* ((str (with-use-ps-pack (:this) (test))) (splitted (split-sequence:split-sequence #\Newline str))) (with-open-file (out "main.js" :direction :output :if-exists :supersede :if-does-not-exist :create) (format out "~{~A~%~} function main() { ~A }" (butlast splitted) (car (last splitted))))))
...末尾の一行を切り取って function main() { } で囲うという見るからに汚いことをしています。本来は with-use-ps-pack に適切なオプションをつけてどうにかできるようにすべきですが、そこまでのモチベーションが湧いていないのでひとまずこんなもので...。そんな訳で次のように無事に GAS に上げて動かせるコードが出力されました。
var psExperiment_defines_defmethod = (function() { /* ※ defgeneric, defmethod 実現のためのコード群なので略 */ })(); var ros_script_test_3797433527 = (function() { /* --- import symbols --- */ /* --- define objects --- */ function test() { __PS_MV_REG = []; return Logger.log('Hello GAS on Lisp'); }; function __psMainFunc__() { __PS_MV_REG = []; return test(); }; /* --- extern symbols --- */ return { '_internal': { 'test': test, '__psMainFunc__': __psMainFunc__, } }; })(); /* ※ここまでは上記の出力と同じ */ function main() { ros_script_test_3797433527._internal.__psMainFunc__(); }
完全に余談ですが、省略している defgeneric, defmethod の（サブセットの）実装の話は下記で記事にしています。
*1:登録したいなという気持ちはありつつ、冴えた名前が思いつかないのでそのままになっています...
*2:Common Lisp ライクに書くための皮を Parenscript に被せるのが ps-experiment の主要な役割でもあります
*3:第1引数で依存解決の起点となるパッケージ群をキーワードで指定します。ただ、依存解決を入れた時点で自身のパッケージを示すエイリアスである :this 以外を指定することがなくなってしまったので、何かオプションを追加したくなったらこちらは obsolete して別のマクロを用意しようかなという気持ちではいます
【Common Lisp】cl-base + rove + GitHub Actions でテストする
以前「cl-base + rove + Travis CI でテストする」という記事を書きましたが、その s/Travis CI/GitHub Actions/ 版です。
下記が作成したアクションのリポジトリです。
使い方
ひとまず使い方です。次の条件に合致する場合、プロジェクトに下記のような内容の .github/workflows/xxx.yml (xxx は任意) を配置するだけです。
- Docker コンテナ: eshamster/cl-base
- テストライブラリ: fukamachi/rove
- Common Lisp 処理系
- SBCL
- Clozure CL
on: [push] jobs: test: runs-on: ubuntu-latest strategy: matrix: lisp: [sbcl-bin, ccl-bin] name: A job to test Common Lisp project steps: - name: Checkout uses: actions/checkout@v2 - name: Test step id: test uses: eshamster/try-cl-test-on-gh-actions@v0.3.1 with: # 利用する処理系: 今のところ sbcl-bin or ccl-bin lisp: '${{ matrix.lisp }}' # [optional] テスト前に ros install したいものがあればカンマ区切りで指定する installTargets: 'eshamster/ps-experiment,eshamster/cl-ps-ecs'
テスト環境の /github/workspace にテスト対象のコードがあることを前提にしているので、先に actions/checkout アクションでリポジトリをチェックアウトします。
ちなみに、リポジトリ内でも動作確認していますが、（GitHub Actions 初触りなため）他プロジェクトから使えるのか不安だったので、次のリポジトリでお試し利用しています。
中身
アクションのリポジトリを再掲します。
このうち、アクションに関係するのは以下の4ファイルです。
├── action.yml
└── test-docker
├── Dockerfile
└── test.sh
Travis CI 版と比べると、docker run 部分を GitHub Actions 側でやってくれるので、test-docker/run.sh にあたるファイルがありません。
action.yml
アクション定義の本体です。
name: 'Test Common Lisp' description: 'Run test of Common Lisp project using rove on Docker' inputs: lisp: description: 'Name of Common Lisp implementation' required: true default: 'sbcl-bin' installTargets: description: 'Comma separated installation targets that can be installed by "ros install"' required: false runs: using: 'docker' image: 'test-docker/Dockerfile' args: - ${{ inputs.lisp }} - ${{ inputs.installTargets }}
特筆するところもないですが、runs.using で docker を指定することで、テストを Docker コンテナ上で走らせることを指示しています。
このアクションでは2つの引数（inputs）を取ります。
lisp: 利用する処理系の指定で今のところ下記のいずれかsbcl-binccl-bin
installTargets: [optional] テスト前に ros install したいものがあればカンマ区切りで指定する ((処理系をros useする手前でros installを実行しているので別の処理系の追加も可能ではあります。とはいえ、テスト実行のたびにインストールすることになるので Dockerfile 側を修正して追加するのが正道ですね))- 例.
'eshamster/ps-experiment,eshamster/cl-ps-ecs'
- 例.
test-docker/Dockerfile
テスト実行環境を定義する Dockerfile です。
FROM eshamster/cl-base:2.4.2
ADD ./test.sh /root
RUN ros install ccl-bin && \
ros install rove
ENTRYPOINT ["/root/test.sh"]
Travis CI 版と比べると CMD -> ENTRYPOINT になったぐらいであとは見ての通りです。Common Lisp 処理系は（デフォルトの sbcl-bin に加えて）ccl-bin を入れています。他の処理系を入れる場合はここに追加するのが良さそうです。
test-docker/test.sh
ENTRYPOINT としてコンテナ内部で起動されるスクリプトです。
#!/bin/sh set -eux lisp=$1 install_targets="${2:-}" if [ "${install_targets}" != "" ]; then echo "${install_targets}" | tr ',' '\n'| while read target; do ros install ${target} done ros -e '(ql:register-local-projects)' -q fi ros use ${lisp} # Note: Assume that repository is checkout to workspace folder in previous step dir=/root/.roswell/local-projects/target cp -R /github/workspace ${dir} # (*1) cd ${dir} rove *.asd 2>&1 | tee /tmp/test.log # Note: In Clozure CL, terminating debug console finishes in errcode 0, # so grep message to check if the test has actually run. grep "tests? passed" /tmp/test.log # (*2)
2つの引数を取ります。
- 第1引数: 利用する Common Lisp 実装
- 第2引数: 追加で
ros installするもの
下記のような微妙なハックがあります。
- (*1): 最初
ln -sでシンボリックリンクを作ろうとしていたのですが、Clozure CL ではうまく認識（ql:quickload）できなかったっため、コピーを作成しています - (*2): システムが見つからなかったなどでデバッガに入った場合即座に死んでくれる...のは良いのですが、Clozure CL ではエラーコード 0 で終了してテスト成功扱いになってしまったので、テストログを grep してテスト成功を示すメッセージがあるかを確認しています
- 追記：複数のテストが走る場合メッセージが
test passedではなくtest"s" passedになることに気付いたので v0.3.1 で修正
- 追記：複数のテストが走る場合メッセージが
参考にしたもの
今回のものをつくる上では、公式のドキュメントを見れば事足りる感じでした。基本的には「Docker コンテナのアクションを作成する」に沿っていけば良かった感じです。
設定の細かい部分に関しては適宜下記を参照しました。
- GitHub Actionsのメタデータ構文
action.ymlについてのリファレンス
- GitHub Actionsのワークフロー構文
.github/workflows/xxx.ymlについてのリファレンス
【Common Lisp】Go言語の goroutine っぽいものを作ってみたかった話
Lisp Advent Calendar 2019 23日目の記事です。
近頃仕事で書いている Go 言語の勉強も兼ねて「Go言語による並行処理」という本を買ったので Lisp を書いていくぞという内容です。goroutine っぽい cloutine なるものを Common Lisp 上で作ってみようという試みです。
できたもの（と制限）
- 隠蔽された複数の実スレッドにいわゆる Green Thread（cloutine と命名）を投げ込んで並行処理を実現する
- 非同期なチャネル
というようにできたのは一部分だけです。また、できたものについても下記の制限があります。
- 色々実用に耐えない
- SBCL 上ではさらに実用的に耐えない
- チャネルについてはかろうじて単独で動作するだけで 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で取得できない場合、他のキューを順に調べて関数を見つけ次第それを実行する
したがって、cloutine を生成する clt マクロの基本的な内容は、渡された処理を lambda で包んで関数化し、上記のキューに詰め込むだけです。基本的には各スレッドは自身のキューに関数を詰めて自身で実行するのですが、「他のキューを順に調べて関数を見つけ次第それを実行する」の動作があるため、空いているスレッドは人のキュー内の関数を盗んで実行することができます。
非同期なチャネル
上記の通り、cloutine の基本的な動作だけであればそれほど面倒なところはない *3 のですが、非同期なチャネルの実装が割と厄介です。「技術要素」の項で述べた限定継続ライブラリ cl-cont と、Promise ライブラリ Blackbird はいずれもここで出てきます。
分かり易く説明できる気がしないのですが、非同期な待ちは次のように実現します（※待ちが発生しない限りはほぼ単なるスレッドセーフなキュー）。以下は取り出し待ちの例ですが、チャネルのサイズを制限した場合の投入待ちの処理もおおむね同じになります。
- チャネル操作以降の処理を「継続」= 特定の形式の関数として取り出す（cl-cont）
- Promise を作成し、解決するための関数をチャネルに保管する（Blackbird）
- 2 で作成した Promise に、解決時の処理として 1 の継続を実行する処理を登録する
- チャネルに値を投入する際に 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 は次のように動作する
パッケージ定義を見ると、上記に必要な部品であるキュー・ロック・セマフォを 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で取得できない場合、他のキューを順に調べて関数を見つけ次第それを実行する
上記を実現するため、先程の 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/cc で defun を囲ったものが 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-promise の resolve（と reject）は macrolet として定義されているため、そのまま外に渡すことはできません。こうした用途のためにはキーワード引数の resolve-fn（reject-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-lengthが nil の場合は利用されない
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 を作ってみた話です。
前置き
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)
まずは所望の数のスレッドを立ち上げます（rts は repl-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 から各スレッドのキューに関数を投げ込むことで、任意の処理を後付けで実行できます。
ということで、次のような順序で作っていきます。
queue: ただのキュー（スレッドアンセーフ）wait-queue: スレッドセーフなキューrepl-thread: 2 を利用して前述の動作をするスレッド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 は次のような動作をします。
- 渡されたロックを解放する
- 渡された Condition variable にシグナルが来るまで待つ
- シグナルが来たらロックを取得して次に進む
(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 は単にシグナルを送るだけです。
- 渡されたロックを解放する
- 渡された Condition variable にシグナルが来るまで待つ
- シグナルが来たらロックを取得して次に進む
試してみます。
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 ; ← 待たされたものが動いた
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箇所ほど手を入れれば動くはずです。
中身
本題は下記の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
envのmatrixで対象の処理系を指定します- 処理系の足し引きで要書き換えな箇所その1
before_installはtest-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へのプロジェクト設置
- お膳立て1:
- ここで
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 には次のような特徴があります。
- 複数の
deferがある場合、通ったのとは逆順で実行される - 実行時に通った
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 Lambda の defmacro! マクロの実装やインタフェースを多いに参考にしています*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 の面白いところですね。
【小ネタ】 簡易な関数定義マクロ, マクロ定義マクロを自作してみる
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 を束縛してあげればできそうな気はします...が、試していません