Think Stitch
PRINCIPIA  最近の更新


Lisp to C Translator

Lisp から C 言語への変換器を作ってみたいと思います. 遊べる程度には機能があって,変換はできるだけ楽をするという方針でいきたいと思います.

Lisp の仕様

まず入力となる Lisp の言語仕様を決めます.

データ型

データ型はシンボル,整数(即値のみ),ペア,あと手続き(クロージャ)です. nil はシンボルで空リストと真偽値の偽を表すとします.

構文

構文を以下のように決めました.

細かいところは以下のようにします.

組み込み関数

組み込み関数も最小限にします.

出力する C コードの構造

次は出力する C コードの構造を考えます.

ポインタの構造

オブジェクトは少なくとも 4 バイト境界にそろえて配置することにして,ポインタの下位 2 ビットをタグとして使います.

nnnnnnnnnnnnnnnn 1   fixnum
aaaaaaaaaaaaaaa 00   pointer to an object
iiiiiiiiiiiiiii 10   symbol

オブジェクトの構造

シンボルは実行中には作らず,ごみ集めで回収しないことにして,下のようなシンボル名文字列のテーブル作り,そのインデックスをポインタに埋め込むことにします.

const char *symtbl[] = {
    "nil",
    "t",
    "A",
    "B",
    "C",
    "D",
};

メモリ上に配置され,ごみ集めの対象となるオブジェクトはペアとクロージャ,それと boxing 用の box です. これらはすべて次の構造体で表します.

typedef struct object *id;

struct object {
  unsigned mark : 1;
  unsigned closure : 1;
  unsigned size : 20;
  id v[0];
};

mark はごみ集めでのマークビット,closure はクロージャかどうかを表すフラグです. v は size 個のポインタです.ペアの場合は size = 2 です.size フィールドの大きさ 20 は適当です.

クロージャ変換と Boxing

lambda 式はすべてクロージャにします. まず各 lambda 式をひとつひとつ C 言語の関数に変換します.そして lambda 式を評価するところでは,クロージャ用のメモリを割りあて,C 言語の関数へのポインタとクローズする変数の値を格納します.

代入される変数は boxing します. 変換時にどのパラメータが代入されるかを調べて,lambda body の入り口で boxing します.

引数の渡し方とごみ集め

引数を渡す方法を考えます. 単純に C 言語でも関数の引数として渡すことにすると,ごみ集めのときにマークできるようにするために仕掛けが必要になります.そういうやり方もありますけど,ここではもっと簡単に,自前のスタックを持つことにします. 引数を前から順にスタックに積んで関数を呼び出します.引数の個数は関数の引数として渡すことにします. 結局,C 言語の関数はクロージャと引数の数の2つだけパラメータを持つことになります.

ごみ集めのときにはクロージャもマークする必要があるので,現在のクロージャを保持するグローバル変数 CP を用意してマークできるようにします. 関数を呼び出すときには,呼び出された方で CP をスタックに積み,リターンするときに戻すことにします.つまり,自前のスタック上に自前でフレームを作るということです.

生成コードの例

変換の話に移る前に,雰囲気をつかんでもらうためにコードの例を示します.

例えば次の式を変換すると,内側の lambda 式は下のようなコードになります.

(lambda (x) ((lambda (y) (+ x y)) 8))

引数 self はクロージャ,nargs は引数の数です. SP はスタックポインタで,スタックトップの1つ先を指しています. 引数は nargs 個ですから,引数の先頭は argv = SP - nargs となり,各引数は argv[0], argv[1], ... で参照できます. #1 で呼び出し元のクロージャを保存しています.

id lambda_1(id self, int nargs)
{
    id R, *argv = SP - nargs;
    *SP++ = CP; CP = self;               ; #1
    {
        intptr_t tmp;
        R = CP->v[1];                    ; #2
        tmp = fixnum_value(R);
        R = argv[0];
        R = make_fixnum(tmp + fixnum_value(R));
    }
    CP = argv[nargs]; SP = argv;         ; #3
    return R;
}

各部分式の評価結果,つまり値は変数 R に格納するようにします.かなり冗長ですけど,変換では楽をして,あとは C コンパイラにがんばってもらいます.

