3imp ヒープベース compile/VM で階乗計算

の続きです。 3imp のヒープベース compile/VM にプリミティブ摘要を追加して階乗計算をやってみます。 ただし、 compile は式の並び対応に変更したものを使うことにします。 次のように、 環境を作成しておき、 fact を階乗計算の手続きに束縛します。 さらに、 loop を内部手続きに束縛します。 このコンパイラVM は set! しか使えないので、 set! したい fact 変数をあらかじめダミーの値に束縛しておきます。

(define environment `(((fact) . (#f)) ((= * -) . (,= ,* ,-))))

(evaluate '(set! fact (lambda (n)
            ((lambda (loop)
              (set! loop (lambda (n r)
               (if (= n 0)
                r
                (loop (- n 1) (* n r)))))
              (loop n 1)) #f)))
           environment)

(evaluate '(fact 5) environment) ;=> 120

2017 年 12 月 11 日修正 コンパイル時と実行時の環境を 3imp と同じにしました。

3imp の compile/VM は CEK マシンなので、 プリミティブを摘要すると即座に return するように仮想マシンの apply 命令に動作を追加します。 いくつか VM の命令を変更しており、 refer 命令と assign 命令は変数をドット対だったのをスタックベース compile/VM と同じにしてフラットなリストにしています。 frame 命令ではコードの順番を入れ替えてあり、 2番目のコードで継続を作ってから 1番目のコードを実行します。 VM に命令を一つ追加しています。 ((lambda X . N) . M) のラムダ形式部分を (close Cn (apply))コンパイルしますが、 このコードだとクロージャを作って即座に廃棄します。 追加した extend 命令はこの無駄を省くためのもので、 クロージャを作ることなく環境にフレームを追加する働きをします。 close 命令と extend 命令にフィールドを追加し、 最初のフィールドにパラメータの個数を与えています。 VMクロージャにこの個数を記録し、 apply 命令で環境にフレームを追加する際に実引数と仮引数の個数が一致するかどうかチェックするように機能を追加しています。

(use util.match)
(use srfi-1)

; R7RS 用
(define primitive? procedure?)

(define (compile exp env next)
 (match exp
  ((? symbol? var)
   (compile-lookup var env (lambda (level loc) `(refer ,level ,loc ,next))))
  (('quote obj) `(constant ,obj, next))
  (('lambda vars . body)
   (let ((n (length vars))
         (x (compile-seq body (compile-extend env vars) '(return))))
    (if (eq? (car next) 'apply)
     `(extend ,n ,x)
     `(close  ,n ,x ,next))))
  (('if test exp1 exp2)
   (compile test env `(test ,(compile exp1 env next) ,(compile exp2 env next))))
  (('set! var exp1)
   (compile exp1 env
    (compile-lookup var env (lambda (level loc) `(assign ,level ,loc ,next)))))
  (('call/cc exp1)
   (compile-frame `(conti (argument ,(compile exp1 env '(apply)))) next))
  (('begin) `(constant #f ,next))
  (('begin exp1 . _) (compile-seq (cdr exp) env next))
  ((fn . args)
   (compile-frame
    (fold (lambda (arg x) (compile arg env `(argument ,x)))
          (compile fn env '(apply))
          args)
    next))
  (_ `(constant ,exp ,next))))

compile-seq は lambda 形式の本体のように、 式が 1 個以上ある式の並びをコンパイルします。

(define (compile-seq body env next)
 (if (pair? body)
  (compile (car body) env (compile-seq (cdr body) env next))
  next))

compile-frame は末尾呼び出しを除いて、 継続を作成するコードを作ります。

(define (compile-frame x next)
 (if (eq? (car next) 'return)
  x
  `(frame ,x ,next)))

compile-extend コンパイル時環境にフレームを一段分追加します。

(define (compile-extend env vars) (cons vars env))

compile-lookup には 3imp のスタックベース compile/VM のものを使っています。

(define (compile-lookup var env kont)
 (let loop-rib ((env env) (level 0))
  (if (pair? env)
   (let loop-frame ((vars (car env)) (loc 0))
    (cond
     ((null? vars) (loop-rib (cdr env) (+ level 1)))
     ((eq? (car vars) var) (kont level loc))
     (else (loop-frame (cdr vars) (+ loc 1))) ))
   (error "3IMP HEAPBASED COMPILE -- VARIABLE NOT FOUND" var) )))

続いて仮想マシンの実行手続きを修正します。 いくつか変更しています。 apply 手続きでは、 プリミティブ摘要をおこない、 その際は直ちに return 命令を次回におこなうようにします。 クロージャ適用時に環境に新しいフレームを追加します。 その際に、 実引数と仮引数の個数が一致するチェックを追加してあります。 extend 命令は、 ((lambda X . M) N) の良くあるパターンを無駄なく処理できるように追加してあります。

(define (VM a x e r s)
 (match x
  (('halt)                a)
  (('refer level loc x1)  (VM (list-ref (list-ref e level) loc) x1 e r s))
  (('constant obj x1)     (VM obj x1 e r s))
  (('close n body x1)     (VM (list n body e) x1 e r s))
  (('test x1 x2)          (VM a (if a x1 x2) e r s))
  (('assign level loc x1) (VM (list-set! (list-ref e level) loc a) x1 e r s))
  (('conti x1)            (VM `(1 (nuate ,s 0 0) ()) x1 e r s))
  (('nuate s1 level loc)  (VM (list-ref (list-ref e level) loc) '(return) e r s1))
  (('frame x1 ret)        (VM a x1 e '() (list ret e r s)))
  (('argument x1)         (VM a x1 e (cons a r) s))
  (('apply) (match a
   ((n1 x1 e1)            (VM a x1 (extend e1 n1 r) '() s))
   ((? primitive? fn) (match s ((x1 e1 r1 s1)
                          (VM (apply fn r) x1 e1 r1 s1))))))
  (('return) (match s ((x1 e1 r1 s1)
                          (VM a x1 e1 r1 s1))))
  ; (extend n1 x1) is equivalent for (close n1 x1 (apply))
  (('extend n1 x1)        (VM a x1 (extend e n1 r) '() s))))

extend 手続きは、 その名のとおり VM 用の仮想マシンに環境フレームを追加します。

(define (extend e n r)
 (if (= n (length r))
  (cons r e)
  (error "3IMP HEAP-BASED VM APPLY -- ARGUMENTS" n (length r))))

evaluate 手続きは、 環境をコンパイル時環境と実行時環境に分け、 S 式をコンパイルして VM で実行します。

(define (evaluate exp env)
 (let ((compile-env (map car env))
       (runtime-env (map cdr env)) )
  (VM '() (compile exp compile-env '(halt)) runtime-env '() '()) ))