2010-12-29

文字列操作の性能(1)

Common Lispで文字列を操作する場合に、何種類かある方法のうち、どれが一番効率的か知りたかったので、調べることにした。今回は参照編。

次のコードを使って、シーケンシャルアクセスの時間を測った。処理系はClozure CL 1.6。get-internal-real-timeの単位はミリ秒。

(defmacro with-random-string ((var &optional (length 1000)) &body body)
  `(let ((,var (make-string ,length)))
     (iter (for i index-of-string ,var)
           (setf (aref ,var i) (code-char (+ 32 (random 95)))))
     ,@body))

(defmacro with-null-stream ((var) &body body)
  `(let ((,var (make-two-way-stream (make-concatenated-stream) 
                                    (make-broadcast-stream))))
     (with-open-stream (,var ,var)
       ,@body)))

(defmacro with-benchmark (&body body)
  (with-gensyms (time)
    `(let ((,time (get-internal-real-time)))
       ,@body
       (- (get-internal-real-time) ,time))))

(defparameter *times* 1000)
(defparameter *length* 1024)

(iter (repeat *times*)
      (sum (with-random-string (str *length*)
             (with-null-stream (*standard-output*)
               (with-benchmark
                 (iter (for i index-of-string str)
                       (princ (char str i))))))))

(iter (repeat *times*)
      (sum (with-random-string (str *length*)
             (with-null-stream (*standard-output*)
               (with-benchmark
                 (iter (for i index-of-string str)
                       (princ (aref str i))))))))

(iter (repeat *times*)
      (sum (with-random-string (str *length*)
             (with-null-stream (*standard-output*)
               (with-benchmark
                 (iter (for i index-of-string str)
                       (princ (elt str i))))))))

(iter (repeat *times*)
      (sum (with-random-string (str *length*)
             (with-null-stream (*standard-output*)
               (with-input-from-string (s str)
                 (with-benchmark
                   (iter (for c = (read-char s nil))
                         (while c)
                         (princ c))))))))

結果は、

関数 所要時間(ミリ秒)
char 1093
aref 998
elt 1063
read-char 1189

arefが一番速い。eltは、型に合わせて下位のアクセサを呼ぶと思っていたので、一番速くないのは予想通り。何となくcharはプリミティブなアクセサだと思い込んでいたけど、実際はarefとeltよりも遅い。文字列ストリームが一番遅いのは予想外。予想以上に上位の関数で組み立てられている模様。

実際のコードを読んでみた。まずはchar。

(defun char (string index)
  "Given a string and a non-negative integer index less than the length of
  the string, returns the character object representing the character at
  that position in the string."
  (if (typep string 'simple-string)
    (schar (the simple-string string) index)
    (if (stringp string)
      (multiple-value-bind (data offset) (array-data-and-offset string)
        (schar (the simple-string data) (+ index offset)))
      (report-bad-arg string 'string))))

scharを呼んでいる。scharの定義は、

(defun schar (s i)
  "SCHAR returns the character object at an indexed position in a string
   just as CHAR does, except the string must be a simple-string."
  (let* ((typecode (typecode s)))
    (declare (fixnum typecode))
    (if (= typecode target::subtag-simple-base-string)
      (aref (the simple-string s) i)
      (report-bad-arg s 'simple-string))))

で、結局呼ぶのはaref。Common Lispでは文字列は文字のベクタなので、ベクタに対する処理のarefの方が下位ということなんだろう。

(defun aref (a &lexpr subs)
  "Return the element of the ARRAY specified by the SUBSCRIPTS."
  (let* ((n (%lexpr-count subs)))
    (declare (fixnum n))
    (if (= n 1)
      (%aref1 a (%lexpr-ref subs n 0))
      (if (= n 2)
        (%aref2 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1))
        (if (= n 3)
          (%aref3 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1) (%lexpr-ref subs n 2))
          (let* ((typecode (typecode a)))
            (declare (fixnum typecode))
            (if (>= typecode target::min-vector-subtag)
              (%err-disp $XNDIMS a n)
              (if (< typecode target::min-array-subtag)
                (report-bad-arg a 'array)
                ;;  This typecode is Just Right ...
                (progn
                  (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) n)
                    (%err-disp $XNDIMS a n))
                  (let* ((rmi (%array-index a subs n)))
                    (declare (fixnum rmi))
                    (multiple-value-bind (data offset) (%array-header-data-and-offset a)
                      (declare (fixnum offset))
                      (uvref data (the fixnum (+ offset rmi))))))))))))))

arefはあからさまにプリミティブな内容。

(defun elt (sequence idx)
  "Return the element of SEQUENCE specified by INDEX."
  (seq-dispatch
   sequence
   (let* ((cell (nthcdr idx sequence)))
     (if (consp cell)
       (car (the cons cell))
       (if cell
         (report-bad-arg sequence '(satisfies proper-list-p))
         (%err-disp $XACCESSNTH idx sequence))))
       
   (progn
     (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0))
       (report-bad-arg idx 'unsigned-byte))
     (locally 
       (if (>= idx (length sequence))
         (%err-disp $XACCESSNTH idx sequence)
         (aref sequence idx))))))

eltは、総称関数ではなく、普通の関数。規格上でもそう決まっている。これもarefを呼んでいる。

文字列ストリームは、level-1/l1-streams.lispに定義がある。read-charしたとき、最終的に呼ばれるのは、おそらくこれ。

(defun string-input-stream-ioblock-read-char (ioblock)
  (let* ((string (string-stream-ioblock-string ioblock))
         (idx (string-input-stream-ioblock-index ioblock))
         (end (string-input-stream-ioblock-end ioblock)))
    (declare (fixnum idx end)
             (simple-string string))
    (if (< idx end)
      (progn (setf (string-input-stream-ioblock-index ioblock)
                   (the fixnum (1+ idx)))
             (schar string idx))
      :eof)))

scharを呼んでいるので、最終的に呼ばれるのはaref。

というわけで、実際の定義も計測結果を裏付ける内容だった。定義を見る限り、ランダムアクセスでも順位は変わらない。文字列ストリームだけ、file-positionで位置を指定する分、他と差が開くかもしれない。

結論としては、Clozure CL 1.6においては、文字列の要素を参照する場合、arefが一番速い。

情報を頂いたので追記。SBCLでは、最適化を掛けると、charやeltがarefに展開されるようで、ディスアセンブルした結果も一致するとのこと。良いなあ。

2010-12-28

Packrat Parser

Common Lispでの実装がPackrat ParsingPackrat Parsing: 遅延版にあった。この方の書く記事は実践的でいつも面白い。

確かに、構造体を利用した遅延版は速いかもしれないんだけど、富豪的なメモリの使い方。パーザの数をn、文字列の長さをlとすると、クロージャをn * l個必ず作らなければならない。遅延評価のHaskellとかなら問題ないのかもしれないけど、Lispだと結構辛い。構造体を作る処理自体も重そう。それと、パーザを定義するごとに構造体のフィールドを増やさないといけないのは、色々と面倒な気がする。マクロで、パーザの定義ごとに構造体を再定義する方法はあるかもしれないけど、ちょっと泥臭い。

自分で使う分には、ハッシュテーブルで十分かとも思うけど、実際にどれだけ高速化するか測ってみないとなんとも言えない。

2010-12-27

ちょっと気の利いた再帰の使い方

考えてみると当たり前なんだけど、軽く感動した再帰の使い方について。

ストリームか文字列を同じ引数として受け取る関数を書こうとして、ストリームの場合と文字列の場合の処理の振り分けについて考えていた。最初は単純に、typecaseや、cl-matchなどのパターンマッチャで、型ごとに分岐させるか、総称関数を使って、型ごとに関数を分けてしまおうと考えた。ただ、処理が、分岐や別の関数に散らばってしまうので、何となくしっくり来なかった。

そこで、他の人がどうやってるのかが気になって、使ってる処理系のコードを読んでみたところ、


(defun f (string-or-stream)
  (if (stringp string-or-stream)
      (with-input-from-string (s string-or-stream)
        (f s))
      (main-process)))

のようなアプローチを採っていた。賢い。

今後、こういうパターンでは使わせてもらおう。

2010-12-20

cond-cons

Scheme:マクロの効用リストの構築で、cond-consというマクロが紹介されてるけど、Common Lispで欲しくなったので書いてみた。

(defmacro cond-cons (&rest clauses)
  (labels ((rec (clauses)
             (if clauses
                 (let ((clause (car clauses))
                       (r (rec (cdr clauses))))
                   `(if ,(car clause) (cons (progn ,@(cdr clause)) ,r) ,r))
                 nil)))
    (rec clauses)))

