ヒープベースでフラット・クロージャ VM (その1)

R. Dybvig Three Implementation Models for Scheme (以下 3imp) 第 4 章のフラット・クロージャはスタックベース VM 用に作ってありますが、 フラット・クロージャ自体はヒープベース VM でも利用できる仕組みです。 ヒープベース VM でも、 クロージャ作成時に束縛変数ベクタと自由変数ベクタから変数を拾い出して、 クロージャ用の自由変数ベクタを作る点は同じです。 それだけではなく、 破壊操作を受ける束縛変数を box オブジェクトでくるみ、 複数のクロージャの自由変数ベクタから共用できるようにするところも同じです。

今回も Gauche 専用で compile/VM を書いていきます。 ライブラリには SRFI-111 box と SRFI-113 set を使います。

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

コンパイラの引数に box 化してある変数の集合 boxed を追加します。 変数参照、 ラムダ形式、 変数代入の 3 ヶ所をフラット・クロージャ対応にするため変更します。 変数参照で box になっている変数を unbox するために、 indirect 命令をくっつけます。 代入される変数はすべて box になっているので、 代入命令には indirect に相当する修飾命令は不要です。 フラット・クロージャの自由変数ベクタはフラットの 1 次元ベクタになる点がディスプレイ・クロージャとの違いです。

