SICP 読み (355) 5.5 翻訳系
Toshiba SatelliteK20 に debian 入れ中。動くかどうか分からんのにパケジをがっつり dpkg --set-selections してしまってるんでパケジを落とすだけで大仕事ッス。
そりゃええんですが、問題 5.47 gdgd です。大事な部分をきちんと読まずにスルーしてるに違いない。
問題 5.47
いつヤッたのかは記憶に無いのですが問題の文章に下線を引いている。
compile-procedure-call を合成 (解釈される) 手続きを扱うよう修正
むむ。MIT で配布されてるソース使ってるので多分カンニングになってしまうのでしょうが、こんなソレを ch5-eceval-compiler.scm 内の eceval を define している箇所にて発見。
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))えーと。なんとなくイメージできかえてるんでメモっとく。
- eceval とか compile-and-go な引数リストは compile されて (eceval はスデに compile 後の状態) assemble されて make-machine なオブジェクトが理解可能な形式に変換されている。
- compile-and-go な引数リストに指定されたリストは env な束縛は解決できる。という事は評価器の中で define されたシンボルが束縛されてる何か、も探せる
- 評価器の中で define されたシンボルが束縛されてる何か、は基本的に scheme のリストになっている。ので assemble 済みな手続きからは直接呼び出してもきちんと動かない。
(test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8
例えば
(lambda (n) n)
みたいなソレが束縛されてる手続き呼び出したとして lookup した結果 proc に上記のリストが入ってるとして cadr な (n) に goto せえと言われても困るわな。逆に上に引用した compoind-apply に jmp する形になってりゃ話は早い。
ただし、この手法は翻訳する手続きから翻訳機側の命令に jmp しなければならなくってラベルの解決が微妙、とゆー事で compapp というレジスタを追加しましょう、というカンジでセイフかなぁ。とりあえずヤッてみます。ログは別途。
つづき
いくつか不具合発生。まず以前と同じ状態で異常終了。よく見てみたら test 入れてなかった。compound-procedure? だったらそっちへ jmp ね、という以下のナニ。
(make-instruction-sequence '(proc) '() ;; add
`((test (op compound-procedure?) (reg proc)) ;; add
(branch (label ,compound-branch)))) ;; addで、今も原因不明なんですが、空の stack を pop しているらしい。restore な模様。
(define (make-restore inst machine stack pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst))))
(lambda ()
(set-contents! reg (pop stack))
(advance-pc pc))))出力される情報はこんなカンジ。
$ gosh
gosh> (add-load-path ".")
("." "/usr/share/gauche/site/lib" "/usr/share/gauche/0.8.7/lib")
gosh> (load "load-eceval-compiler")
#t
gosh> (load "ch5-compiler")
#t
gosh> (define true #t)
true
gosh> (define false #f)
false
gosh> (compile-and-go '(define (f n) (g n)))
(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok
;;; EC-Eval input:
(define (g x) x)
(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok
;;; EC-Eval input:
(f 5)
*** ERROR: Empty stack -- POP
Stack Trace:
_______________________________________
0 (pop stack)
At line 330 of "./ch5-regsim.scm"
1 (set-contents! reg (pop stack))
At line 330 of "./ch5-regsim.scm"
2 (instruction-execution-proc (car insts))
At line 139 of "./ch5-regsim.scm"
gosh> これは仕方が無いので手でヤルか。なんとなく continue なレジスタが微妙と見てるんですがどうか。とりあえず eceval の中で (f 5) の評価が開始された所から見てみます。eceval の以下の部分で式を読んでるはず。
read-eval-print-loop (perform (op initialize-stack)) (perform (op prompt-for-input) (const ";;; EC-Eval input:")) (assign exp (op read)) (assign env (op get-global-environment)) (assign continue (label print-result)) (goto (label eval-dispatch))
continue には print-result なラベルが格納されて eval-dispatch 方面へ。eval-dispatch においては application 認定されるので ev-application に jmp します。
ev-application (save continue) (save env) (assign unev (op operands) (reg exp)) (save unev) (assign exp (op operator) (reg exp)) (assign continue (label ev-appl-did-operator)) (goto (label eval-dispatch))
さらに eval ですが、この時点で stack は
(5) env (label print-result)
というカンジかな。exp には f がセットされて eval-dispatch 方面にトバされる。行った先では variable 認定で lookup された手続き (compiled-procedure
ev-appl-did-operator (restore unev) (restore env) (assign argl (op empty-arglist)) (assign proc (reg val)) (test (op no-operands?) (reg unev)) (branch (label apply-dispatch)) (save proc) ev-appl-operand-loop (save argl) (assign exp (op first-operand) (reg unev)) (test (op last-operand?) (reg unev)) (branch (label ev-appl-last-arg)) ;; 略 (引数一つなのでここで ev-appl-last-arg に jmp) ev-appl-last-arg (assign continue (label ev-appl-accum-last-arg)) (goto (label eval-dispatch))
で unev と env が restore されて 5 が exp にセット eval-dispatch に jmp する直前の stack の状態は
() (compiled-procedure <f の入口ラベル> <env>) (label print-result)
みたいなカンジでしょうか。で、jmp した eval-dispatch では self 認定ですので val に 5 がセットされて ev-appl-accum-last-arg 方面へ jmp するはず。
ev-appl-accum-last-arg (restore argl) (assign argl (op adjoin-arg) (reg val) (reg argl)) (restore proc) (goto (label apply-dispatch))
で、argl が restore されて (5) なリストになり、proc も restore されて apply-dispatch 方面へ jmp しますがこの時点で stack は
(label print-result)
という状態。
apply-dispatch (test (op primitive-procedure?) (reg proc)) (branch (label primitive-apply)) (test (op compound-procedure?) (reg proc)) (branch (label compound-apply)) ;;*next added to call compiled code from evaluator (section 5.5.7) (test (op compiled-procedure?) (reg proc)) (branch (label compiled-apply)) (goto (label unknown-procedure-type))
ここでは compiled 認定で compilied-apply 方面へ。
compiled-apply (restore continue) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val))
ここで continue を restore して stack は空。ラベルを reg に取り出してそちら方面に jmp します。continue の中は (label print-result) になっているはず。
で、jmp 先はどうなってるか、というと以下。整形は面倒なのでしてません。
entry7 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (n)) (reg argl) (reg env)) (assign proc #0=(op lookup-variable-value) (const g) . #1=((reg env))) (assign val #0# (const n) . #1#) (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch9)) (test (op compound-procedure?) (reg proc)) (branch (label compound-branch11)) compiled-branch10 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) compound-branch11 (assign val (reg compapp)) (goto (reg val)) primitive-branch9 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) #2=(goto (reg continue)) after-call12 after-lambda8
ここで lookup されてる g ですが
(procedure (x) (x) <env>)
みたいなカンジでしょうか。これは compound 認定される式になる。g を define した時の環境を n が 5 で束縛されたナニで extend した環境を作って proc と argl を作成した後には compapp なラベルに行ってらっしゃい、になる訳か。それが以下。
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))この時点で stack は空ですが、restore 命令は発行されておりません。で、上記 compound-apply ではパラメータに実引数割り当てて uenv に (x) セットして ev-sequence 方面へ jmp している。
ev-sequence (assign exp (op first-exp) (reg unev)) (test (op last-exp?) (reg unev)) (branch (label ev-sequence-last-exp)) ;; 略 (ev-sequence-last-exp に jmp する) ev-sequence-last-exp (restore continue) (goto (label eval-dispatch))
あら。continue を restore してるし。これはどこで save するべきなのか迷うな。compound-apply の goto 直前、とか??
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(save continue)
(goto (label ev-sequence))微妙。試験してみたら動いた。
$ gosh
gosh> (add-load-path ".")
("." "/usr/share/gauche/site/lib" "/usr/share/gauche/0.8.7/lib")
gosh> (load "load-eceval-compiler")
#t
gosh> (load "ch5-compiler")
#t
gosh> (define true #t)
true
gosh> (define false #f)
false
gosh> (compile-and-go '(define (f n) (g n)))
(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok
;;; EC-Eval input:
(define (g x) x)
(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok
;;; EC-Eval input:
(f 5)
(total-pushes = 6 maximum-depth = 3)
;;; EC-Eval value:
5
;;; EC-Eval input:この後どうするべきなのか。一応問題に書いてあるソレはクリアしてるな。
そういえば
一応ソースも貼っておこう。まず ch5-eceval-compiler.scm の以下の部分。
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(save continue)
(goto (label ev-sequence))allcode なソレにはスデに上記の手続きは記述済みなんですが continue を save してません。ただ、ここが適当かどうかは不明。次は ch5-compiler.scm を
(define (compile-procedure-call target linkage)
(let ((primitive-branch (make-label 'primitive-branch))
(compiled-branch (make-label 'compiled-branch))
(compound-branch (make-label 'compound-branch)) ;; add
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
(make-instruction-sequence '(proc) '()
`((test (op primitive-procedure?) (reg proc))
(branch (label ,primitive-branch))))
(make-instruction-sequence '(proc) '() ;; add
`((test (op compound-procedure?) (reg proc)) ;; add
(branch (label ,compound-branch)))) ;; add
(parallel-instruction-sequences
(append-instruction-sequences
compiled-branch
(compile-proc-appl target compiled-linkage))
(parallel-instruction-sequences ;; add
(append-instruction-sequences ;; add
compound-branch ;; add
(compound-proc-appl target compiled-linkage)) ;; add
(append-instruction-sequences
primitive-branch
(end-with-linkage linkage
(make-instruction-sequence '(proc argl)
(list target)
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl)))))))
) ;; add
after-call))))
;;;applying compound procedures
(define (compound-proc-appl target linkage)
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,linkage))
(assign val (reg compapp))
(goto (reg val)))))
((and (not (eq? target 'val))
(not (eq? linkage 'return)))
(let ((proc-return (make-label 'proc-return)))
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,proc-return))
(assign val (reg compapp))
(goto (reg val))
,proc-return
(assign ,target (reg val))
(goto (label ,linkage))))))
((and (eq? target 'val) (eq? linkage 'return))
(make-instruction-sequence '(proc continue) all-regs
'((assign val (reg compapp))
(goto (reg val)))))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE"
target))))
