Scheme-users.jp今回は、KMRCLのos.lispから DELETE-DIRECTORY-AND-FILES です。
Allegro CLだと同名の関数があり、処理系にディレクトリを削除する機能があるようですが、他の処理系の場合はKL:COMMAND-OUTPUTを使って、rm -rfするようです。
定義は、
(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force)
#+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist
:quiet quiet :force force)
#-(or allegro) (declare (ignore force))
#-(or allegro) (cond
((probe-directory dir)
(let ((cmd (format nil "rm -rf ~A" (namestring dir))))
(unless quiet
(format *trace-output* ";; ~A" cmd))
(command-output cmd)))
((eq if-does-not-exist :error)
(error "Directory ~A does not exist [delete-directory-and-files]." dir))))
となっています。
動作は、
(KL:DELETE-DIRECTORY-AND-FILES "/tmp/bar")
;⇒ ""
""
0
;; 権限不足で削除できなかった場合
;⇒ ""
"rm: ディレクトリ`/tmp/bar/baz/quux'を削除できません: Permission denied
"
1
というところ
■
今回は、KMRCLのos.lispからRUN-SHELL-COMMANDです。
前回のCOMMAND-OUTPUTは出力を取得できましたが、今回のRUN-SHELL-COMMANDは外部のコマンドを実行するのに特化しています。
動作は、
(LET ((FILE "/usr/share/dict/words")
(OUT-FILE "/tmp/bar"))
(WITH-OPEN-FILE (IN FILE)
(ALEXANDRIA:WITH-OUTPUT-TO-FILE (OUT OUT-FILE)
(LOOP :FOR LINE := (READ-LINE IN NIL) :WHILE LINE
:DO (WRITE-LINE (STRING-UPCASE LINE) OUT))))
(KL:RUN-SHELL-COMMAND "firefox ~A" OUT-FILE))
のようなところでしょうか。
定義は、下記のようになっていますが、処理系依存の切り分けが中身の殆どです。
(defun run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell,
returns (VALUES output-string pid)"
(let ((command (apply #'format nil control-string args)))
#+sbcl
(sb-impl::process-exit-code
(sb-ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output nil))
#+(or cmu scl)
(ext:process-exit-code
(ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output nil))
#+allegro
(excl:run-shell-command command :input nil :output nil
:wait t)
#+lispworks
(system:call-system-showing-output
command
:shell-type "/bin/sh"
:show-cmd nil
:prefix ""
:output-stream nil)
#+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
#+openmcl
(nth-value 1
(ccl:external-process-status
(ccl:run-program "/bin/sh" (list "-c" command)
:input nil :output nil
:wait t)))
#-(or openmcl clisp lispworks allegro scl cmu sbcl)
(error "RUN-SHELL-PROGRAM not implemented for this Lisp")
))
■
今回は、KMRCLのos.lispからCOMMAND-OUTPUTです。
外部のシェルでコマンドを実行したり外部コマンドの出力を取得したりしたくなることは多いと思うのですが、ANSI CLではその辺りのことは決められていませんので、実装依存になります。
しかし、大抵の実装では、外部シェルとやりとりをする一連の関数が提供されています。
COMMAND-OUTPUTはそういうコマンドを処理系に依存しないようにラッピングするものです。
動作は、
(KL:COMMAND-OUTPUT "ls -l /etc/hosts")
;⇒ "-rw-r--r--. 1 root root 1055 2010-07-24 16:51 /etc/hosts
"
""
0
で、
- コマンド出力の文字列
- エラー
- コマンドの終了コード
と3つの値を返すようになっていて、大体の処理系は、上記3つを取得できる関数を持っているようです。
定義は、処理系ごとに色々違うので長くなっていますが、下記のようになっています。
(defun command-output (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell,
returns (VALUES string-output error-output exit-status)"
(let ((command (apply #'format nil control-string args)))
#+sbcl
(let* ((process (sb-ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output :stream :error :stream))
(output (read-stream-to-string (sb-impl::process-output process)))
(error (read-stream-to-string (sb-impl::process-error process))))
(close (sb-impl::process-output process))
(close (sb-impl::process-error process))
(values
output
error
(sb-impl::process-exit-code process)))
#+(or cmu scl)
(let* ((process (ext:run-program
"/bin/sh"
(list "-c" command)
:input nil :output :stream :error :stream))
(output (read-stream-to-string (ext::process-output process)))
(error (read-stream-to-string (ext::process-error process))))
(close (ext::process-output process))
(close (ext::process-error process))
(values
output
error
(ext::process-exit-code process)))
#+allegro
(multiple-value-bind (output error status)
(excl.osi:command-output command :whole t)
(values output error status))
#+lispworks
;; BUG: Lispworks combines output and error streams
(let ((output (make-string-output-stream)))
(unwind-protect
(let ((status
(system:call-system-showing-output
command
:prefix ""
:show-cmd nil
:output-stream output)))
(values (get-output-stream-string output) nil status))
(close output)))
#+clisp
;; BUG: CLisp doesn't allow output to user-specified stream
(values
nil
nil
(ext:run-shell-command command :output :terminal :wait t))
#+openmcl
(let* ((process (ccl:run-program
"/bin/sh"
(list "-c" command)
:input nil :output :stream :error :stream
:wait t))
(output (read-stream-to-string (ccl::external-process-output-stream process)))
(error (read-stream-to-string (ccl::external-process-error-stream process))))
(close (ccl::external-process-output-stream process))
(close (ccl::external-process-error-stream process))
(values output
error
(nth-value 1 (ccl::external-process-status process))))
#-(or openmcl clisp lispworks allegro scl cmu sbcl)
(error "COMMAND-OUTPUT not implemented for this Lisp")
))
■
今回のABCLは、JVM上で動くCL処理系ではなくて、LISPベースの並列オブジェクト指向言語の方です。
今日、deliciousから流れてくるLISP関係のものを眺めていて、
というのをみつけました。
中に配布されているソースが書かれているのですが、もしかしてと思って、上のディレクトリを覗いてみると、abcl/1や、abcl/r2のソースがありました!
abcl/fはソースが配布されているのを見たことがあったのですが、abcl/1やabcl/rは配布されていることを知りませんでした。
物は試しということで、早速、ビルドに挑戦。
Makefileもあるのですが、手直ししないと動かないようなので、ターゲットの一つであるKCLの直系のGCLを起動して、処理系からビルド用のファイルを読み込むことにしてみました。
といっても非常に簡単です。(環境は、Ubuntu 10.4 x86_64で試しました。)
abcl/r2の場合
$ mkdir abclr2
$ cd abclr2
$ wget http://venus.is.s.u-tokyo.ac.jp/pub/abclr2/abclr2-dist.tar.Z
$ gzcat abclr2-dist.tar.Z|tar xvf -
$ gcl
GCL (GNU Common Lisp) 2.6.7 CLtL1 Feb 15 2010 17:57:54
Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl)
Binary License: GPL due to GPL'ed components: (XGCL READLINE BFD UNEXEC)
Modifications of this banner must retain notice of a compatible license
Dedicated to the memory of W. Schelter
Use (help) to get some basic information on how to use GCL.
Temporary directory for compiler files set to /tmp/
>(push :kcl *features*) ;KCLということにする
(:KCL :COMPILER :NUMLIB :SDEBUG :DEFPACKAGE :GNU-LD :XGCL :UNEXEC :BFD
:NATIVE-RELOC :READLINE :TRUNCATE_USE_C :CLX-LITTLE-ENDIAN :BSD
:GNU :LINUX :X86_64 :SGC :IEEE-FLOATING-POINT :UNIX :GMP :GCL
:AKCL :COMMON :KCL)
(load "defabclr2.lsp")
Loading defabclr2.lsp
Loading defsystem.lsp
Finished loading defsystem.lsp
Finished loading defabclr2.lsp
T
>(build-and-dump) ;ビルドして実行可能ファイルを作成
Loading /home/mc/Desktop/abcl/abclr2/src/abclr2.system...
...
とすると、saved_abclr2というものができます。
これを実行すると
$ ./saved_abclr2 Welcome to ABCL/R2 Gesi version (Jul. 7, 1995, 0.59) ABCL/R2>[[object (script (=> [:hello] !(print "Hello, World!")))] <== [:hello]] "Hello, World!" "Hello, World!" ABCL/R2>
abcl/r2が起動できます。
abcl/1のビルド
abcl/1もabcl/r2と同じようにできますが、途中でちょっとひっかかるので、そこは飛します。
>(push :kcl *features*)
(:KCL :COMPILER :NUMLIB :SDEBUG :DEFPACKAGE :GNU-LD :XGCL :UNEXEC :BFD
:NATIVE-RELOC :READLINE :TRUNCATE_USE_C :CLX-LITTLE-ENDIAN :BSD
:GNU :LINUX :X86_64 :SGC :IEEE-FLOATING-POINT :UNIX :GMP :GCL
:AKCL :COMMON :KCL)
>(load "init-abcl")
Loading init-abcl.lsp
ABCL-USER>> (load "maksys")
Loading maksys.lsp
Finished loading maksys.lsp
t
ABCL-USER>> (load "defabcl")
Loading defabcl.lsp
Finished loading defabcl.lsp
t
ABCL-USER>> (maksys 'abcl1)
Loading file declare.o...... start address -T 0x10bbfe0 done.
ABCL-USER>> (abcl::enable-debug)
ABCL-USER>> (abcl::gbc-message-on)
ABCL-USER>> ; (si:catch-bad-signals);飛ばす
ABCL-USER>> (setq si:*indent-formatted-output* nil)
ABCL-USER>> (defun system:top-level nil (abcl::abcl-top-level))
ABCL-USER>> (if abcl::*distribution* (setq si::*break-enable* nil))
ABCL-USER>> (gbc t)
ABCL-USER>> (si:save-system "saved_abcl1")
まだ、マニュアルをちょっと眺めただけですが、abcl面白そうです!
■
まず安定版の gmp-4.3.2 を入手。次に Mona のビルド環境に近いパラメータでクロスコンパイルしてみる。
% ./configure --enable-assert=yes --enable-cxx=no --build=i586 --host=i586-mingw32msvc
トップディレクトリにある .c ファイルのビルド assert.c のビルド例から CFLAGS を見る。
-std=gnu99 -DHAVE_CONFIG_H -I. -I. -I. -D__GMP_WITHIN_GMP -m32 -O2 -pedantic -fomit-frame-pointe
というわけで上のフラグをつけて *.c をビルドしてみると invalid.c で SIG_FPE がどうのこうの言われるので Mona 用にエラー処理を書き換える。
mpn ディレクトリの *.asm なファイルは m4 で更新されてからビルドされるようだ、これらもそのままパクって使う。add の定義で sub も生成するみたいな事をやっているっぽい。
関係ないけど mpn ディレクトリはアーキテクチャ毎にシンボリックリンクでファイルが置き換わって面白い。同じ演算でもアーキテクチャ依存 *.asm 版と generic/*.c 版がある。
そんなこんなでビルドが通った。算術演算ライブラリなだけあって貧弱なライブラリしか持たないマイナ OS でもビルドできる。Mosh に組み込んでテストしていたところ一部のテストが合わない。config.h で #define WANT_TMP_ALLOCA 1 としていたのが。#define alloca __builtin_alloca してて悪さしていたので WANT_TMP_REENTRANT にして回避した。
結局ソースコード自体への変更はこれだけ。後は独自に config.h や Makefile をつっこんだ。
% unzip http://incanter.org/downloads/incanter-latest.zipとか
% tar zxvf http://prdownloads.sourceforge.net/gauche/Gauche-0.9.tgzとか書いたらダウンロードから解凍まで面倒みてくれないかな…そろそろURLをファイル名と同等に扱えてもいい頃だよねと。
シェルがやってくれればいいんですが、何かいいやつ知りませんか？
手元でさっと書いてみたのは、例えば $HOME/bin あたりを環境変数PATHで最初に読まれるようにしといて、そこに みたいなスクリプトを unzip とか tar という名前で仕込んでみたりとか。（chmod +x しておく必要があります）
【C.M.ビショップ「パターン認識と機械学習(PRML)」読書会の情報はこちら】
（とりあえずハブエントリ）
PRML(パターン認識と機械学習) Hackathon #2 を開催しました。参加者8名。
幹事の都合で集まりにくい日になってしまって申し訳ありません。
公式タグはPRMLhackathon。
Incanterは、Clojureベースの、統計計算とグラフィックスのためのR言語風プラットフォーム、であります
- PRML hackathon#2でProcessingを使ったビジュアライズに挑戦しようとしていて
- Processing使うならClojureかなと思ってClojureにも挑戦しようとしていて
- Chaton Clojureに行ったらmaking(※まきんぐ)さんにIncanterを勧められた、であります
- ClojureもProcessingもユーザ歴１日目ですが… やってみます
- これで勝つる！
shiroさんに教わったのでメモっておきます
;;; from shiro
(defun gauche-info-index (topic)
(interactive
(list (read-string
(concat "Gauche help topic : ")
(current-word))))
(switch-to-buffer-other-window (get-buffer-create "*info*"))
(info "/usr/share/info/gauche-refe.info.gz")
;;(info "/usr/local/share/info/gauche-refe.info.gz") ;;うちは/usr/local/
(Info-index topic))
;;(define-key global-map "\C-xH" 'gauche-info-index) ;; original
(define-key global-map "\C-x\C-j" 'gauche-info-index) ;; naoya_t
キーバインドは C-x H だとシフト押すのが面倒なので、うちでは C-x C-j に移しました。（キーバインドは皆さんのお好みで！）
調べたい関数名の後でC-x C-jするとinfoが引けます。これは便利。
去年ちょっとだけ参加したTLE (Time Limit Exceeded)に今年は最初から参加。とは言っても仕事の合間にちょこちょこと。
- PALIN1 (Super Palindrome - 1; 問題文): 58.7356 / 100
// n^n%p。要128bit演算 - PALIN2 (Super Palindrome - 2; 問題文): 111.6 / 150
// これは簡易版 - PREP (The Preprocessor Problem; 問題文): 5.6684 / 100
// これは浜地さんの出題だそうです。
// cpp（プリプロセッサ）でfizzbuzz。あとでじっくり考えたい - CARM (Carmichael Numbers; 問題文): 3.2305 / 100
// 自作Bignumが遅くてTLE（文字通りの）との闘い - COMP (Compress the Text/Image; 問題文): 76.973 / 100
// tsubosakaさんさすがと思った - SHORTEN (Play with Code; 問題文): 18.2888 / 100
// コードちゃんと読んでないので時間あればもっと取れたはず - KEY (Key to C; 問題文): 69.4118 / 100
// 問題の意味がわからず悩んだ - CQUINE (Chain Quine!; 問題文): 94.2466 / 200
// quineが書けただけで満足っす
（追記：恥ずかしいコードへのリンクを貼りました）
とりあえず通るコードを考えてsubmit x 8で最速全問通過（別にボーナスは無い）。しかしその後の詰めの能力は低いので順位は上がらず。瞬間最高順位は2位。
最終結果は438.1527点で19位。別枠でランキングのあるインド人トップより辛うじて上だけどそんなの関係ない。これはインドを舞台にした日本人同士の闘い。
パズル的にはとても面白かったけれどやはりゴルフ力が全然ないので、渋谷から10分のゴルフ場で鍛えるなどしたいです。
おまけ：副次的効果
gistに貼ってるだけだと忘れそうなのでここにもメモっとく。
「プログラミングErlang」の§12.2 に、ErlangからCの関数を利用する方法があるので、同等なインターフェイスを書けば
(define (twice x) (* 2 x)) (define (sum x y) (+ x y))
のようなScheme(Gauche)の関数も呼び出せる。
Eshell V5.7.4 (abort with ^G)
1> c(example1).
{ok,example1}
2> example1:start().
<0.39.0>
3> example1:twice(48).
96
4> example1:sum(17,25).
42
...
Interpolative coding - tsubosakaの日記 より。
長さと出てくる値の最小値、最大値が分かっている狭義単調増加な自然数のリストを圧縮する方法の話。
最小値1、最大値20、長さ７の数列 [ 3, 8, 9, 11, 12, 13, 17 ] が17ビットに圧縮されるらしい。試してみたい。
まずはC++に翻訳しつつ写経。（Scheme編はこちら）
Schemeでも写経してみたの巻。C++編はこちら。
#;'(べ、べつにS式で書かないと理解できないわけじゃないんだからね)
(define (lg x) (integer-length (- x 1)))
(define (interpolative-encode L L-length lo hi)
(define (binary-encode x low high result)
(let* ([range (+ (- high low) 1)]
[bnum (lg range)]
[enc (- x low)])
(let loop ((i (- bnum 1)) (result result))
(if (< i 0) result
(loop (- i 1) (cons (if (logbit? i enc) 1 0) result))))))
(define (iter f lo hi left right result)
(cond [(= f 0) result]
[(= f 1) (binary-encode (vector-ref L left) lo hi result)]
[else
(let* ([h (quotient f 2)]
[m (vector-ref L (+ left h))]
[f1 h]
[f2 (- f h 1)])
(iter f2 (+ m 1) hi (+ left h 1) right
(iter f1 lo (- m 1) left (+ left h)
(binary-encode m (+ lo f1) (- hi f2) result))))]))
(let1 L-length (vector-length L)
(reverse! (iter L-length lo hi 0 L-length '())))
(define (interpolative-decode L L-length lo hi input-stream)
(define (binary-decode low high iter)
(let* ([range (+ (- high low) 1)]
[bnum (lg range)])
(let loop ((i 0) (dec 0) (iter iter))
(if (= i bnum)
(values (+ low dec) iter)
(let1 b (car iter)
(loop (+ i 1) (+ (* dec 2) (car iter)) (cdr iter)))))))
(define (iter f lo hi left right input-stream)
(cond [(= f 0) input-stream]
[(= f 1)
(receive (m stream) (binary-decode lo hi input-stream)
(vector-set! L left m)
stream)]
[else
(let* ([h (quotient f 2)]
[f1 h]
[f2 (- f h 1)])
(receive (m stream) (binary-decode (+ lo f1) (- hi f2) input-stream)
(vector-set! L (+ left h) m)
(iter f2 (+ m 1) hi (+ left h 1) right
(iter f1 lo (- m 1) left (+ left h) stream))))]))
(iter L-length lo hi 0 L-length input-stream))
(define (main args)
(let* ([L #(3 8 9 11 12 13 17)]
[lo 1]
[hi 20]
[L-length (vector-length L)]
[Ldec (make-vector L-length)]) ; 結果格納用vec
(print "original: " L)
(let1 encoded-bitstream (interpolative-encode L L-length lo hi)
(format #t "encoded (~d bits): ~a\n" (length encoded-bitstream) encoded-bitstream)
(interpolative-decode Ldec L-length lo hi encoded-bitstream)
(print "decoded: " Ldec))))
結果
original: #(3 8 9 11 12 13 17) encoded (17 bits): (0 1 1 1 1 1 0 0 1 0 0 0 0 0 0 1 1) decoded: #(3 8 9 11 12 13 17)
17bitに圧縮後、ちゃんと復号できて一安心。
こんな便利なものがあるなんて知らずに生きていた（恥）
Function: info symbol
Gaucheのinfoドキュメント中から、 symbolで指定される手続きか構文要素の定義を含んでいるページを表示します。 infoドキュメントは、もし環境変数INFOPATHが定義されていればそこに示されるディレクトリ中から探され、そうでなければgoshのライブラリディレクトリから推測されるディレクトリ中から探されます。infoドキュメントが見付からなかったり、見付かってもsymbolがIndexページ中に無かった場合はエラーとなります。つまり、この手続きはinfoファイルがインストールされていないと動作しません。
現在の出力ポートが端末である場合、infoドキュメントの該当ページはページングプログラムを用いて表示されます。環境変数PAGERが指定されていればそれを用い、そうでなければコマンドサーチパスからless及びmoreをこの順で探します。いずれも見付からなかった場合や、出力ポートが端末ではない場合には、単にページがそのまま出力されます。
この手続きのセッション中での最初の呼び出しは、infoファイルをパーズするために多少時間がかかります。
unfoldの引数の順番に迷った時とか、REPLから
gosh> (info 'unfold)
と打てば
10.2.5 List fold, unfold & map
------------------------------
...
... (foldとかreduceとかの定義)
...
-- Function: unfold p f g seed &optional tail-gen
[SRFI-1] Fundamental recursive list constructor. Defined by the
following recursion.
(unfold p f g seed tail-gen) ==
(if (p seed)
(tail-gen seed)
(cons (f seed)
(unfold p f g (g seed))))
That is, P determines where to stop, G is used to generate
successive seed value from the current seed value, and F is used
to map each seed value to a list element.
...
qを打てばまたREPLに戻って来られる。これは便利。
久々にMeCabを使いたくなったのでGauche-mecabをインストールしたい（が少しはまった）のでメモ。
- MeCab: http://mecab.sourceforge.net/
- Gauche-mecab: http://sourceforge.jp/cvs/view/gauche/Gauche-mecab/
1. ビルドはGauche-0.9でもSnow Leopardでも行けるっぽい。
- CFLAGS='-arch i386' LDFLAGS='-arch i386' ./configure とかしなくても可か
2. ビルドはできるが make check で失敗する。
- /usr/lib/にある、Snow Leopardに元々入ってる？MeCabを見に行ってしまうため。
mecab-lib.$(SOEXT): $(srcdir)/mecab-lib.scm
$(GENCOMP) --ext-module=text/mecab.scm $(srcdir)/mecab-lib.scm
$(GAUCHE_PACKAGE) compile \
--local=$(LOCAL_PATHS) --ldflags='-L/usr/local/lib' --libs='-lmecab' --verbose mecab-lib mecab-lib.c
のようにldflagsでなんとかすれば良いレベル。
higeponさんから始まったコードバトンがkazu634さんから回ってきた話、の後編。
- kazu634さんから
- 次は佐野さんへ
やったこと
- 同じスクリプトをGaucheでもmoshでも動かそうと試行錯誤
- cond-expandを使うにはmoshではimport文が先に必要
- とりあえず、Gaucheで動かしたい時には最初のimportをコメントアウト、な方式で行きます
- 途中で２つの大きな壁
- moshをSnow Leopardで動かす →前編参照
- c-wrapperをSnow Leopardで動かす →c-wrapperは32bitでならビルドする方法が見つかった。後述。
- 小さな壁
- ncurseswが文字化け → LC_ALL の値が環境依存？とりあえず6を0にしたらMacでは直ったっぽい
ここしばらく本体となるピンボールゲームの開発に忙しくイプシロン関連の更新が滞っております :(
新タイトル「MAD DAEDALUS（仮称）」が完成しましたら、その成果をイプシロンにフィードバックいたします、どうぞしばらくお待ち下さい m(_ _)m
Shibuya Lisp TT#2の発表の時に使った"JelloBench"です :)
テクスチャマッピングされたポリゴンをSDL/OpenGLで描画しています。
プログラムはすべてSchemeで書かれていますが、Intel Core2 2.4GHzのLinuxで3500フレーム/秒以上の表示が可能です。
JelloBenchの実行には開発版のイプシロン(http://code.google.com/p/ypsilon/)とSDL, SDL_image, SDL_mixerが必要です。MacOSXでは最初にSDL.framework, SDL_image.framework, SDL_mixer.frameworkをインストールしておいてください。インプシロンのビルド時にSDL初期化用のdylibが作成され/usr/local/lib/ypsilon/に自動的にインストールされます。
JelloBenchは'example'にカレントディレクトリを移動してから'ypsilon jello.scm'で実行してください。
今回追加したMacOSXのSDLサポートにはid:kazuya_aさんがypsilon+SDL+Mac OSX!に紹介された方法を使っています。これによりSDL専用のイプシロンをビルドする必要がなくなりました。感謝です！:)
(6/13追記：動画を再エンコードしました)
野田 開さんのご厚意によりPS3をSSH経由で提供して頂きました m(_ _)m
32bit/64bit対応でFFIもサポート済みですよ。 :)
libspe2を使ったテストプログラムを作ってみました。
svn trunkのイプシロンをPS3に入れると動きます＾＾b
#!/usr/bin/env ypsilon #!r6rs ;; ps3-cell-demo.scm ;; tested on PS3 Linux (import (rnrs) (only (core) system format iota) (ypsilon ffi) (ypsilon concurrent) (ypsilon cell libspe2)) (define spe-code " #include <stdio.h> int main(unsigned long long spe_id, unsigned long long pdata) { printf(\"SPE:0x%llx sleep for 2 second\\n\", spe_id); sleep(2); printf(\"SPE:0x%llx exit\\n\", spe_id); return 0; }\n") (define NULL 0) (define source-file "spe_example.c") (define object-file "spe_example") (define make-spe-program (lambda () (when (file-exists? source-file) (delete-file source-file)) (call-with-port (open-output-file source-file) (lambda (port) (put-string port spe-code))) (unless (= (system (format "spu-gcc ~a -o ~a" source-file object-file)) 0) (error 'make-spe-program "unexpected error")))) (make-spe-program) (newline) ;; sequential (let ((image (spe_image_open object-file))) (when (= image NULL) (error 'spe_image_open "unexpected error")) (for-each (lambda (n) (let ((context (spe_context_create (+ SPE_EVENTS_ENABLE SPE_MAP_PS) NULL))) (when (= context NULL) (error 'spe_context_create "unexpected error")) (spe_program_load context image) (let ((entry (make-c-int SPE_DEFAULT_ENTRY))) (format #t "-- kick sequential run ~a/6\n" n) (when (< (spe_context_run context entry 0 0 NULL NULL) 0) (error 'spe_context_run "unexpected error")) (spe_context_destroy context)))) (iota 6)) (spe_image_close image)) (newline) (newline) ;; parallel (let ((image (spe_image_open object-file))) (when (= image NULL) (error 'spe_image_open "unexpected error")) (let ((threads (map (lambda (n) (format #t "-- kick parallel run ~a/6\n" n) (future (let ((context (spe_context_create (+ SPE_EVENTS_ENABLE SPE_MAP_PS) NULL))) (when (= context NULL) (error 'spe_context_create "unexpected error")) (spe_program_load context image) (let ((entry (make-c-int SPE_DEFAULT_ENTRY))) (when (< (spe_context_run context entry 0 0 NULL NULL) 0) (error 'spe_context_run "unexpected error")) (spe_context_destroy context))))) (iota 6)))) (format #t "== wait for all SPE exit\n") (for-each (lambda (x) (x)) threads)) (spe_image_close image))
このプログラムは、最初に一つのSPEで順次実行し、次に6個のSPEで並列実行します。
$ ypsilon example/ps3-cell-demo.scm -- kick sequential run 0/6 SPE:0x101b4340 sleep for 2 second SPE:0x101b4340 exit -- kick sequential run 1/6 SPE:0x101b4340 sleep for 2 second SPE:0x101b4340 exit -- kick sequential run 2/6 SPE:0x101b4340 sleep for 2 second SPE:0x101b4340 exit -- kick sequential run 3/6 SPE:0x101b4340 sleep for 2 second SPE:0x101b4340 exit -- kick sequential run 4/6 SPE:0x101b4340 sleep for 2 second SPE:0x101b4340 exit -- kick sequential run 5/6 SPE:0x101b4340 sleep for 2 second SPE:0x101b4340 exit -- kick parallel run 0/6 -- kick parallel run 1/6 -- kick parallel run 2/6 -- kick parallel run 3/6 SPE:0x101b5230 sleep for 2 second SPE:0x101b5170 sleep for 2 second SPE:0x101b52f0 sleep for 2 second SPE:0x1020c248 sleep for 2 second -- kick parallel run 4/6 -- kick parallel run 5/6 == wait for all SPE exit SPE:0x10223910 sleep for 2 second SPE:0x10237e48 sleep for 2 second SPE:0x101b5230 exit SPE:0x101b52f0 exit SPE:0x101b5170 exit SPE:0x1020c248 exit SPE:0x10223910 exit SPE:0x10237e48 exit
うまく動いているようです :D
ところでpowerpcはわたしの好きなCPUの一つなのですが、やはりあのニーモニックは微妙・・・思い出せばなんでもないことなんですけどね :p
SSH経由なのでエディタはemacsを使いました。どこでも同じものが動くというのは素晴らしいことです！でも・・・あいかわらず・・・普段はほとんど使っていません（笑
example/sdl-ttf-demo.scmの表示です :)
やっぱりハッシュテーブルだけだとキツイです・・・
で、餅は餅屋ということでMySQL 5.1 C APIのバインディングを追加しました。
$ ypsilon Ypsilon 0.9.6-trunk/r443 Copyright (c) 2009 Y.Fujita, LittleWing Company Limited. > (import (ypsilon mysql)) > (define NULL 0) > (define user "root") > (define passwd "...") > (define mysql (mysql_init NULL)) > (if (zero? (mysql_real_connect mysql "localhost" user passwd "mysql" 0 NULL 0)) (display (mysql_error mysql)) (display (mysql_stat mysql))) Uptime: 52318 Threads: 1 Questions: 7 Slow queries: 0 Opens: 12 Flush tables: 1 ... > (mysql_close mysql)
このままだと使いにくいので何か考えたいですね :)