Think Stitch
PRINCIPIA  最近の更新


LispKit Lisp 2 - SECD 機械 in C

LispKit Lisp の SECD 機械を C 言語で書いてみました.前回の記事はこちらです.

データ構造

まずデータ構造を決めます.LispKit Lisp のデータ型はシンボル,整数,コンス (ペア)の3つです.整数は即値(fixnum)だけにします.シンボルはゴミ集めで回収 しないので,シンボル名(文字列)を連続した領域に NUL で区切って並べることにしま す.これをシンボル領域とでも呼ぶことにしましょうか.シンボル領域の先頭から文 字列の先頭までのオフセットをポインタに埋め込み,タグをつけてシンボルを表すこ とにします.シンボル領域は oblist を兼ねることにします.シンボルを作るときに は既存かどうかシンボル領域を線型探索して調べます.

コンスセルは次のように定義します.これを適当な数だけ用意してリンクでつなぎ, フリーリストにしておきます.

typedef struct pair *ptr_t;
struct pair {
  ptr_t car;
  ptr_t cdr;
};

ポインタの構造,つまりタグの構造を次のようにしました.

MSB                    LSB
aaaaaaaaaaaaaaaaaaaaaa 000   cons
iiiiiiiiiiiiiiiiiiiiii 010   symbol
nnnnnnnnnnnnnnnnnnnnnn 110   fixnum

bit 0 はゴミ集めでマークに使います.bit 1 が ATOM かどうかを示します.bit 2 でシンボルと整数を区別します.

マークビットは car と cdr で2つ取れます.1つはコンスセルのマーク用,もう1つはポインタ逆転アルゴリズムを使うときに使います.

データ構造に関するマクロと変数を定義しておきます.

#define MARK_BIT           0x01
#define ATOM_BIT           0x02
#define FIXNUM_BIT         0x04

#define SYMBOL_AREA_SIZE   4096
#define NUM_PAIRS         12000

#define mark_p(p) (((intptr_t)(p) & MARK_BIT) != 0)
#define pair_p(p) (((intptr_t)(p) & (ATOM_BIT | FIXNUM_BIT)) == 0)
#define fixnum_p(p) (((intptr_t)(p) & (ATOM_BIT | FIXNUM_BIT)) == (ATOM_BIT | FIXNUM_BIT))
#define symbol_p(p) (((intptr_t)(p) & (ATOM_BIT | FIXNUM_BIT)) == ATOM_BIT)
#define fixnum_value(p) ((intptr_t)(p) >> 3)
#define symbol_index(p) ((intptr_t)(p) >> 3)
#define make_fixnum(k) ((ptr_t)(((intptr_t)(k) << 3) | (ATOM_BIT | FIXNUM_BIT)))
#define make_symbol_ptr(i) ((ptr_t)(((intptr_t)(i) << 3) | ATOM_BIT))
#define car(p) ((p)->car)
#define cdr(p) ((p)->cdr)

struct pair pairs[NUM_PAIRS];
char symbol_area[SYMBOL_AREA_SIZE];

SECD 機械のレジスタ

SECD 機械の4つのレジスタと,作業用のレジスタ W を用意します.

ptr_t S, E, C, D;
ptr_t W;

SECD 機械の命令

SECD 機械の命令は整数で表します.enum で名前をつけておきます.

enum VM_INST {
  LD,   LDC,  LDF,  AP,   RTN,  DUM,  RAP,  SEL,  JOIN,
  SOR,  NON,
  CAR,  CDR,  CONS, ATOM, EQ,  SYMBOLP,  INTEGERP,  LESS,
  ADD,  SUB,  MUL,  DIV,  REM,
};

SECD 機械

Scheme で書いた vm を単純に C言語に変換するだけです.ただし途中でゴミ集め が発生する可能性があるので,使用中のコンスセルが回収されないように気をつける 必要があります.使用中のセルが4つのレジスタのどれかから間接的にたどれるように するか,それが無理な場合は作業用レジスタ W を使います.

