開発環境
- OS X Mavericks - Apple(OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- MIT/GNU Scheme (処理系)
計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田 英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.2(レジスタ計算機シミュレータ)、5.2.4(計算機の性能監視)、問題 5.18を解いてみる。
その他参考書籍
問題 5.18.
修正、追加箇所。
コード(BBEdit)
(define (make-register name) (let ((contents '*unassigned*) (trace false)) (define (set value) (if trace (begin (newline) (display "name=") (display name) (display ", old value=") (display contents) (display ", new value=") (display value))) (set! contents value)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) set) ((eq? message 'trace-on) (set! trace true) 'done) ((eq? message 'trace-off) (set! trace false) 'done) (else (error "Unknown request -- REGISTER" message)))) dispatch)) (define (trace-register-on machine reg-name) ((get-register machine reg-name) 'trace-on)) (define (trace-register-off machine reg-name) ((get-register machine reg-name) 'trace-off))
全体。
コード(BBEdit)
register.scm
(define (make-machine ops controller-text) (let ((machine (make-new-machine))) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine)) machine)) (define (make-register name) (let ((contents '*unassigned*) (trace false)) (define (set value) (if trace (begin (newline) (display "name=") (display name) (display ", old value=") (display contents) (display ", new value=") (display value))) (set! contents value)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) set) ((eq? message 'trace-on) (set! trace true) 'done) ((eq? message 'trace-off) (set! trace false) 'done) (else (error "Unknown request -- REGISTER" message)))) dispatch)) (define (get-contents register) (register 'get)) (define (set-contents! register value) ((register 'set) value)) (define (make-stack) (let ((s '()) (number-pushes 0) (max-depth 0) (current-depth 0)) (define (push x) (set! s (cons x s)) (set! number-pushes (+ 1 number-pushes)) (set! current-depth (+ 1 current-depth)) (set! max-depth (max current-depth max-depth))) (define (pop) (if (null? s) (error "Empty stack -- POP") (let ((top (car s))) (set! s (cdr s)) (set! current-depth (- current-depth 1)) top))) (define (initialize) (set! s '()) (set! number-pushes 0) (set! max-depth 0) (set! current-depth 0) 'done) (define (print-statistics) (newline) (display (list 'total-pushes '= number-pushes 'maximum-depth '= max-depth))) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) (pop)) ((eq? message 'initialize) (initialize)) ((eq? message 'print-statistics) (print-statistics)) (else (error "Unknown request -- STACK" message)))) dispatch)) (define (pop stack) (stack 'pop)) (define (push stack value) ((stack 'push) value)) (define (initialize stack) (stack 'initialize)) (define (print-statistics stack) (stack 'print-statistics)) (define (start machine) (machine 'start)) (define (trace-on machine) (machine 'trace-on)) (define (trace-off machine) (machine 'trace-off)) (define (trace-register-on machine reg-name) ((get-register machine reg-name) 'trace-on)) (define (trace-register-off machine reg-name) ((get-register machine reg-name) 'trace-off)) (define (initialize-inst-count machine) (machine 'initialize-inst-count)) (define (get-register-contents machine register-name) (get-contents (get-register machine register-name))) (define (set-register-contents! machine register-name value) (set-contents! (get-register machine register-name) value) 'done) (define (get-register machine reg-name) ((machine 'get-register) reg-name)) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (the-instruction-counting 0) (trace false) (label '())) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))) (list 'print-stack-statistics (lambda () (stack 'print-statistics))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) ;; 命令のアセンブリ中に、初めて見るたびに、レジスタを割り当てる (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (begin (allocate-register name) (lookup-register name))))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin (set! the-instruction-counting (+ the-instruction-counting 1)) (let ((p (car insts))) (if trace (let ((l (instruction-label p))) (newline) (if (null? l) (begin (display label)) (begin (set! label l) (display label))) (display ": ") (display (instruction-text p)))) ((instruction-execution-proc p)) (execute)))))) (define (initialize-inst-count) (display (list 'the-instruction-counting '= the-instruction-counting)) (set! the-instruction-counting 0) 'done) ;; 命令トレースを開始、停止出来るようにする (define (trace-on) (set! trace true) 'done) (define (trace-off) (set! trace false) 'done) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'trace-on) (trace-on)) ((eq? message 'trace-off) (trace-off)) ((eq? message 'initialize-inst-count) (initialize-inst-count)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (assemble controller-text machine) (extract-labels controller-text (lambda (insts labels) (update-insts! insts labels machine) insts))) (define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (if (assoc next-inst labels) (error "Multiply defined label: " next-inst) (begin (set-instruction-label! (car insts) next-inst) (receive insts (cons (make-label-entry next-inst insts) labels)))) (receive (cons (make-instruction next-inst) insts) labels))))))) (define (update-insts! insts labels machine) (let ((pc (get-register machine 'pc)) (flag (get-register machine 'flag)) (stack (machine 'stack)) (ops (machine 'operations))) (for-each (lambda (inst) (set-instruction-execution-proc! inst (make-execution-procedure (instruction-text inst) labels machine pc flag stack ops))) insts))) (define (make-instruction text) (list text '() '())) (define (instruction-text inst) (car inst)) (define (instruction-execution-proc inst) (cadr inst)) (define (instruction-label inst) (caddr inst)) (define (set-instruction-execution-proc! inst proc) (set-car! (cdr inst) proc)) (define (set-instruction-label! inst label) (set-car! (cddr inst) label)) (define (make-label-entry label-name insts) (cons label-name insts)) (define (lookup-label labels label-name) (let ((val (assoc label-name labels))) (if val (cdr val) (error "Undefined label -- ASSEMBLE" label-name)))) (define (make-execution-procedure inst labels machine pc flag stack ops) (cond ((eq? (car inst) 'assign) (make-assign inst machine labels ops pc)) ((eq? (car inst) 'test) (make-test inst machine labels ops flag pc)) ((eq? (car inst) 'branch) (make-branch inst machine labels flag pc)) ((eq? (car inst) 'goto) (make-goto inst machine labels pc)) ((eq? (car inst) 'save) (make-save inst machine stack pc)) ((eq? (car inst) 'restore) (make-restore inst machine stack pc)) ((eq? (car inst) 'perform) (make-perform inst machine labels ops pc)) ;; 新しい構文を追加(branchと枝分かれの仕方が逆) ((eq? (car inst) 'branch-not) (make-branch-not inst machine labels flag pc)) ((eq? (car inst) 'initialize) (make-initialize stack pc)) ((eq? (car inst) 'print-statistics) (make-print-statistics stack pc)) (else (error "Unknown instruction type -- ASSEMBLE" inst)))) (define (make-assign inst machine labels operations pc) (let ((target (get-register machine (assign-reg-name inst))) (value-exp (assign-value-exp inst))) (let ((value-proc (if (operation-exp? value-exp) (make-operation-exp value-exp machine labels operations) (make-primitive-exp (car value-exp) machine labels)))) (lambda () ; execution procedure for assign (set-contents! target (value-proc)) (advance-pc pc))))) (define (assign-reg-name assign-instruction) (cadr assign-instruction)) (define (assign-value-exp assign-instruction) (cddr assign-instruction)) (define (advance-pc pc) (set-contents! pc (cdr (get-contents pc)))) (define (make-test inst machine labels operations flag pc) (let ((condition (test-condition inst))) (if (operation-exp? condition) (let ((condition-proc (make-operation-exp condition machine labels operations))) (lambda () (set-contents! flag (condition-proc)) (advance-pc pc))) (error "Bad TEST instruction -- ASSEMBLE" inst)))) (define (test-condition test-instruction) (cdr test-instruction)) (define (make-branch inst machine labels flag pc) (let ((dest (branch-dest inst))) (if (label-exp? dest) (let ((insts (lookup-label labels (label-exp-label dest)))) (lambda () (if (get-contents flag) (set-contents! pc insts) (advance-pc pc)))) (error "Bad BRANCH instruction -- ASSEMBLE" inst)))) (define (branch-dest branch-instruction) (cadr branch-instruction)) (define (make-goto inst machine labels pc) (let ((dest (goto-dest inst))) (cond ((label-exp? dest) (let ((insts (lookup-label labels (label-exp-label dest)))) (lambda () (set-contents! pc insts)))) ((register-exp? dest) (let ((reg (get-register machine (register-exp-reg dest)))) (lambda () (set-contents! pc (get-contents reg))))) (else (error "Bad GOTO instruction -- ASSEMBLE" inst))))) (define (goto-dest goto-instruction) (cadr goto-instruction)) (define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst)))) (lambda () (push stack (get-contents reg)) (advance-pc pc)))) (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)))) (define (stack-inst-reg-name stack-instruction) (cadr stack-instruction)) (define (make-perform inst machine labels operations pc) (let ((action (perform-action inst))) (if (operation-exp? action) (let ((action-proc (make-operation-exp action machine labels operations))) (lambda () (action-proc) (advance-pc pc))) (error "Bad PERFORM instruction -- ASSEMBLE" inst)))) (define (perform-action inst) (cdr inst)) (define (make-branch-not inst machine labels flag pc) (let ((dest (branch-not-dest inst))) (if (label-exp? dest) (let ((insts (lookup-label labels (label-exp-label dest)))) (lambda () (if (get-contents flag) (advance-pc pc) (set-contents! pc insts)))) (error "Bad BRANCH-NOT instruction -- ASSEMBLE" inst)))) (define (branch-not-dest branch-not-instruction) (cadr branch-not-instruction)) (define (make-initialize stack pc) (lambda () (initialize stack) (advance-pc pc))) (define (make-print-statistics stack pc) (lambda () (print-statistics stack) (advance-pc pc))) (define (make-primitive-exp exp machine labels) (cond ((constant-exp? exp) (let ((c (constant-exp-value exp))) (lambda () c))) ((label-exp? exp) (let ((insts (lookup-label labels (label-exp-label exp)))) (lambda () insts))) ((register-exp? exp) (let ((r (get-register machine (register-exp-reg exp)))) (lambda () (get-contents r)))) (else (error "Unknown expression type -- ASSEMBLE" exp)))) (define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) false)) (define (register-exp? exp) (tagged-list? exp 'reg)) (define (register-exp-reg exp) (cadr exp)) (define (constant-exp? exp) (tagged-list? exp 'const)) (define (constant-exp-value exp) (cadr exp)) (define (label-exp? exp) (tagged-list? exp 'label)) (define (label-exp-label exp) (cadr exp)) (define (make-operation-exp exp machine labels operations) (let ((op (lookup-prim (operation-exp-op exp) operations)) (aprocs (map (lambda (e) (if (label-exp? e) (error "Cannot apply op to lbael -- MAKE-OPERATION-EXP" e) (make-primitive-exp e machine labels))) (operation-exp-operands exp)))) (lambda () (apply op (map (lambda (p) (p)) aprocs))))) (define (operation-exp? exp) (and (pair? exp) (tagged-list? (car exp) 'op))) (define (operation-exp-op operation-exp) (cadr (car operation-exp))) (define (operation-exp-operands operation-exp) (cdr operation-exp)) (define (lookup-prim symbol operations) (let ((val (assoc symbol operations))) (if val (cadr val) (error "Unknown operation -- ASSEMBLE" symbol))))
元のrestoreとの違いを確認。
入出力結果(Terminal, REPL(Read, Eval, Print, Loop))
$ scheme MIT/GNU Scheme running under MacOSX Type `^C' (control-C) followed by `H' to obtain information about interrupts. Copyright (C) 2011 Massachusetts Institute of Technology This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. Image saved on Saturday October 26, 2013 at 11:02:50 PM Release 9.1.1 || Microcode 15.3 || Runtime 15.7 || SF 4.41 || LIAR/C 4.118 Edwin 3.116 1 ]=> (load "./register.scm") ;Loading "./register.scm"... done ;Value: lookup-prim 1 ]=> (define (print a) (newline) (display a)) ;Value: print 1 ]=> (define fact-machine (make-machine (list (list '= =) (list '- -) (list '* *) (list 'read read) (list 'print print)) '( (assign continue (label fact-done)) (initialize) (assign n (op read)) fact-Loop (test (op =) (reg n) (const 1)) (branch (label base-case)) (save continue) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) base-case (assign val (const 1)) (goto (reg continue)) fact-done (perform (op print) (reg val)) (print-statistics)))) ;Value: fact-machine 1 ]=> (start fact-machine) 5 120 (total-pushes = 8 maximum-depth = 8) ;Value: done 1 ]=> (trace-register-on fact-machine 'n) ;Value: done 1 ]=> (start fact-machine) 5 name=n, old value=5, new value=5 name=n, old value=5, new value=4 name=n, old value=4, new value=3 name=n, old value=3, new value=2 name=n, old value=2, new value=1 name=n, old value=1, new value=2 name=n, old value=2, new value=3 name=n, old value=3, new value=4 name=n, old value=4, new value=5 120 (total-pushes = 8 maximum-depth = 8) ;Value: done 1 ]=> (trace-register-on fact-machine 'val) ;Value: done 1 ]=> (start fact-machine) 5 name=n, old value=5, new value=5 name=n, old value=5, new value=4 name=n, old value=4, new value=3 name=n, old value=3, new value=2 name=n, old value=2, new value=1 name=val, old value=120, new value=1 name=n, old value=1, new value=2 name=val, old value=1, new value=2 name=n, old value=2, new value=3 name=val, old value=2, new value=6 name=n, old value=3, new value=4 name=val, old value=6, new value=24 name=n, old value=4, new value=5 name=val, old value=24, new value=120 120 (total-pushes = 8 maximum-depth = 8) ;Value: done 1 ]=> (trace-register-off fact-machine 'n) ;Value: done 1 ]=> (start fact-machine) 5 name=val, old value=120, new value=1 name=val, old value=1, new value=2 name=val, old value=2, new value=6 name=val, old value=6, new value=24 name=val, old value=24, new value=120 120 (total-pushes = 8 maximum-depth = 8) ;Value: done 1 ]=> (trace-on fact-machine) ;Value: done 1 ]=> (start fact-machine) (): (assign continue (label fact-done)) (): (initialize) (): (assign n (op read))5 fact-loop: (test (op =) (reg n) (const 1)) fact-loop: (branch (label base-case)) fact-loop: (save continue) fact-loop: (save n) fact-loop: (assign n (op -) (reg n) (const 1)) fact-loop: (assign continue (label after-fact)) fact-loop: (goto (label fact-loop)) fact-loop: (test (op =) (reg n) (const 1)) fact-loop: (branch (label base-case)) fact-loop: (save continue) fact-loop: (save n) fact-loop: (assign n (op -) (reg n) (const 1)) fact-loop: (assign continue (label after-fact)) fact-loop: (goto (label fact-loop)) fact-loop: (test (op =) (reg n) (const 1)) fact-loop: (branch (label base-case)) fact-loop: (save continue) fact-loop: (save n) fact-loop: (assign n (op -) (reg n) (const 1)) fact-loop: (assign continue (label after-fact)) fact-loop: (goto (label fact-loop)) fact-loop: (test (op =) (reg n) (const 1)) fact-loop: (branch (label base-case)) fact-loop: (save continue) fact-loop: (save n) fact-loop: (assign n (op -) (reg n) (const 1)) fact-loop: (assign continue (label after-fact)) fact-loop: (goto (label fact-loop)) fact-loop: (test (op =) (reg n) (const 1)) fact-loop: (branch (label base-case)) base-case: (assign val (const 1)) name=val, old value=120, new value=1 base-case: (goto (reg continue)) after-fact: (restore n) after-fact: (restore continue) after-fact: (assign val (op *) (reg n) (reg val)) name=val, old value=1, new value=2 after-fact: (goto (reg continue)) after-fact: (restore n) after-fact: (restore continue) after-fact: (assign val (op *) (reg n) (reg val)) name=val, old value=2, new value=6 after-fact: (goto (reg continue)) after-fact: (restore n) after-fact: (restore continue) after-fact: (assign val (op *) (reg n) (reg val)) name=val, old value=6, new value=24 after-fact: (goto (reg continue)) after-fact: (restore n) after-fact: (restore continue) after-fact: (assign val (op *) (reg n) (reg val)) name=val, old value=24, new value=120 after-fact: (goto (reg continue)) fact-done: (perform (op print) (reg val)) 120 fact-done: (print-statistics) (total-pushes = 8 maximum-depth = 8) ;Value: done 1 ]=> ^D End of input stream reached. Moriturus te saluto. $
0 コメント:
コメントを投稿