(define (compile exp env boxed next)
 (match exp
  ((? symbol? var)
   (compile-refer var env
    (if (set-contains? boxed var) `(indirect ,next) next)))     
  (('quote obj) `(constant ,obj ,next))
  (('lambda vars . body) (compile-lambda vars body env boxed next))
  (('if test suc alt)
   (compile test env boxed
    `(test ,(compile suc env boxed next) ,(compile alt env boxed next))))
  (('set! var exp1)
   (compile-lookup var env
    (lambda (i) (compile exp1 env boxed `(assign-local ,i ,next)))
    (lambda (i) (compile exp1 env boxed `(assign-free  ,i ,next)))))
  (('call/cc exp1)
   (compile-push
    `(frame 1 (conti (argument 0 ,(compile exp1 env boxed '(apply 1))))) next))
  (('begin) `(constant #f ,next))
  (('begin exp1 . _) (compile-seq (cdr exp) env boxed next))
  ((fn . args)
   (compile-push
    `(frame ,(length args)
      ,(fold-left-with-index
        (lambda (i arg x) (compile arg env boxed `(argument ,i ,x)))
        (compile fn env boxed `(apply ,(length args)))
        args))
    next) )
  (_ `(constant ,exp ,next))))

compile-seq と compile-push は引数に boxed を加えただけで、 それを除くとディスプレイ・クロージャと同じです。

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

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

ラムダ形式のコンパイル部分は煩雑になるので、 手続きに分離しました。 まず、 ラムダ形式の本体にある自由変数の集合を free に、 set! される束縛変数の集合を sets に作ります。 続いて、 自由変数のリスト free-vars を作ります。 また body コンパイル時用の代入束縛変数集合を body-boxed に作っておきます。 close+apply を合わせて extend 命令を使うコスト上の有利点がなくなってしまったので extend 命令は廃止し、 close 命令だけを生成します。 ラムダ形式をコンパイルすると、 代入束縛変数を box にすげ替える命令列を compile-box でくっつけ、 クロージャにキャプチャするために自由変数を取り込む命令列を compile-free で追加します。

 (define (compile-lambda vars body env boxed next)
  (let ((binds (vars->set vars)))
  (let ((free (find-free body binds))
        (sets (find-sets body binds)))
  (let ((free-vars (set->list free)))
  (let ((env-extended (cons vars free-vars))
        (boxed-extended (set-union sets (set-intersection boxed free))))
   (compile-free free-vars env `(close ,(length vars)
    ,(compile-box sets vars
      (compile-seq body env-extended boxed-extended `(return)))
    ,next)))))))

代入束縛変数を box オブジェクトにすげ替えるのは box 命令です。 compile-box は、 束縛変数のうち代入されるものを対象に box 命令を生成します。

(define (compile-box sets vars next)
 (fold-right-with-index
  (lambda (i var x) (if (set-contains? sets var) `(box ,i ,x) x))
  next vars))

クロージャの作り方は、 自由変数ベクタ用に frame-free 命令で r レジスタを初期化しておき、 argument 命令で自由変数の値をコピーします。 その後、 close 命令で r レジスタを取り込んで、 frame-free 命令開始時点の r レジスタに戻します。 3imp スタックベース VM に倣って、 手続きをベクタにしています。 手続きベクタへ先頭から仮引数個数 n、 本体コード x を格納し、 その後に自由変数の値が並びます。

; r is #(n x free-var-0 free-var-1 ...)
(define (compile-free free-vars env next)
 `(frame-free ,(+ (length free-vars) 2)
   ,(fold-right-with-index
     (lambda (i var x) (compile-refer var env `(argument ,(+ i 2) ,x)))
     next free-vars)))

compile-refer 命令は、 束縛変数か自由変数から変数を束縛しているオブジェクトを読み出します。

(define (compile-refer var env next)
 (compile-lookup var env
  (lambda (i) `(refer-local ,i ,next))
  (lambda (i) `(refer-free  ,i ,next))))

compile-lookup 命令は、 変数 var のありかを env から求め、 束縛変数ベクタからなら kont-local 継続を、 自由変数ベクタからなら kont-free 継続を摘要します。

(define (compile-lookup var env kont-local kont-free)
 (define (find-index frame x got fail)
  (let loop ((frame frame) (n 0))
   (cond
    ((null? frame) (fail))
    ((eq? (car frame) x) (got n))
    (else (loop (cdr frame) (+ n 1))) )))
 (find-index (car env) var kont-local (lambda ()
  (find-index (cdr env) var kont-free (lambda ()
   (error "COMPILE -- VARIABLE NOT FOUND" var) )))))

find-free 手続きで lambda 形式中の自由変数集合を求めます。 phi は空集合です。 find-free 手続きの引数は、 束縛変数集合 binds と lambda 形式の本体である式の並び body です。

(define phi (set eq-comparator))

(define (vars->set vars) (list->set eq-comparator vars))

; (match x (('lambda binds . body) (find-free body (vars->set binds)) )) => free::<set of symbol>
(define (find-free body binds)
 (fold (lambda (exp u)
   (set-union u
    (match exp
     ((? symbol? var) (if (set-contains? binds var) phi (set-adjoin phi var)))
     (('quote obj) phi)
     (('lambda vars . body) (find-free body (set-union (vars->set vars) binds)))
     (((or 'set! 'if 'call/cc 'begin) . body) (find-free body binds))
     ((fn . args) (find-free exp binds))
     (_ phi))))
  phi body))

find-sets 手続きは lambda 形式中で代入を受ける変数の集合を求めます。

; (match x (('lambda binds . body) (find-sets body (vars->set binds)) )) => sets::<set of symbol>
(define (find-sets body binds)
 (if (set-empty? binds)
  phi ; 束縛変数集合が空集合のとき、 この本体に sets に含めるべき代入束縛変数はない。
  (fold (lambda (exp u)
   (set-union u
    (match exp
     ((? symbol? var) phi)
     (('quote obj) phi)
     (('lambda vars . body) (find-sets body (set-difference binds (vars->set vars))))
     (('set! var . body)
      (if (set-contains? binds var)
       (set-adjoin (find-sets body binds) var)
       (find-sets body binds)))
     (((or 'if 'call/cc 'begin) . body) (find-sets body binds))
     ((fn . args) (find-sets exp binds))
     (_ phi))))
   phi body)))

コンパイラでは、 左結合の fold-left と右結合 の fold-right の手続きを使います。

; (fold-left-with-index (lambda (i v x) (list i v x)) '(X) '(a b c))
; => (2 c (1 b (0 a (X))))
(define (fold-left-with-index f x e)
 (let loop ((i 0) (x x) (e e))
  (if (pair? e)
   (loop (+ i 1) (f i (car e) x) (cdr e))
   x)))

; (fold-right-with-index (lambda (i v x) (list i v x)) '(X) '(a b c))
; => (0 a (1 b (2 c (X))))
(define (fold-right-with-index f x e)
 (let next ((i 0) (e e))
  (if (pair? e)
   (f i (car e) (next (+ i 1) (cdr e)))
   x)))

これでコンパイラは終わりです。 続いて VM を定義します。 ディスプレイ・クロージャVM に indirect 命令と frame-free 命令を追加し、 変数参照・代入命令と close 命令をフラット・クロージャ用に変更します。 3imp に合わせて、 フラット・クロージャが自由変数フレームを兼ねています。 フラット・クロージャの先頭 2 スロットは n と body で自由変数フレームではないので、 refer-free と assign-free で場所に 2 を足して自由変数フレームの添字を求めます。

(define (VM a x f c r s)
 (match x
  (('halt)              a)
  (('constant obj x1)   (VM obj x1 f c r s))
  (('test x1 x2)        (VM a (if a x1 x2) f c r s))
  (('refer-local i x1)  (VM (vector-ref f i) x1 f c r s))
  (('refer-free i x1)   (VM (vector-ref c (+ i 2)) x1 f c r s))
  (('indirect x1)       (VM (unbox a) x1 f c r s))
  (('frame-free n x1)   (VM a x1 f c (make-vector n) (cons r s)))
  (('close n fn x1)     (vector-set! r 0 n)
                        (vector-set! r 1 fn)
                        (VM r x1 f c (car s) (cdr s)))
  (('box i x1)          (vector-set! f i (box (vector-ref f i)))
                        (VM a x1 f c r s))
  (('assign-local i x1) (set-box! (vector-ref f i) a)
                        (VM a x1 f c r s))
  (('assign-free i x1)  (set-box! (vector-ref c (+ i 2)) a)
                        (VM a x1 f c r s))
  (('conti x1)          (VM `(1 (nuate ,s 0) ()) x1 f c r s))
  (('nuate s i)         (VM (vector-ref f i) '(return) f c r s))
  (('push x1 x2)        (VM a x1 f c r (cons* x2 f c r s)))
  (('frame n x1)        (VM a x1 f c (make-vector n) s))
  (('argument i x1)     (vector-set! r i a)
                        (VM a x1 f c r s))
  (('apply n2) (match a
   (#(n1 fn _ ...)      (or (= n1 n2) (error "VM APPLY -- ARGUMENT?" n1 n2))
                        (VM a fn r a '() s))
   ((? procedure? fn) (match s ((x1 f1 c1 r1 . s1)
                        (VM (apply fn (vector->list r)) x1 f1 c1 r1 s1))))))
  (('return) (match s ((x1 f1 c1 r1 . s1)
                        (VM a x1 f1 c1 r1 s1))))))

evaluate に引数を一つ増やし、 束縛変数のうち set! される変数をリストアップしておきます。 この sets-vars 引数は集合に変換してから compile で利用します。 事前準備として、 ディスプレイ・クロージャ用の環境を利用できるようにするため、 box 化して環境を破壊操作します。 さらに、 実行時の自由変数フレームの先頭に 2 つダミーを加えてクロージャへ変換します。

(define (evaluate exp env sets-vars)
 (let ((compile-env (cons (caar env) (caadr env)))
       (sets (vars->set sets-vars))
       (runtime-f (cdar env))
       (runtime-c (vector-append (vector 0 '()) (cdadr env))))
  (fix-toplevel-box! compile-env sets runtime-f)
  (VM '() (compile exp compile-env sets '(halt)) runtime-f runtime-c '() '()) ))

束縛変数フレームの box 化手続きでは、 コンパイル時環境から変数を探し、 実行時環境の対応するスロットが box になっていないときは、 box 化します。

(define (fix-toplevel-box! compile-env sets runtime-f)
 (do ((vars (car compile-env) (cdr vars))
      (loc 0 (+ loc 1)))
     ((not (pair? vars)))
  (let ((var (car vars))
        (val (vector-ref runtime-f loc)))
   (and (set-contains? sets var) (not (box? val))
        (vector-set! runtime-f loc (box val))))))

階乗計算をするデモは次のように記述できます。

(define (fact-demo)
 (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)) '())))
  environment '(fact))

 (evaluate '(fact 5) environment '(fact)) )