void vm(void)
{
    while (1) {
        if (C == nil) {
            if (D == nil) {
                return;
            } else {
                /* RTN */
                S = cons(car(S), car(D));
                ptr_t p = cdr(D);
                E = car(p);
                p = cdr(p);
                C = car(p);
                D = cdr(p);
            }
        } else {

            switch (fixnum_value(car(C))) {
            case LD:
              {
                  ptr_t p = cdr(C);
                  S = cons(locate(car(p)), S);
                  C = cdr(p);
              }
              break;

            case LDC:
              {
                  ptr_t p = cdr(C);
                  S = cons(car(p), S);
                  C = cdr(p);
              }
              break;

            case LDF:
              {
                  ptr_t p = cdr(C);
                  S = cons(nil, S);
                  S->car = cons(car(p), E);
                  C = cdr(p);
              }
              break;

            case AP:
              {
                  D = cons(cdr(C), D);
                  D = cons(E, D);
                  ptr_t ce = car(S);
                  C = car(ce);
                  E = cdr(ce);
                  ptr_t p = cdr(S);
                  ptr_t v = car(p);
                  E = cons(v, E);
                  D = cons(cdr(p), D);
                  S = nil;
              }
              break;

            case RTN:
              {
                  S = cons(car(S), car(D));
                  ptr_t p = cdr(D);
                  E = car(p);
                  p = cdr(p);
                  C = car(p);
                  D = cdr(p);
              }
              break;

            case DUM:
              {
                  C = cdr(C);
                  E = cons(nil, E);
              }
              break;

            case RAP:
              {
                  D = cons(cdr(C), D);
                  D = cons(cdr(E), D);
                  ptr_t ce = car(S);
                  C = car(ce);
                  E = cdr(ce);
                  ptr_t p = cdr(S);
                  E->car = car(p);
                  D = cons(cdr(p), D);
                  S = nil;
              }
              break;

            case SEL:
              {
                  W = cdr(C);
                  if (car(S) != nil) {
                      C = car(W);
                      W = cdr(W);
                  } else {
                      W = cdr(W);
                      C = car(W);
                  }
                  S = cdr(S);
                  D = cons(cdr(W), D);
                  W = nil;
              }
              break;

            case JOIN:
              {
                  C = car(D);
                  D = cdr(D);
              }
              break;

            case CAR:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  if (pair_p(p)) {
                      S = cons(car(p), cdr(S));
                  } else {
                      error("CAR: not pair", p);
                  }
              }
              break;

            case CDR:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  if (pair_p(p)) {
                      S = cons(cdr(p), cdr(S));
                  } else {
                      error("CDR: not pair", p);
                  }
              }
              break;

            case CONS:
              {
                  C = cdr(C);
                  W = S;
                  S = cons(nil, cdr(cdr(S)));
                  S->car = cons(car(W), car(cdr(W)));
                  W = nil;
              }
              break;

            case ATOM:
              {
                  C = cdr(C);
                  if (!pair_p(car(S))) {
                      S = cons(sym_t, cdr(S));
                  } else {
                      S = cons(nil, cdr(S));
                  }
              }
              break;

            case EQ:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  ptr_t q = cdr(S);
                  if (p == car(q)) {
                      S = cons(sym_t, cdr(q));
                  } else {
                      S = cons(nil, cdr(q));
                  }
              }
              break;

            case SYMBOLP:
              {
                  C = cdr(C);
                  if (symbol_p(car(S))) {
                      S = cons(sym_t, cdr(S));
                  } else {
                      S = cons(nil, cdr(S));
                  }
              }
              break;

            case INTEGERP:
              {
                  C = cdr(C);
                  if (fixnum_p(car(S))) {
                      S = cons(sym_t, cdr(S));
                  } else {
                      S = cons(nil, cdr(S));
                  }
              }
              break;

            case LESS:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  ptr_t q = cdr(S);
                  ptr_t r = car(q);
                  if (!fixnum_p(p) || !fixnum_p(r)) {
                      error("LESS: not integer", p, r);
                  }
                  if (fixnum_value(r) < fixnum_value(p)) {
                      S = cons(sym_t, cdr(q));
                  } else {
                      S = cons(nil, cdr(q));
                  }
              }
              break;

            case ADD:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  ptr_t q = cdr(S);
                  ptr_t r = car(q);
                  if (!fixnum_p(p) || !fixnum_p(r)) {
                      error("ADD: not integer", p, r);
                  }
                  S = cons(make_fixnum(fixnum_value(r) + fixnum_value(p)), cdr(q));
              }
              break;

            case SUB:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  ptr_t q = cdr(S);
                  ptr_t r = car(q);
                  if (!fixnum_p(p) || !fixnum_p(r)) {
                      error("SUB: not integer", p, r);
                  }
                  S = cons(make_fixnum(fixnum_value(r) - fixnum_value(p)), cdr(q));
              }
              break;

            case MUL:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  ptr_t q = cdr(S);
                  ptr_t r = car(q);
                  if (!fixnum_p(p) || !fixnum_p(r)) {
                      error("MUL: not integer", p, r);
                  }
                  S = cons(make_fixnum(fixnum_value(r) * fixnum_value(p)), cdr(q));
              }
              break;

            case DIV:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  ptr_t q = cdr(S);
                  ptr_t r = car(q);
                  if (!fixnum_p(p) || !fixnum_p(r)) {
                      error("DIV: not integer", p, r);
                  }
                  S = cons(make_fixnum(fixnum_value(r) / fixnum_value(p)), cdr(q));
              }
              break;

            case REM:
              {
                  C = cdr(C);
                  ptr_t p = car(S);
                  ptr_t q = cdr(S);
                  ptr_t r = car(q);
                  if (!fixnum_p(p) || !fixnum_p(r)) {
                      error("REM: not integer", p, r);
                  }
                  S = cons(make_fixnum(fixnum_value(r) % fixnum_value(p)), cdr(q));
              }
              break;

            default:
              error("unknown instruction: %ld\n", fixnum_value(car(C)));
            }
        }
    }
}

