Tociyuki::Diary RSSフィード

tociyuki による Perl・Ruby・C++・C で書き散らしたコードを中心に、日常雑記も混在 : B  F  twitter  GitHub  CPAN  本館  公開鍵
 | 

2017年12月20日

[]ヒープベースなフラット・クロージャでも letrec

フラット・クロージャ VM でも letrec をサポートしてみます。 方針はディスプレイ・クロージャと同じにします。

  1. letrec のスコープの自由変数を集めたダミー・クロージャを作ります。 その際、 自由変数は実引数と本体の両方から求めます。
  2. ダミー・クロージャを letrec のスコープの自由変数として使うように c レジスタにセットします。
  3. letrec のスコープの束縛変数フレームを作成し、 すべての束縛変数を box にします。
  4. 実引数フレームを作成します。
  5. 実引数を評価して実引数フレームへ格納します。 その際、 実引数がクロージャのとき、 letrec のスコープの束縛変数と自由変数をとりこみます。 束縛変数は box なので、 実引数のクロージャの自由変数も box になります。
  6. 実引数をすべて評価し終えたら、 すべての実引数を実引数フレームから letrec スコープの束縛変数フレームの box に set-box! します。 これで、 実引数のクロージャが取り込んだ box の値も同時に更新されます。

ダミー・クロージャへ自由変数を取り込むのに、 通常のクロージャを作る close 命令を使うことにすると、 close 命令は作ったクロージャを a レジスタに置くので、 それを c レジスタへ移動すると同時に束縛変数フレームを初期化する close-dummy 命令を VM に追加することにします。 さらに、 実引数を束縛変数へ上書きする close-rec 命令も追加します。

 (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)))
   (('close-dummy n x1)  (VM a x1 (local-dummy n) a r s))           ;+
   (('close-rec x1)      (local-copy! f r)                          ;+
                         (VM a x1 f c '() 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))))))

close-dummy 命令は local-dummy 手続きで実引数の個数分の box で埋めた束縛変数フレームを作成します。

 (define (local-dummy n)
  (let ((v (make-vector n)))
   (do ((i 0 (+ i 1)))
       ((= i n) v)
    (vector-set! v i (box #f)))))

close-rec 命令は local-copy! 手続きで実引数を束縛変数へセットします。

 (define (local-copy! f r)
  (do ((i 0 (+ i 1)))
      ((= i (vector-length r)))
   (set-box! (vector-ref f i) (vector-ref r i))))

letrec をコンパイルできるようにします。 ついでに実引数のコンパイル命令列を生成する compile-arg 手続きを作っておいて、 アプリケーションもそれを使うようにするのは、 これまでの他の VM の letrec 対応化と同じです。

 (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))
   (('letrec ((vars args) ...) . body)                          ;+
    (compile-letrec vars args 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)))
     (lambda (t) (error "COMPILE -- UNAVAILABLE set! GLOBAL" var)) ))
   (('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) ,(compile-arg args env boxed        ;!
       (compile fn env boxed `(apply ,(length args)))))         ;!
     next))
   (_ `(constant ,exp ,next))))

 (define (compile-arg args env boxed next)                      ;+
  (fold-left-with-index                                         ;+
   (lambda (i arg x) (compile arg env boxed `(argument ,i ,x))) ;+
   next args))                                                  ;+

compile-letrec は自由変数を実引数と本体の両方から求めます。 束縛変数はすべて box にして set! に備えるので、 sets 集合を求める必要がなくなります。 さらに、 束縛変数集合 binds を sets 集合の代わりに使って実引数と本体をコンパイルします。 close 命令の直後に close-dummy 命令を置き、 実引数の評価に備えます。 そして、 実引数のコンパイルを本体と同じ環境でおこないます。 実引数の評価の直後に close-rec 命令を置いて、 VM に束縛変数へ実引数をセットさせるようにします。 その後に、 コンパイルした本体をつなげます。

 (define (compile-letrec vars args body env boxed next)
  (let ((binds (vars->set vars))
        (lexicals (set-union (vars->set (car env)) (vars->set (cdr env))))
        (args+body (append args body)))
  (let ((free (set-intersection (find-free args+body binds) lexicals)))
  (let ((free-vars (set->list free)))
  (let ((env-extended (cons vars free-vars))
        (boxed-extended (set-union binds (set-intersection boxed free))))
   (compile-push
    (compile-free free-vars env `(close ,(length vars) ()
     (close-dummy ,(length vars)
      (frame ,(length vars) ,(compile-arg args env-extended boxed-extended
       `(close-rec ,(compile-seq body env-extended boxed-extended `(return))))))))
    next))))))

自由変数の集合を求める find-free 手続きに letrec 形式を追加します。 実引数と本体の両方に対して、 束縛変数を加えたスコープの中で自由変数を探すようにします。

 (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)))
      (('letrec ((vars args) ...) . body)                                         ;+
       (find-free (append args 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 手続きにも letrec 形式を追加します。

 (define (find-sets body sets)
  (if (set-empty? sets)
   phi
   (fold (lambda (exp u)
    (set-union u
     (match exp
      ((? symbol? var) phi)
      (('quote obj) phi)
      (('lambda vars . body) (find-sets body (set-difference sets (vars->set vars))))
      (('letrec ((vars args) ...) . body)                                      ;+
       (find-sets (append args body) (set-difference sets (vars->set vars))))  ;+
      (('set! var . body)
       (if (set-contains? sets var)
        (set-adjoin (find-sets body sets) var)
        (find-sets body sets)))
      (((or 'if 'call/cc 'begin) . body) (find-sets body sets))
      ((fn . args) (find-sets exp sets))
      (_ phi))))
    phi body)))

スパム対策のためのダミーです。もし見えても何も入力しないでください
ゲスト


画像認証

トラックバック - http://d.hatena.ne.jp/tociyuki/20171220/1513771188
 |