トップ «前の日記(2011-08-24 (Wed)) 最新 次の日記(2011-08-29 (Mon))» 編集

uDiary

海野秀之(うんのひでゆき)の外部記憶

Twitter (twilog) / RSS / アンテナ / ぶくま

2006|07|08|09|10|11|12|
2007|01|02|03|04|05|06|07|08|09|10|11|12|
2008|01|02|03|04|05|06|07|08|09|10|11|12|
2009|01|02|03|04|05|06|08|
2010|01|02|03|05|06|07|10|11|
2011|03|08|
2012|02|04|07|08|10|
2013|01|02|03|05|06|08|11|12|
2014|01|02|05|06|07|08|09|12|
2015|01|02|03|04|

2011-08-26 (Fri)

[Scheme][3imp] 3imp 写経(最終): 4.5 章 Stack-Based, tail call 最適化まえのもの

4.5 章の Stack-Based 版を。 Gauche 上で動くようにするには、ただ写してくるだけではダメで、いくつか修正・追加が必要だった。

コード

3imp_syntax_extensions.scm
; 3imp_syntax_extensions.scm

; record and record-case are syntax exptensions described in 3imp p.27 and 28.
;
; I couldn't implement with define-syntax but I found a useful article:
; http://chobitscheme.blog87.fc2.com/?mode=m&no=3
;
; These code are from the article.

; The record syntax extension binds a set of variables to the element of a list
; (this list, or record, must contain as many elements as there are variables;
; the variables name the fields of the record).
;
;   (record (var ...) val exp ...)  ->
;       (apply (lambda (var ...) exp ...) val)
;
(define-syntax record
  (syntax-rules ()
    ((_ (var ...) val exp ...)
     (apply (lambda (var ...) exp ...) val))))