ゴミ集め

ゴミ集めはマーク&スイープにしました.SECD 機械の4つのレジスタと作業用レジ スタからたどれるコンスをマークして,次にコンス領域を走査してゴミを回収します.

void gc(void)
{
    mark(S);
    mark(E);
    mark(C);
    mark(D);
    mark(W);
    sweep();
    if (free_list == nil) {
        error("pair exhausted");
    }
}

かんたんにするために,マークは再帰を使います.

void mark(ptr_t p)
{
    while (pair_p(p) && !mark_p(car(p))) {
        mark_pair(p);
        mark((ptr_t)((intptr_t)car(p) & ~MARK_BIT));
        p = (ptr_t)((intptr_t)cdr(p) & ~MARK_BIT);
    }
}

マークが済んだらコンス領域を走査します.マークがついていたら消し,ついていなかったらフリーリストにつなぎます.

void sweep(void)
{
    int i;
    free_list = nil;
    for (i = 0; i < NUM_PAIRS; ++i) {
        if (mark_p(pairs[i].car)) {
            unmark_pair(&pairs[i]);
            unmark_atom(&pairs[i]);
        } else {
            pairs[i].car = nil;
            pairs[i].cdr = free_list;
            free_list = &pairs[i];
        }
    }
}

main

細かいところは省略しますが,残りの大物としては S式の読み書きをする関数 read_sexpr と write_sexpr を用意しました.

SECD 機械は起動するとまずコンス領域とシンボル領域を初期化します.コンスはフリーリストにつなぎ,シンボル領域には nil と t だけ登録しておきます.

次にコンパイルされたコードを read_sexpr で読み込みます.そして SECD 機械で実行し,結果を write_sexpr で表示します.結果はスタック S の先頭にあります.

int main(int argc, char *argv[])
{
    FILE *fp;

    init();
    fp = fopen(argv[1], "r");
    if (fp == NULL) {
        fprintf(stderr, "cannot open %s\n", argv[1]);
        return 1;
    }
    C = read_sexpr(fp);
    fclose(fp);

    S = nil;
    E = nil;
    D = nil;
    vm();
    write_sexpr(car(S));
    printf("\n");
    return 0;
}

実行例

前回も使った効率の悪い append と reverse のペアを使います.

(letrec ((rev (lambda (x)
                (if (atom x)
                    '()
                    (app (rev (cdr x))
                         (cons (car x) '())))))
         (app (lambda (x y)
                (if (atom x)
                    y
                    (app (rev (cdr (rev x)))
                         (cons (car (rev x)) y))))))
  (rev '(0 1 2 3 4 5 6 7)))

SECD 機械の命令コードを整数にするために,定義を以下のように変えます.

(define LD 0)
(define LDC 1)
(define LDF 2)
(define AP 3)
(define RTN 4)
......

コンパイルするとこうなります.

(5 1 () 2 (0 (0 . 0) 14 7 (0 (0 . 1) 8) (1 () 0 (0 . 1) 1 () 0 (0 . 0)
 13 0 (1 . 0) 3 11 13 13 1 () 1 () 0 (0 . 0) 13 0 (1 . 0) 3 12 13 0
 (1 . 0) 3 13 0 (1 . 1) 3 8) 4) 13 2 (0 (0 . 0) 14 7 (1 () 8) (1 ()
 1 () 0 (0 . 0) 11 13 13 1 () 0 (0 . 0) 12 13 0 (1 . 0) 3 13 0 (1 . 1)
 3 8) 4) 13 2 (1 () 1 (0 1 2 3 4 5 6 7) 13 0 (0 . 0) 3 4) 6)

これをファイル test.secd に書いて,SECD 機械を実行すると計算できます.

$ ./secd test.secd
(7 6 5 4 3 2 1 0)
2015/03/22
© 2013,2014,2015 PRINCIPIA Limited