一瞬、rが複数回評価されて、副作用があるとまずいんじゃ、とか思ったけど、考えたらifで分岐するから問題なかった。

マクロなのに末尾再帰版。すみません。大好きです末尾再帰。

(defmacro cond-cons (&rest clauses)
  (labels ((rec (clauses fn)
             (if clauses
                 (let ((clause (car clauses)))
                   (rec (cdr clauses)
                        (lambda (x)
                          `(if ,(car clause)
                               (cons (progn ,@(cdr clause)) ,(funcall fn x))
                               ,(funcall fn x)))))
                 `(nreverse ,(funcall fn nil)))))
    (rec clauses (lambda (x) x))))

コンパイル時にしか評価されないので、ほとんど意味がない。末尾再帰じゃないバージョンだとスタックが溢れるくらい、clausesが長いリストだったりするなら多少は意味があるだろうけど、それってどんなだよ。

Paul Grahamも同じ趣旨のことをOn Lispかどこかに書いてたように思うけど、マクロ定義のコードで頑張る意味なんてない。

ちなみに、Gaucheでは、util.listにcond-listという名前で、より高機能なものが収録されている。何でそんなことを書くかというと、以前探したときに、しばらく見付けられなかったからではない。そんなわけはない。

2010-12-13

teepeedee2でfaviconを表示

手探りでやるしかないから、えらく苦労した。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:load-system :teepeedee2))

(defpackage :tpd2-favicon (:use :cl :tpd2 :tpd2.ml.html))
(in-package :tpd2-favicon)

(defconstant +icon-content-type+
  (byte-vector-cat "Content-Type: image/x-icon" tpd2.io:+newline+))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun favicon ()
    (with-open-file (in "work/tpd2/favicon.ico" :element-type '(unsigned-byte 8))
      (let ((buf (make-array (file-length in) :element-type '(unsigned-byte 8))))
        (read-sequence buf in)
        buf))))

(dispatcher-register-path
 (find-or-make-dispatcher "localhost:8080")
 "/favicon.ico"
 #'(lambda (dispatcher con done)
     (declare (ignore dispatcher))
     (start-http-response :content-type +icon-content-type+)
     (send-http-response con done (with-sendbuf () #.(favicon)))))

(defsite *favicon-site* :dispatcher (find-or-make-dispatcher "localhost:8080"))

(with-site (*favicon-site*)
  (defpage "/" ()
    (<p "favicon test")))

(http-start-server 8080)
(ccl:process-run-function "tpd2" #'event-loop)

2010-12-06

フィードを表示するWiLiKiのリーダーマクロ

オプション引数の処理がad hocなのは仕様です。

(use gauche.charconv)
(use srfi-1)
(use srfi-13)
(use srfi-19)
(use rfc.822)
(use rfc.http)
(use rfc.uri)
(use sxml.ssax)
(use sxml.sxpath)
(use sxml.tools)
(use util.list)

(define-reader-macro (feed url . args)
  (define *item-max* 10)
  (define *date-format* "~Y/~m/~d")
  (define *item-format* "(~a) ~a")
  (define *ns*
    '((atom . "http://www.w3.org/2005/Atom")
      (openSearch . "http://a9.com/-/spec/opensearchrss/1.0/")
      (georss . "http://www.georss.org/georss")
      (thr . "http://purl.org/syndication/thread/1.0")
      (rss1 . "http://purl.org/rss/1.0/")
      (rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
      (content . "http://purl.org/rss/1.0/modules/content/")
      (dc . "http://purl.org/dc/elements/1.1/")
      (foo . "bar")))
  (define (w3cdtf->date str)
    (define (df->nano df)
      (string->number (string-pad-right (number->string df) 9 #\0)))
    (and-let*
        ((match (#/^(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:T(\d\d):(\d\d)(?::(\d\d)(?:\.(\d+))?)?(?:Z|([+-]\d\d):(\d\d)))?)?)?$/ str)))
      (receive (year month day hour minute second df zh zm)
          (apply values (map (lambda (i) (x->integer (match i))) (iota 9 1)))
        (make-date (df->nano df)
                   second minute hour day month year
                   (* (if (negative? zh) -1 1)
                      (+ (* (abs zh) 3600) (* zm 60)))))))
  (define *feed-attributes*
    `((atom 
       (converter
        ,(sxpath '(// atom:entry atom:title *text*))
        ,(sxpath '(// atom:entry
                   (atom:link (@ (equal? (rel "alternate"))))
                   @ href *text*))
        ,(sxpath '(// atom:entry atom:published *text*)))
       (date-parser . ,w3cdtf->date))
      (rss1
       (converter
        ,(sxpath '(// rss1:item rss1:title *text*))
        ,(sxpath '(// rss1:item rss1:link *text*))
        ,(sxpath '(// rss1:item dc:date *text*)))
       (date-parser . ,w3cdtf->date))
      (rss2
       (converter
        ,(sxpath '(// item title *text*))
        ,(sxpath '(// item link *text*))
        ,(sxpath '(// item pubDate *text*)))
       (date-parser . ,rfc822-date->date))))
  (define (feed-attr type field)
    (cdr (assoc field (cdr (assoc type *feed-attributes*)))))
  (define (decompose-uri url)
    (receive (_ specific) (uri-scheme&specific url)
      (uri-decompose-hierarchical specific)))
  (define (authority&path?query url)
    (define (path?query path query)
      (with-output-to-string
        (lambda ()
          (display path)
          (when query (format #t "?~a" query)))))
    (receive (authority path query _) (decompose-uri url)
      (values authority (path?query path query))))
  (define (feed-get url)
    (receive (authority path?query) (authority&path?query url)
      (receive (status header body) (http-get authority path?query)
        (unless (equal? status "200")
          (error "フィードの読み込みに失敗しました。ステータスコードは~aです。"
                 status))
        (if (or (null? args) (null? (cdr args)))
            body
            (ces-convert body (cadr args))))))
  (define (feed->sxml feed)
    (with-input-from-string feed
      (cut ssax:xml->sxml (current-input-port) *ns*)))
  (define (feed-type-of sxml)
    (define root-node ((car-sxpath '(*)) sxml))
    (define (rss1?)
      (eq? (sxml:name root-node) 'rdf:RDF))
    (define (rss2?)
      (and (eq? (sxml:name root-node) 'rss)
           (equal? (sxml:attr root-node 'version) "2.0")))
    (define (atom?)
      (eq? (sxml:name root-node) 'atom:feed))
    (cond ((rss1?) 'rss1)
          ((rss2?) 'rss2)
          ((atom?) 'atom)
          (else (error "対応していない種類のフィードです。"))))
  (define converter-title car)
  (define converter-link cadr)
  (define converter-date caddr)
  (define (take-item-max nodes)
    (let1 n (if (null? args) *item-max* (car args))
      (take* nodes n)))
  (let* ((feed (feed->sxml (feed-get url)))
         (type (feed-type-of feed))
         (conv (feed-attr type 'converter))
         (proc (feed-attr type 'date-parser))
         (title (converter-title conv))
         (link (converter-link conv))
         (date (converter-date conv)))
    `((ul ,@(map (lambda (title link date)
                   `(li (a (@ (href ,link))
                           ,(format #f *item-format*
                                    (date->string (proc date) *date-format*)
                                    title))))
                 (take-item-max (title feed))
                 (take-item-max (link feed))
                 (take-item-max (date feed)))))))

W3C-DTF文字列をSRFI 19の日付オブジェクトに変換する関数

WiLiKiのrssmix.scmを参考に、W3C-DTFの文字列をSRFI 19の日付オブジェクトに変換する関数を書いた。

(use srfi-1)
(use srfi-13)
(use srfi-19)

(define (w3cdtf->date str)
  (define (df->nano df)
    (string->number (string-pad-right (number->string df) 9 #\0)))
  (and-let*
      ((match (#/^(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:T(\d\d):(\d\d)(?::(\d\d)(?:\.(\d+))?)?(?:Z|([+-]\d\d):(\d\d)))?)?)?$/ str)))
    (receive (year month day hour minute second df zh zm)
        (apply values (map (lambda (i) (x->integer (match i))) (iota 9 1)))
      (make-date (df->nano df)
                 second minute hour day month year
                 (* (if (negative? zh) -1 1)
                    (+ (* (abs zh) 3600) (* zm 60)))))))