本体では引数 y とクローズされた変数 x を加えることになります.#2 がクロージャの中の変数 x の値を参照している部分です.CP->v[0] には関数へのポインタが入っているので,インデックスは 1 からです.

最後に #3 で CP を元に戻し,引数を含むスタックフレームを解放します.

外側の lambda 式は次のようになります. まず #1 で引数 8 をスタックに積みます. 次にクロージャを作ります.オブジェクト用のメモリを割り当て(#2),関数へのポインタ(#3)と変数 x の値(#4)を格納します.そして呼び出します(#5).

id lambda_0(id self, int nargs)
{
    id R, *argv = SP - nargs;
    *SP++ = CP; CP = self;
    R = make_fixnum(8);               ; #1
    push(R);
    R = make_closure(1);              ; #2
    R->v[0] = (id)&lambda_1;          ; #3
    R->v[1] = argv[0];                ; #4
    R = (*(pf_t)(R->v[0]))(R, 1);     ; #5
    CP = argv[nargs]; SP = argv;
    return R;
}

もう一つ,代入がある場合の例を示します.

(lambda (x)
  (begin
    (set! x (+ x 13))
    (lambda () x)))

代入の対象となる変数は,#1 のように boxing します. 値を参照するときは #2 のように box の中身を取り出します. 代入の場合は #3 のように box の中身を書き換えます. 代入される変数をクロージャに格納するときは,#4 のように値ではなく box への参照をそのまま入れます.こうすることですべてのクロージャで変数を共有できます.

id lambda_0(id self, int nargs)
{
    id R, *argv = SP - nargs;
    *SP++ = CP; CP = self;
    argv[0] = box(argv[0]);         ; #1
    { intptr_t tmp;
        R = (argv[0])->v[0];        ; #2
        tmp = fixnum_value(R);
        R = make_fixnum(13);
        R = make_fixnum(tmp + fixnum_value(R)); }
    argv[0]->v[0] = R;              ; #3
    R = make_closure(1);
    R->v[0] = (id)&lambda_1;
    R->v[1] = argv[0];              ; #4
    CP = argv[nargs]; SP = argv;
    return R;
}

変換

変換は 2 パスで行います.はじめのパスではデータとしてのシンボルと lambda 式をすべて集めます.それぞれに集積用のハッシュ表を用意しておいて,式を構造的に分解しながら見つけたものを登録していきます.

lambda 式には変数に関する情報を2種類計算して付けます.1つはクローズする変数のリストです.いいかえれば lambda 式本体に現われる自由変数のリストです.これは関数 collect-free で求めます.もう1つは代入の対象となる変数のリストです.これは boxing をするためと,参照時に unbox が必要かどうかを判断するために使います.こちらは関数 collect-sets で求めます.

