Scheme Compiler の勉強(15) - 小まとめ

LLVM 用 scheme compiler の勉強をしています。ようやく "Compilers: Backend to Frontend and Back to Front Again" の 1.3 まで終了（自分は時間のないおっさんなので時間が掛かっているけど、やる気とセンスのある人なら一日二日くらいでゆうゆういけると思います）。わたし同様に勉強したい人のために gauche 版で一応動く test-driver.scm を貼付けておきます。まだいくらでも奇麗にしたり改良する余地はあります。
この他、 runtime.c は何をやっているか理解するため少しずつ書いた方が良いと思うので自分で作って下さい。 compiler.scm は作者のサイトから compiler-tutorial-tests-2006-10-11.tar を入手し、 README を読んで少しずつ書いていけばいいと思います（わたしはまだ 1.3 以降はほとんど読んでいませんので、とんちんかんなことをやっている可能性も十分ありますのでご注意！また LLVM については相当怪しい知識で書いています）。

LLVM に関しては build のところで埋め込んでいますが、 llvm-as, llc, llvm-gcc を使っています。実行ファイルができるまでの流れとしては、以下のとおりです。

• 自作のコンパイラで LLVM IR をファイルに出力（今のところ単なる文字列として）(run-compile)(ファイルstst.s)
• llvm-as (http://llvm.org/cmds/llvm-as.html)が LLVM IR を bitcode に変換 (build)(ファイル stst.bc)
• (opt で bitcode を最適化。)
• llc で LLVM IR をコンパイル。ここでようやくターゲットとなるマシンのアセンブラになります。(ファイルstst.n.s)
• llvm-gcc(単にgcc でも良いかも)で、stst.n.s と runtime.c をコンパイルし、実行ファイルができます。

(use gauche.test)
(use gauche.parameter)
(use file.util)

(define (fxzero? x) (and (fixnum? x) (zero? x)))

(define all-tests '())

(define-syntax add-tests-with-string-output
  (syntax-rules (=>)
    [(_ test-name [expr => output-string] ...)
     (set! all-tests
        (cons
           '(test-name [expr string  output-string] ...)
            all-tests))]))

(define (test-one test-id test-data)
  (let ([expr (car test-data)]
        [type (cadr test-data)]
        [out  (caddr test-data)])
    (run-compile expr)
    (build)
    (execute)
    (test* test-id out (file->string "stst.out"))))

(define (build)
  (unless (zero? (sys-system "llvm-as -f -o stst.bc stst.s"))
	  (errorf "fail to llvm-as to generate stst.bc"))
  (unless (zero? (sys-system "llc -f -o stst.n.s stst.bc"))
	  (errorf "fail to llc to generate stst.n.s"))
  ;; opt
  (unless (zero? (sys-system "opt -std-compile-opts stst.bc -f -o stst.opt.bc"))
   	  (error "fail to llc to generate stst.opt.bc"))
  (unless (zero? (sys-system "llc -f -o stst.opt.s stst.opt.bc"))
   	  (error "fail to llc to generate stst.opt.s"))
;;  (unless (zero? (sys-system "llvm-gcc -o stst runtime.c stst.n.s"))
  (unless (zero? (sys-system "llvm-gcc -o stst runtime.c stst.opt.s"))
	  (errorf "could not build target")))

(define (execute)
  (unless (fxzero? (sys-system "./stst > stst.out"))
	  (errorf "produced program exited abnormally")))

(define (build-program expr)
   (run-compile expr)
   (build))

(define (test-all)
  (test-start "compiler test")
  (let f ([i 0] [ls (reverse all-tests)])
    (if (null? ls)
        (test-end)
        (let ([x (car ls)] [ls (cdr ls)])
          (let* ([test-name (car x)] 
                 [tests (cdr x)]
                 [n (length tests)])
	    (test-section test-name)
            (let g ([i i] [tests tests])
              (cond
                [(null? tests) (f i ls)]
                [else
                 (test-one i (car tests))
                 (g (+ i 1) (cdr tests))])))))))

(define compile-port
  (make-parameter
    (current-output-port)
    (lambda (p)
       (unless (output-port? p) 
         (errorf "not an output port ~s" p))
       p)))

(define (run-compile expr)
  (let ([p (open-output-file "stst.s" :if-exists :supersede)])
    (parameterize ([compile-port p])
       (compile-program expr))
    (close-output-port p)))

(define (emit . args)
  (apply format (compile-port) args)
  (newline (compile-port)))