; The record-case syntax extension is a special combination of cond and record.
; It is useful for destructuring a record based on the "key" that appears as
; the record's first element:
;
;    (record-case exp1
;      (key vars exp2 ...)
;        :
;        :
;      (else exp3 ...))  ->
;
;    (let ((r exp1))
;      (cond
;        ((eq? (car r) 'key)
;         (record vars (cdr r) exp2 ...))
;        (else exp3 ...)))
;
; The variable r is introduced so that exp is only evaluated once.  Care must
; be taken to prevent r from capturing any free variables.
;

(define-syntax record-case
  (syntax-rules (else)
    ((_ exp1 (else exp2 ...))
     (begin exp2 ...))
    ((_ exp1 (key vars exp2 ...))
     (let ((r exp1))
       (if (eq? (car r) 'key)
	   (record vars (cdr r) exp2 ...))))
    ((_ exp1 (key vars exp2 ...) clause ...)
     (let ((r exp1))
       (if (eq? (car r) 'key)
	   (record vars (cdr r) exp2 ...)
	   (record-case r clause ...))))))


; The rec syntactic form allows the creation of self-recursive closures.
; The binding of var to () by let encloses the expression exp to which var is
; assigned. (The original vlue () is never references.)
(define-syntax rec
  (syntax-rules ()
    ((_ var exp)
     (let ((var '()))
       (set! var exp)))))

; Quite often, a rec expression whose body is lambda is directly applied to
; arguments, usually to implement a loop.  The syntactic form recur makes the
; code more readable
(define-syntax recur
  (syntax-rules ()
    ((_ f ((var init) ...) exp ...)
     ((rec f (lambda (var ...) exp ...))
      init ...))))
stack-operations.scm
;; stack-operations.scm
;  3imp section 4.1.4

(define stack (make-vector 1000))

(define push
  (lambda (x s)
    (vector-set! stack s x)
    (+ s 1)))

(define index
  (lambda (s i)
    (vector-ref stack (- (- s i) 1))))

(define index-set!
  (lambda (s i v)
    (vector-set! stack (- (- s i) 1) v)))
compile451.scm
;; compile451.scm
; Translator from section 4.5.1 of 3imp.

(load "3imp_syntax_extensions.scm")

; p.95: compile-lookup, compile-refer
(define compile-lookup
  (lambda (x e return-local return-free)
    (recur nxtlocal ((locals (car e)) (n 0))
      (if (null? locals)
	  (recur nxtfree ((free (cdr e)) (n 0))
	    (if (eq? (car free) x)
		(return-free n)
		(nxtfree (cdr free) (+ n 1))))
	  (if (eq? (car locals) x)
	      (return-local n)
	      (nxtlocal (cdr locals) (+ n 1)))))))

(define compile-refer
  (lambda (x e next)
    (compile-lookup x e
      (lambda (n) (list 'refer-local n next))
      (lambda (n) (list 'refer-free n next)))))

; p.93: help functions; set-member?, set-cons, set-union, set-minus, and set-intersect
(define set-member?
  (lambda (x s)
    (cond
     ((null? s) #f) ; modified from 3imp, '() can't be used as false.
     ((eq? x (car s)) #t)
     (else (set-member? x (cdr s))))))

(define set-cons
  (lambda (x s)
    (if (set-member? x s)
	s
	(cons x s))))

(define set-union
  (lambda (s1 s2)
    (if (null? s1)
	s2
	(set-union (cdr s1) (set-cons (car s1) s2)))))

(define set-minus
  (lambda (s1 s2)
    (if (null? s1)
	'()
	(if (set-member? (car s1) s2)
	    (set-minus (cdr s1) s2)
	    (cons (car s1) (set-minus (cdr s1) s2))))))

(define set-intersect
  (lambda (s1 s2)
    (if (null? s1)
	'()
	(if (set-member? (car s1) s2)
	    (cons (car s1) (set-intersect (cdr s1) s2))
	    (set-intersect (cdr s1) s2)))))

; p.104: find-free
(define find-free
  (lambda (x b)
    (cond
     ((symbol? x) (if (set-member? x b) '() (list x)))
     ((pair? x)
      (record-case x
       (quote (obj) '())
       (lambda (vars body)
        (find-free body (set-union vars b)))
       (if (test then else)
        (set-union (find-free test b)
		   (set-union (find-free then b)
			      (find-free else b))))
       (set! (var exp)
        (set-union (if (set-member? var b) '() (list var))
		   (find-free exp b)))
       (call/cc (exp) (find-free exp b))
       (else
        (recur next ((x x))
           (if (null? x)
	       '()
	       (set-union (find-free (car x) b)
			  (next (cdr x))))))))
     (else '()))))

; p.95: collect-free
(define collect-free
  (lambda (vars e next)
    (if (null? vars)
	next
	(collect-free (cdr vars) e
	  (compile-refer (car vars) e
	    (list 'argument next))))))

; p.101
(define find-sets
  (lambda (x v)
    (cond
     ((symbol? x) '())
     ((pair? x)
      (record-case x
         (quote (obj) '())
	 (lambda (vars body)
          (find-sets body (set-minus v vars)))
	 (if (test then else)
          (set-union (find-sets test v)
		     (set-union (find-sets then v)
				(find-sets else v))))
	 (set! (var x)
	  (set-union (if (set-member? var v) (list var) '())
		     (find-sets x v)))
	 (call/cc (exp) (find-sets exp v))
	 (else
	  (recur next ((x x))
	     (if (null? x)
		 '()
		 (set-union (find-sets (car x) v)
			    (next (cdr x))))))))
     (else '()))))

; p.102: make-boxes
(define make-boxes
  (lambda (sets vars next)
    (recur f ((vars vars) (n 0))
	   (if (null? vars)
	       next
	       (if (set-member? (car vars) sets)
		   (list 'box n (f (cdr vars) (+ n 1)))
		   (f (cdr vars) (+ n 1)))))))

; p.103
(define compile
  (lambda (x e s next)
    (cond
     ((symbol? x)
      (compile-refer x e
         (if (set-member? x s)
	     (list 'indirect next)
	     next)))
     ((pair? x)
      (record-case x
         (quote (obj) (list 'constant obj next))
	 (lambda (vars body)
	   (let ((free (find-free body vars))
		 (sets (find-sets body vars)))
	     (collect-free free e
		(list 'close
		      (length free)
		      (make-boxes sets vars
		         (compile body
				  (cons vars free)
				  (set-union
				     sets
				     (set-intersect s free))
				  (list 'return (length vars))))
		      next))))
	 (if (test then else)
          (let ((thenc (compile then e s next))
		(elsec (compile else e s next)))
	    (compile test e s (list 'test thenc elsec))))
	 (set! (var x)
	  (compile-lookup var e
	    (lambda (n)
	      (compile x e s (list 'assign-local n next)))
	    (lambda (n)
	      (compile x e s (list 'assign-free n next)))))
	 (call/cc (x)
	  (list 'frame
		next
		(list 'conti
		      (list 'argument
			    (compile x e s '(apply))))))
	 (else
          (recur loop ((args (cdr x))
		       (c (compile (car x) e s '(apply))))
		 (if (null? args)
		     (list 'frame next c)
		     (loop (cdr args)
			   (compile (car args)
				    e
				    s
				    (list 'argument c))))))))
     (else (list 'constant x next)))))

set-member? が、Gauche 上で動かすには問題があった。 いまは、null は False じゃないんですね。

vm452.scm
;; vm452.scm
; VM from section 4.5.2 of 3imp.

(load "3imp_syntax_extensions")
(load "stack-operations")
(load "compile451")

; box/unbox/set-box!, by higepon
; http://d.hatena.ne.jp/higepon/20071102/1193995703
(define (box v)
  (cons 'box v))

(define (set-box! b v)
  (set-cdr! b v))

(define (unbox b)
  (cdr b))

; p.97; closure
(define closure
  (lambda (body n s)
    (let ((v (make-vector (+ n 1))))
      (vector-set! v 0 body)
      (recur f ((i 0))
	 (unless (= i n)
		 (vector-set! v (+ i 1) (index s i))
		 (f (+ i 1))))
      v)))

; p.98: closure-body, index-closure
(define closure-body
  (lambda (c)
    (vector-ref c 0)))

(define index-clusure
  (lambda (c n)
    (vector-ref c (+ n 1))))

; p.83: save-stack, restore-stack
(define save-stack
  (lambda (s)
    (let ((v (make-vector s)))
      (recur copy ((i 0))
        (unless (= i s)
		(vector-set! v i (vector-ref stack i))
		(copy (+ i 1))))
      v)))

(define restore-stack
  (lambda (v)
    (let ((s (vector-length v)))
      (recur copy ((i 0))
	(unless (= i s)
		(vector-set! stack i (vector-ref v i))
		(copy (+ i 1))))
      s)))

; continuation, not shown in 3imp.
; http://cadr.g.hatena.ne.jp/mokehehe/20080510/1210388340
(define continuation
  (lambda (s)
    (closure
     (list 'refer-local 0 (list 'nuate (save-stack s) '(return 0)))
     0
     '())))

; p.105
(define VM
  (lambda (a x f c s)
    (record-case x
       (halt () a)
       (refer-local (n x)
	(VM (index f n) x f c s))
       (refer-free (n x)
	(VM (index-clusure c n) x f c s))
       (indirect (x)
        (VM (unbox a) x f c s))
       (constant (obj x)
	(VM obj x f c s))
       (close (n body x)
        (VM (closure body n s) x f c (- s n)))
       (box (n x)
        (index-set! s n (box (index s n)))
	(VM a x f c s))
       (test (then else)
        (VM a (if a then else) f c s))
       (assign-local (n x)
	(set-box! (index f n) a)
	(VM a x f c s))
       (assign-free (n x)
	(set-box! (index-closure c n) a)
	(VM a x f c s))
       (conti (x)
        (VM (continuation s) x f c s))
       (nuate (stack x)
        (VM a x f c (restore-stack stack)))
       (frame (ret x)
        (VM a x f c (push ret (push f (push c s)))))
       (argument (x)
        (VM a x f c (push a s)))
       (apply ()
        (VM a (closure-body a) s a s))
       (return (n)
        (let ((s (- s n)))
	  (VM a (index s 0) (index s 1) (index s 2) (- s 3)))))))

3imp 中では、ここで使われている box/unbox と continuation のコードが明に示されていません。 いくつかのサイトにお世話になりました(URL はコメント中に)。

REPL
#!/usr/local/bin/gosh

(add-load-path ".")
(load "vm452")

(define banner
  (lambda ()
    (display "3imp Section 4.5 Compiler & VM")))

(define evaluate
  (lambda (x)
    (VM '() (compile x '() '() '(halt)) 0 '() 0)))

(define (repl)
  (let loop ((s '()))
    (display "\n>>> ")
    (set! s (read))
    (display (compile s '() '() '(halt)))
    (newline)

    (display "\n==> ")
    (display (evaluate s))
    (newline)
    (loop '())))

(define (main args)
  (banner)
  (repl))

動作例

% ./repl4.5.scm
3imp Section 4.5 Compiler & VM
>>> 1
(constant 1 (halt))

==> 1

>>> (if #t 1 2)
(constant #t (test (constant 1 (halt)) (constant 2 (halt))))

==> 1

>>> (if #f 1 2)
(constant #f (test (constant 1 (halt)) (constant 2 (halt))))

==> 2

>>> (lambda (x) (lambda () x))
(close 0 (refer-local 0 (argument (close 1 (refer-free 0 (return 0)) (return 1)))) (halt))

==> #((refer-local 0 (argument (close 1 (refer-free 0 (return 0)) (return 1)))))

>>> ((lambda (x) (lambda () x)) 10)
(frame (halt) (constant 10 (argument (close 0 (refer-local 0 (argument (close 1 (refer-free 0 (return 0)) (return 1)))) (apply)))))

==> #((refer-free 0 (return 0)) 10)

>>> (((lambda (x) (lambda () x)) 10))
(frame (halt) (frame (apply) (constant 10 (argument (close 0 (refer-local 0 (argument (close 1 (refer-free 0 (return 0)) (return 1)))) (apply))))))

==> 10

>>> ((lambda (x) (set! x (call/cc (lambda (cont) (cont 20))))) '())
(frame (halt) (constant () (argument (close 0 (box 0 (frame (assign-local 0 (return 1)) (conti (argument (close 0 (frame (return 1) (constant 20 (argument (refer-local 0 (apply))))) (apply)))))) (apply)))))

==> 20

>>>

予定

まだ写経して、ちょっと動かしてみただけなので、きちんと理解できているわけじゃない。 この写経版を動かしたり改造したりしながら、 Stack-Based モデルを理解していきたい。 (改造しないと、できることが少なくて、「いろいろ動かす」のがムズいの)

だいたい、以下のような改造をやっていくつもり:

  • グローバル変数, define の実装
  • 復文対応 (halt を suspend (仮称) に差し替える方針)
  • 組込み関数いくつか
  • マクロ

最初の3つは、だいたいこんな感じかなという想像がついているのだけど、 マクロはどうやるのがいいんだろうなぁ。

でも、begin くらいは使えないと、しんどい。なので、マクロもはやめにほしい。

んで、動作を理解してから、末尾呼び出しを含む最適化に取り組む。

その他(めも)

  • 3imp の recur マクロは、名前付き let に見える。いっしょ?
  • 継続で多値とか、任意個の引数を取る関数とかいう話

2006|07|08|09|10|11|12|
2007|01|02|03|04|05|06|07|08|09|10|11|12|
2008|01|02|03|04|05|06|07|08|09|10|11|12|
2009|01|02|03|04|05|06|08|
2010|01|02|03|05|06|07|10|11|
2011|03|08|
2012|02|04|07|08|10|
2013|01|02|03|05|06|08|11|12|
2014|01|02|05|06|07|08|09|12|
2015|01|02|03|04|
Categories 3imp | Card | Cutter | Dalvik | Euler | Football | GAE/J | Hand | Haskell | Re:View | Ruby | Scheme | TQD | Tiger | TigerBook読 | UikiTeXi | Verilog | Violin | Web | parconc | tDiary | お勉強 | エントロピー | ツン読 | | 将棋 | 政治について | | 模写してみよう | 確率論 | 設定など | 雑文 | 音声