Tociyuki::Diary

■[Scheme]3imp ヒープベース VM をディスプレイ・クロージャで (その 2)

昨日は入れ子リストのクロージャをそのままディスプレイにしただけでした。 ディスプレイ・クロージャ版の VM の動作を追うと、 close 命令で環境をそのまま閉じ込めて、 apply 命令ごとにディスプレイを作成していました。

a (close n1 x1 x) e r s -> (n1 x1 e) x e r s
a (push x x1) e r s -> a x e r (x1 e r s)
a (frame n2 x) e r s -> a x e r1 s                    r1 は (make-vector n2)
(n1 x1 e1) (apply) e' r s -> (n1 x1 e1) x1 e () s     e は (vector-append (vector r) e1)

ところが、 3imp のスタック・ベースのフラット・クロージャの真似をすると、 ベクタの作り直しを close 命令に押し付けることができ、 apply 命令で毎回ベクタを作り直す無駄をなくすことができます。 その場合、 環境 e を先頭のフレーム f とディスプレイ・クロージャ c 内の残りのフレームに分けることになります。 クロージャの先頭に仮引数の個数 n1 と実行コード x1 を書き込んであります。

e = #(#(v0.0 v0.1 ...) #(v1.0 v1.1 ...) ...)
を分けて、
f = #(v0.0 v0.1 ...)、  c = #(n1 x1 #(v1.0 v1.1 ...) ...)

これで close、 push、 frame、 apply 命令による状態遷移が、 次のように変化します。 PASCAL 系とは異なり、 クロージャをあらかじめ作成しておいてからアプリケーションを実行する 2 段がまえを利用した Scheme ならではの無駄省きができます。

a (close n1 x1 x) f c=#(n' x' f2 f3...) r s -> #(n1 x1 f f2 f3...) x f c r s
a (push x x1) f c r s -> a x f c r (x1 f c r s)
a (frame n2 x) f c r s -> a x f c r1 s               r1 は (make-vector n2)
a=#(n1 x1 f f2 f3...) (apply n1) f' c' r s -> a r a () s

evaluate 手続きで VM に与える環境を分割するよう変更します。 自由変数はディスプレイ・クロージャ free に閉じ込めるため、 先頭にダミーの仮引数と実行コードを追加しておきます。

(define (evaluate exp env)
 (let ((compile-env (map car env))
       (free (list->vector (cons* 0 '() (map cdr (cdr env))))) )
  (VM '() (compile exp compile-env '(halt)) (cdar env) free '() '()) ))

VM を変更します。 環境 e を、 f と c に分割した影響で、 refer 命令を f 用の refer-local と c 用の refer-free に分けます。 assign 命令も同様に、 assign-local と assign-free に分けます。 nuate 命令が使う変数は f のフレームを使うので、 refer-local 相当に変更し、 conti 命令でそのような nuate 命令を作ります。 今回、 さらに、 apply 命令のオペランドに実引数の個数を指定するようにして実引数と仮引数の個数比較にかかる手間を少し減らすことにしました。 extend 命令は省略してあります。

(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 j i x1)  (VM (vector-ref (vector-ref c (+ j 2)) i) x1 f c r s))
  (('close n fn x1)      (VM (closure n fn f c) x1 f c r s))
  (('assign-local i x1)  (vector-set! f i a)
                         (VM a x1 f c r s))
  (('assign-free j i x1) (vector-set! (vector-ref c (+ j 2)) i a)
                         (VM a x1 f c r s))
  (('conti x1)           (VM `#(1 (nuate ,s 0) ()) x1 f c r s))
  (('nuate s1 i)         (VM (vector-ref f i) '(return) f c r s1))
  (('push x1 x2)         (VM a x1 f c r (list x2 f c r s)))
  (('frame n1 x1)        (VM a x1 f c (make-vector n1) s))
  (('argument i x1)      (vector-set! r i a)
                         (VM a x1 f c r s))
  (('apply n2) (match a
   (#(n1 x1 _ ...)       (or (= n1 n2) (error "VM APPLY -- ARGUMENT?" n1 n2))
                         (VM a x1 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))))))

closure 手続きでディスプレイ・クロージャを作成します。

; n x f1 #(n' fn' f2 f3...)  -->  #(n x f1 f2 f3...)
(define (closure n x f1 c)
 ;(vector-append (vector n x f1) (vector-copy c 2)))
 (let ((v (make-vector (+ (vector-length c) 1))))
  (vector-set! v 0 n)
  (vector-set! v 1 x)
  (vector-set! v 2 f1)
  (vector-copy! v 3 c 2)
  v))

コンパイラにも refer 命令と assign 命令を分けたそれぞれの命令を生成するように手を入れます。

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

compile-extend、 compile-lookup、 compile-seq、 compile-push の 4 つの手続きは前と同じなので省略します。

Permalink | コメント(0) | トラックバック(0) | 21:26