(define (collect-symbols-n-lambdas locals closed sets expr)
  (match expr
    (('quote c)
     (if (symbol? c)
         (register-symbol c)))
    (('lambda ps body)
     (let ((vs (lset-difference eq?
                 (lset-union eq? locals closed)
                 ps)))
       (let ((fs (collect-free vs '() body))
             (ss (collect-sets ps '() body)))
         (let ((xs (lset-union eq? ss (lset-difference eq? sets ps))))
           (register-lambda expr fs xs)
           (collect-symbols-n-lambdas ps fs xs body)))))
    ((op . args)
     (for-each
      (lambda (x)
        (collect-symbols-n-lambdas locals closed sets x))
      expr))
    (_ #f)))

引数の locals, closed, sets はそれぞれ,調べる対象である式 expr がある場所から見える lambda 式のパラメータリスト,クローズされている変数のリスト,そして box されている変数のリストです.lambda 式はすべてクロージャにすることにしたので(そしてグローバル変数はないので),変数はパラメータかクローズされているものかのどちらかになります.

その状況下で lambda 式があった場合,lambda 式本体の locals, closed, sets がそれぞれどうなるか考えます.まず locals はかんたんで,lambda 式のパラメータリスト ps そのものになります.したがってわざわざ記録しておく必要はないでしょう.

残りの2つは少し事情が複雑です.まず closed ですが,これはいいかえれば lambda 式本体に自由に現われる変数のリストですから,関数 collect-free を使って求めます.関数 collect-free は自由変数として扱う変数の候補を渡すようになっています.これは locals と closed の和集合からパラメータ ps を除いたものになります.

最後は sets です.lambda 式本体から見える変数のうち,パラメータ ps 以外はすでにわかっているので,ps の中で代入されるものがあるかどうかを関数 collect-sets によって調べます.これと元の sets の和集合を求めればいいように思いますが,落し穴があります.sets の中にパラメータと同名の変数があって,しかも代入されない場合があるからです.そのため,まずいちど sets から ps をすべて取り除いて,それから改めて代入されるものだけを加えます.

関数 collect-free は以下のとおりです.パラメータ vs が自由変数の候補です.acc は集積変数です. lambda 式の本体を調べる際に,vs からパラメータ ps を除いておくこと以外は特に難しくないと思います.

(define (collect-free vs acc expr)
  (match expr
    (('quote c) acc)
    (('lambda ps body)
     (collect-free (lset-difference eq? vs ps)
                   acc body))
    (('set! v e)
     (let ((acc (collect-free vs acc e)))
       (if (and (memq v vs)
                (not (memq v acc)))
           (cons v acc)
           acc)))
    ((op . args)                        ; including if and begin
     (fold-left
       (lambda (acc x)
         (collect-free vs acc x))
       acc expr))
    (_
     (if (and (memq expr vs)
              (not (memq expr acc)))
         (cons expr acc)
         acc))))

関数 collect-sets も同様です.

(define (collect-sets vs acc expr)
  (match expr
    (('quote c) acc)
    (('lambda ps body)
     (collect-sets (lset-difference eq? vs ps)
                   acc body))
    (('set! v e)
     (let ((acc (collect-sets vs acc e)))
       (if (and (memq v vs)
                (not (memq v acc)))
           (cons v acc)
           acc)))
    ((op . args) ; including if and begin
     (fold-left
       (lambda (acc x)
         (collect-sets vs acc x))
       acc expr))
    (_ acc)))

つづいて式を評価するコードを生成する部分に移ります.まず変数を参照するコードを生成する補助関数2つです.

関数 gen-ref-var は指定された変数 x の値を参照するコードを生成します. locals, closed と順に x が入っているかどうかを調べ,もし i 番目にあったら argv[i] または CP->v[i + 1] を出力するだけです.

(define (gen-ref-var x locals closed)
  (let ((i (list-index (lambda (y) (eq? x y)) locals)))
    (if i
        (format port "argv[~S]"  i)
        (let ((i (list-index (lambda (y) (eq? x y)) closed)))
          (if i
              (format port "CP->v[~S]" (+ i 1))
              (error "unknown var" x))))))

関数 gen-val-var は変数 x が boxing されているときに,unbox するコードも出力します.

関数 gen-ref-var と gen-val-var が分れているのは,クロージャを作るときには boxing にかかわらず参照を格納するからです.

(define (gen-val-var x locals closed sets)
  (if (memq x sets)
      (begin
        (format port "(")
        (gen-ref-var x locals closed)
        (format port ")->v[0]"))
      (gen-ref-var x locals closed)))

いよいよ変換の本体です.式の構成にしたがって対応するコードを生成します.

quote では空リストか整数かシンボルかに応じて即値を作ります.空リストが特別扱いになっているのはメタ言語が Scheme だからです.

lambda 式ではクロージャを作ります.あらかじめ計算しておいた closed を参照しながら変数をクローズする部分を作ります.

(define (compile expr locals closed sets)
  (match expr
    (('quote c)
     (cond ((null? c)
            (format port "R = nil;\n"))
           ((integer? c)
            (format port "R = make_fixnum(~S);\n" c))
           ((symbol? c)
            (let ((id (get-symbol-id c)))
              (format port "R = symbol(~S);\n" id)))
           (else
            (error "invalid constant" expr))))
    (('lambda ps body)
     (let ((id.closed.sets (hash-table-get lambda-ht expr)))
       (let ((id (car id.closed.sets))
             (closed (cadr id.closed.sets)))
         (format port "R = make_closure(~S);\n" (length closed))
         (format port "R->v[0] = (id)&lambda_~S;\n" id)
         (do ((i 0 (+ i 1))
              (xs closed (cdr xs)))
             ((null? xs))
           (format port "R->v[~S] = " (+ i 1))
           (gen-ref-var (car xs) locals closed)
           (format port ";\n")))))
    (('if b t e)
     (compile b locals closed sets)
     (format port "if (R != nil) {\n")
     (compile t locals closed sets)
     (format port "} else {\n")
     (compile e locals closed sets)
     (format port "}\n"))
    (('set! v e)
     (compile e locals closed sets)
     (gen-ref-var v locals closed)
     (format port "->v[0] = R;\n"))
    (('begin . es)
     (cond ((not (pair? es))
            (error "invalid begin" expr))
           ((null? (cdr es))
            (compile (car es) locals closed sets))
           (else
            (compile (car es) locals closed sets)
            (compile `(begin ,@(cdr es)) locals closed sets))))
    ;;
    (('car x)
     (compile x locals closed sets)
     (format port "R = R->v[0];\n"))
    (('cdr x)
     (compile x locals closed sets)
     (format port "R = R->v[1];\n"))
    (('cons x y)
     (compile x locals closed sets)
     (format port "push(R);\n")
     (compile y locals closed sets)
     (format port "push(R);\n")
     (format port "R = cons();\n"))
    (('eq? x y)
     (compile x locals closed sets)
     (format port "push(R);\n")
     (compile y locals closed sets)
     (format port "R = (R == pop()) ? symbol_t : nil;\n"))
    (('<= x y)
     (compile x locals closed sets)
     (format port "push(R);\n")
     (compile y locals closed sets)
     (format port "R = (R <= pop()) ? symbol_t : nil;\n"))
    (('+ x y)
     (format port "{ intptr_t tmp;\n")
     (compile x locals closed sets)
     (format port "tmp = fixnum_value(R);\n")
     (compile y locals closed sets)
     (format port "R = make_fixnum(tmp + fixnum_value(R)); }\n"))
    (('- x y)
     (format port "{ intptr_t tmp;\n")
     (compile x locals closed sets)
     (format port "tmp = fixnum_value(R);\n")
     (compile y locals closed sets)
     (format port "R = make_fixnum(tmp - fixnum_value(R)); }\n"))
    ;;
    ((fn . args)
     (do ((xs args (cdr xs)))
         ((null? xs))
       (compile (car xs) locals closed sets)
       (format port "push(R);\n"))
     (compile fn locals closed sets)
     (format port "R = (*(pf_t)(R->v[0]))(R, ~S);\n" (length args)))
    (_
     (cond ((symbol? expr)
            (format port "R = ")
            (gen-val-var expr locals closed sets)
            (format port ";\n"))
           ((integer? expr)
            (format port "R = make_fixnum(~S);\n" expr))
           (else
            (error "invalid expr" expr))))))

関数適用の部分には組み込み関数の処理を埋め込んであります.大した手間ではないのですが,スコープも無視しています. 気になるようでしたら直してください.

やることはあと3つです.まずシンボルテーブルを出力します.

(define (generate-symbol-vars)
  (let ((n (hash-table-num-entries symbol-ht)))
    (let ((v (make-vector n)))
      (hash-table-for-each
       symbol-ht
       (lambda (s id) (vector-set! v id s)))
      (format port "const char *symtbl[] = {\n")
      (dotimes (i n)
        (format port "    \"~S\",\n" (vector-ref v i)))
      (format port "};\n"))))

つづいて lambda 式に対応する関数を生成します.事前にプロトタイプを出しますが省略します. 本体の入り口で,sets を参照し boxing を行います.

PROLOGUE, EPILOGUE はフレーム作成,解放のマクロです.

(define (generate-lambda-func id closed sets x)
  (match x
    (('lambda ps body)
     (format port "id lambda_~S(id self, int nargs)\n{\nPROLOGUE;\n" id)
     ;; boxing
     (do ((i 0 (+ i 1))
          (ps ps (cdr ps)))
         ((null? ps))
       (let ((p (car ps)))
         (when (memq p sets)
           (format port "argv[~S] = box(argv[~S]);\n" i i))))
     ;; body
     (compile body ps closed sets)
     ;; epilogue
     (format port "EPILOGUE;\n}\n\n"))))

最後は main 関数を作っておわりです.関数 compile で式のトップレベルを評価するコードを生成するだけです.

Runtime

Runtime で用意したのはごみ集めを含むメモリ管理と printer です.printer はかんたんなのでごみ集めだけ示します.アルゴリズムは mark & sweep です.

できるだけかんたんにしようと思ったので,次のようにしました. ヒープ用に大きめのメモリブロックを用意しておいて,最初は必要な分だけ前から切り出して使っていきます.

#define HEAP_SIZE       20000
#define MAX_OBJECT_SIZE 20

intptr_t heap[HEAP_SIZE];
intptr_t *heap_cur;
id free_list[MAX_OBJECT_SIZE];

最後まで使いきってしまったら,ごみ集めをします.ごみを回収するときは,サイズごとに分けてフリーリストを作ることにしました.これ以降はフリーリストから取り出して割りあてます.もし欲しいサイズのブロックがなければまたごみ集めをして,それでもなければあきらめます.

id alloc(unsigned n)
{
    id p;
    if (free_list[n]) {
        p = free_list[n];
        free_list[n] = p->v[0];
    } else {
        size_t size = (sizeof(struct object) + n * sizeof(id) + sizeof(intptr_t) - 1) / sizeof(intptr_t);
        if (heap_cur + size <= heap + HEAP_SIZE) {
            p = (id)heap_cur;
            heap_cur += size;
            p->mark = 0;
            p->size = n;
        } else {
            gc();
            if (free_list[n]) {
                p = free_list[n];
                free_list[n] = p->v[0];
            } else {
                printf("exhausted\n");
                exit(1);
            }
        }
    }
    return p;
}

マークのルートになるのはスタックと CP だけです.

void gc(void)
{
    int i;
    id *p;

    for (i = 0; i < MAX_OBJECT_SIZE; ++i)
      free_list[i] = NULL;

    mark(CP);
    for (p = STACK; p < SP; ++p)
      mark(*p);

    sweep();
}

マークは再帰を使えばかんたんです.一点,クロージャの先頭には関数へのポインタが入っていて,これはオブジェクトではないのでスキップする必要があります.フラグ closure で識別できます.

void mark(id p)
{
    int i;
    while (objectp(p)) {
        if (p->mark)
          break;
        p->mark = 1;
        if (p->size == 0)
          break;
        for (i = p->closure ? 1 : 0; i < p->size - 1; ++i) {
            mark(p->v[i]);
        }
        p = p->v[i];
    }
}

sweep ではヒープを前から走査して,マークのついていないブロックをフリーリストにつないでいきます.

void sweep(void)
{
    intptr_t *p;
    id q;
    for (p = heap; p < heap_cur; ) {
        q = (id)p;
        if (q->mark) {
            q->mark = 0;
        } else {
            q->v[0] = free_list[q->size];
            free_list[q->size] = q;
        }
        p += (sizeof(struct object) + q->size * sizeof(id) + sizeof(intptr_t) - 1) / sizeof(intptr_t);
    }
}

非効率な reverse, append ペアです. リストは cons で作ります.letrec は set! で作りました.

((lambda (rev app)
   (begin
     (set! rev
           (lambda (x)
             (if (eq? x (quote ()))
                 (quote ())
                 (app (rev (cdr x)) (cons (car x) (quote ()))))))
     (set! app
           (lambda (x y)
             (if (eq? x (quote ()))
                 y
                 (app (rev (cdr (rev x))) (cons (car (rev x)) y)))))
     (rev (cons 0 (cons 1 (cons 2 (cons 3
            (cons 4 (cons 5 (cons 6 (cons 7
              (cons 8 (cons 9 (cons 'A (cons 'B
                (cons 'C (cons 'D '())))))))))))))))))
 '() '())

変換すると次のようになります.インデントは emacs でつけました.

#include "d9.h"

const char *symtbl[] = {
    "nil",
    "t",
    "A",
    "B",
    "C",
    "D",
};

id lambda_2(id self, int nargs);
id lambda_1(id self, int nargs);
id lambda_0(id self, int nargs);

id lambda_2(id self, int nargs)
{
    PROLOGUE;
    R = argv[0];
    push(R);
    R = nil;
    R = (R == pop()) ? symbol_t : nil;
    if (R != nil) {
        R = argv[1];
    } else {
        R = argv[0];
        push(R);
        R = (CP->v[1])->v[0];
        R = (*(pf_t)(R->v[0]))(R, 1);
        R = R->v[1];
        push(R);
        R = (CP->v[1])->v[0];
        R = (*(pf_t)(R->v[0]))(R, 1);
        push(R);
        R = argv[0];
        push(R);
        R = (CP->v[1])->v[0];
        R = (*(pf_t)(R->v[0]))(R, 1);
        R = R->v[0];
        push(R);
        R = argv[1];
        push(R);
        R = cons();
        push(R);
        R = (CP->v[2])->v[0];
        R = (*(pf_t)(R->v[0]))(R, 2);
    }
    EPILOGUE;
}

id lambda_1(id self, int nargs)
{
    PROLOGUE;
    R = argv[0];
    push(R);
    R = nil;
    R = (R == pop()) ? symbol_t : nil;
    if (R != nil) {
        R = nil;
    } else {
        R = argv[0];
        R = R->v[1];
        push(R);
        R = (CP->v[1])->v[0];
        R = (*(pf_t)(R->v[0]))(R, 1);
        push(R);
        R = argv[0];
        R = R->v[0];
        push(R);
        R = nil;
        push(R);
        R = cons();
        push(R);
        R = (CP->v[2])->v[0];
        R = (*(pf_t)(R->v[0]))(R, 2);
    }
    EPILOGUE;
}

id lambda_0(id self, int nargs)
{
    PROLOGUE;
    argv[0] = box(argv[0]);
    argv[1] = box(argv[1]);
    R = make_closure(2);
    R->v[0] = (id)&lambda_1;
    R->v[1] = argv[0];
    R->v[2] = argv[1];
    argv[0]->v[0] = R;
    R = make_closure(2);
    R->v[0] = (id)&lambda_2;
    R->v[1] = argv[0];
    R->v[2] = argv[1];
    argv[1]->v[0] = R;
    R = make_fixnum(0);
    push(R);
    R = make_fixnum(1);
    push(R);
    R = make_fixnum(2);
    push(R);
    R = make_fixnum(3);
    push(R);
    R = make_fixnum(4);
    push(R);
    R = make_fixnum(5);
    push(R);
    R = make_fixnum(6);
    push(R);
    R = make_fixnum(7);
    push(R);
    R = make_fixnum(8);
    push(R);
    R = make_fixnum(9);
    push(R);
    R = symbol(2);
    push(R);
    R = symbol(3);
    push(R);
    R = symbol(4);
    push(R);
    R = symbol(5);
    push(R);
    R = nil;
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = cons();
    push(R);
    R = (argv[0])->v[0];
    R = (*(pf_t)(R->v[0]))(R, 1);
    EPILOGUE;
}

int main()
{
    id R;
    init();
    R = nil;
    push(R);
    R = nil;
    push(R);
    R = make_closure(0);
    R->v[0] = (id)&lambda_0;
    R = (*(pf_t)(R->v[0]))(R, 2);
    write_sexpr(R);
    printf("\n");
    epilogue();
    return 0;
}

実行時間は Core2Duo 2.4GHz で 4.5秒 (run: 4.0秒, gc: 0.5秒) でした. SBCL で 2.0秒 なのでまあまあかなと思います.SyncStitch に内蔵している Razor Scheme では 2.2秒 でした.

こうやって小さいものが動き始めるといろいろ拡張したくなります.すぐにでもできる拡張や最適化はいろいろありますしね.

おまけ

変数 SP と CP をレジスタ変数にしてみました.

register id *SP asm("r15");
register id CP asm("r14");

結果,実行時間は 2.7秒 (run 2.2秒, gc 0.5秒) となりました.

2015/03/30
© 2013,2014,2015 PRINCIPIA Limited