プログラミング言語Schemeの学び方

これに触発されてみた。
調簡易なHTTPサーバーをR7RS＋SRFIで作ってSchemeを学ぼうという話。スライド145にある項目をとりあえず列挙

• Socketの扱い
• 正規表現
• リソースの開放
• 並行処理
• 文字列の扱い

【Socketの扱い】
Scheme標準にはないのでSRFI-106を使う。サーバーSocketはこう作る。

(define server-socket (make-server-socket "8080"))

そして、こんな風に待ち受ける。

(let loop ()
  (let ((socket (socket-accept server-socket)))
    (loop))

特に何もしないソケットがリークしまくるサーバーの出来上がり。

【正規表現】
Scheme標準にはないのでSRFI-115を使う。HTTPリクエストの最初の一行をパースする正規表現はこんな感じで書ける。

(define first-line
  '(: "GET" (+ space)
      (-> path (: "/" (+ ascii))) (+ space)
      "HTTP/" (: num "." num)))

こんな感じで使う

(cond ((regexp-matches first-line line) =>
       (lambda (m)
         (let ((path (regexp-match-submatch m 'path)))
           ;; get the content of the path
           ))))

サブマッチに名前は付ける必要はないが、あるとわかりやすい。

【リソースの開放】
Schemeに便利な汎用リソース開放構文というのはないので、都度用途に合わせて作ったり標準にあるものを用いる。例えば、ポートの開放はclose-portを使い、call-with-portを使えば、正常処理後にはポートを閉じてくれる。Socketの開放はsocket-shutodownやsocket-closeを用いる。
サーバをであれば、以下のようなものが便利に使えなくもない。

(define (finish)
  (close-port in)
  (close-port out)
  (socket-shutdown socket *shut-rdwr*)
  (socket-close socket))

inとoutはソケットポートである。

【並行処理】
Scheme標準にはないのでSRFI-18を使う。SRFI-18はプリミティブなスレッドとミューテックスしか提供しないので、高度なものが必要であれば自分で作る必要がある。
投げっぱなしスレッドは以下のように作れる。

(thread-start! (make-thread (lambda () (handle-request socket))))

処理系によってはスレッドの作成は高価な場合があるので、可能であればスレッドプール等は作っておきたいところ。R6RS処理系かつSRFI-18をサポートしているのであれば、拙作の(util concurrent)が使える。

【文字列の扱い】
スライドにあるような便利なものはない。連結したければstring-append等を使う必要がある。文字列操作は高価な場合があるので(例：参照にO(n)かかる)、使える場面ではポートを使いたいところ。

さて、上記全てを踏まえて非常に簡易なGETリクエストのみに対応したHTTPサーバは以下になる。R7RSではバイナリポートと文字ポートは分かれていて、処理系によっては厳しく分けてあつかう(特にR6RS/R7RSな処理系、Sagittariusなど)ので、I/Oの部分がどうしても煩雑になる。例えば、出力の際には文字列を一旦バイナリに変換している。

(import (scheme base)
        (scheme write)
        (scheme file)
        (srfi 18)
        (srfi 106)
        (srfi 115))

;; Assume all ASCII
(define (read-binary-line in)
  (let ((out (open-output-string)))
    (let loop ((b (read-u8 in)))
      (case b
        ((#x0d)
         (case (peek-u8 in)
           ((#x0a) (read-u8 in) (get-output-string out))
           (else (write-char (integer->char b) out) (loop (read-u8 in)))))
        (else (write-char (integer->char b) out) (loop (read-u8 in)))))))

(define (handle-request socket)
  (define in (socket-input-port socket))
  (define out (socket-output-port socket))
  (define first-line
    '(: "GET" (+ space)
        (-> path (: "/" (+ ascii))) (+ space)
        "HTTP/" (: num "." num)))
  (define (finish)
    (close-port in)
    (close-port out)
    (socket-shutdown socket *shut-rdwr*)
    (socket-close socket))
  (define (http-error status e)
    (define message (string->utf8 "Not okay"))
    (report-error e)
    (write-bytevector (string->utf8 "HTTP/1.1 ") out)
    (write-bytevector (string->utf8 (number->string status)) out)
    ;; laziness...
    (write-bytevector (string->utf8 " BOO\r\n") out)
    (write-bytevector (string->utf8 "Content-Type: text/plain\r\n") out)
    (write-bytevector (string->utf8 "Content-Length: ") out)
    (write-bytevector (string->utf8
                       (number->string (bytevector-length message))) out)
    (write-bytevector (string->utf8 "\r\n\r\n") out)
    (write-bytevector message out)
    (finish))
    
  (guard (e (else (http-error 500 e)))
    (let ((line (read-binary-line in)))
      (cond ((regexp-matches first-line line) =>
             (lambda (m)
               (let ((path (regexp-match-submatch m 'path))
                     (bout (open-output-bytevector)))
                 (guard (e (else (http-error 404 e)))
                   (let ((file (string-append "." path)))
                     (call-with-port (open-binary-input-file file)
                       (lambda (in)
                         (define buf (make-bytevector 1024))
                         (let loop ((n (read-bytevector! buf in)))
                           (write-bytevector buf bout 0 n)
                           (when (= n 1024)
                             (loop (read-bytevector! buf in))))))))
                 (write-bytevector (string->utf8 "HTTP/1.1 200 OK\r\n") out)
                 (write-bytevector (string->utf8 "Content-Type: text/plain\r\n") out)
                 (let ((bv (get-output-bytevector bout)))
                   (write-bytevector (string->utf8 "Content-Length: ") out)
                   (write-bytevector (string->utf8
                                          (number->string
                                           (bytevector-length bv))) out)
                   (write-bytevector (string->utf8 "\r\n\r\n") out)
                   (write-bytevector bv out)
                   (finish)))))
            (else (http-error 403 #f))))))

(define server-socket (make-server-socket "8080"))

(display "Starting server on port 8080") (newline)
(let loop ()
  (let ((socket (socket-accept server-socket)))
    (thread-start! (make-thread (lambda () (handle-request socket))))
    (loop))

もう少し簡単に書きたいと思ったら、Sagittariusに付属している(net server)を使うか、拙作Paellaを使うと簡単にHTTPサーバが書ける。後者はサーバというよりはWebアプリが簡単に書けると言うべきか。

スレッドの軽量化

Sagittariusはスレッドの作成が重い。理由は至って簡単でスレッド毎にVMを複製するからである。あまり気にするほどスレッドを使っていなかったのだが、最近（というか昨日）Paellaに非同期的なのを入れた際にこれはまずいと思いだした。何がまずいかというと、Paellaに入れた非同期構造は、サーバーからソケットの管理を外した後にスレッドを作ってその中でリクエストを処理するというものだからだ。つまり、スレッドの作成の重さがそのままボトルネックになる。

スレッドの生成で最も重いのはVMスタックを割り当てる部分だと大まかにあたりをつけてはいた。ついでに、VMスタックをCスタック上におければよくね？とも考えてはいた。ずっと思っていただけで実行には移さなかったのだが、ここに来てちと重要になりそうなのでえいや！っと試してみることにした。

スレッド＝VMということはスレッドの寿命＝VMの寿命でもあるので、開始時にスレッドのスタックからVMスタックを割り付ければ問題ないはず。ということでそんな感じのコードを書いて適当なベンチマークを行ってみた。以下はベンチマークのコード

(import (rnrs) (srfi :1) (srfi :18) (time))

(define data (iota 10000))

(let ((threads
       (time (map (lambda (i)
                    (thread-start! (make-thread (lambda () i)))) data))))
  (assert (equal? data (map thread-join! threads))))

スレッドの生成時間のみを測りたいので、こんなに単純。っで以下が結果(環境 Ubuntu 16.04 64bit Intel® Core™ i7-6820HQ CPU @ 2.70GHz × 8):
元のコード

$ sash thread-bench.scm

;;  (map (lambda (i) (thread-start! (make-thread (lambda () i)))) data)
;;  2.626753 real    3.012000 user    0.256000 sys

改良版

$ ./build/sagittarius -Dbuild thread-bench.scm

;;  (map (lambda (i) (thread-start! (make-thread (lambda () i)))) data)
;;  0.239091 real    0.120000 user    0.224000 sys

ちょっと出来過ぎな感じもするが、効果はありっぽい。まぁ、生成数をひとけた減らすと３倍程度の改善になるので、メモリの圧迫が減っただけとも言える（それが目的なのではあるが）。