海野秀之（うんのひでゆき）の外部記憶
Twitter (twilog) / RSS / アンテナ / ぶくま
4.5 章の Stack-Based 版を。 Gauche 上で動くようにするには、ただ写してくるだけではダメで、いくつか修正・追加が必要だった。
; 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
; 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
; 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
; 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 はコメント中に）。
#!/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 モデルを理解していきたい。 （改造しないと、できることが少なくて、「いろいろ動かす」のがムズいの）
だいたい、以下のような改造をやっていくつもり：
最初の３つは、だいたいこんな感じかなという想像がついているのだけど、 マクロはどうやるのがいいんだろうなぁ。
でも、begin くらいは使えないと、しんどい。なので、マクロもはやめにほしい。
んで、動作を理解してから、末尾呼び出しを含む最適化に取り組む。