SICP
Exercise 5.7
(define expt-a
(make-machine
'(continue n b val)
(list (list '= =) (list '- -) (list '* *))
'(machine
(assign continue (label expt-done))
expt-loop
(test (op =) (reg n) (const 0))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterexpt))
(assign n (op -) (reg n) (const 1))
(goto (label expt-loop))
afterexpt
(restore continue)
(assign val (op *) (reg b) (reg val))
(goto (reg continue))
immediate-answer
(assign val (const 1))
(goto (reg continue))
expt-done)
))
(set-register-contents! expt-a 'b 2)
(set-register-contents! expt-a 'n 5)
(start expt-a)
;;gosh> (get-register-contents expt-a 'val)
;;32
(define expt-b
(make-machine
'(counter product n b)
(list (list '= =) (list '- -) (list '* *))
'(machine
(assign counter (reg n))
(assign product (const 1))
expt-loop
(test (op =) (reg counter) (const 0))
(branch (label expt-done))
(assign counter (op -) (reg counter) (const 1))
(assign product (op *) (reg b) (reg product))
(goto (label expt-loop))
expt-done)
))
(set-register-contents! expt-b 'b 2)
(set-register-contents! expt-b 'n 6)
(start expt-b)
;;gosh> (get-register-contents expt-b 'product)
;;64
Exercise 5.8
(define ex5.8
(make-machine
'(a)
(list '())
'(start
(goto (label here))
here
(assign a (const 3))
(goto (label there))
here
(assign a (const 4))
(goto (label there))
there)
))
(start ex5.8)
;;gosh> (get-register-contents ex5.8 'a)
;;3
;;; extract-labels で同じラベルがあるかどうかチェックする。
(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)
(let ((p (assoc next-inst labels)))
(if p
(error "Duplicate label -- ASSEMBLE" next-inst)
(receive insts
(cons
(make-label-entry next-inst insts) labels))))
(receive (cons (make-instruction next-inst) insts)
labels)))))))
;;gosh> (define ex5.8
;; (make-machine
;; '(a)
;; (list '())
;; '(start
;; (goto (label here))
;; here
;; (assign a (const 3))
;; (goto (label there))
;; here
;; (assign a (const 4))
;; (goto (label there))
;; there)
;; ))
;;*** ERROR: Duplicate label -- ASSEMBLE here
Exercise 5.9
;;; make-operation-exp で operand が label の時はエラーとする。
(define (make-operation-exp exp machine labels operation)
(let ((op (lookup-prim (operation-exp-op exp) operation))
(aprocs
(map (lambda (e)
(if (label-exp? e)
(error "Operations can be used only with registers and constants -- ASSEMBLE" exp)
(make-primitive-exp e machine labels)))
(operation-exp-operands exp))))
(lambda ()
(apply op (map (lambda (p) (p)) aprocs)))))
(define ex5.9
(make-machine
'(a)
(list (list '+ +))
'(l
(assign a (op +) (label l) (const 1))
)
))
;;gosh> (load "ex5_9")
;;*** ERROR: Operations can be used only with registers and constants -- ASSEMBLE ((op +) (label l) (const 1))
Exercise 5.10
;;; syntax って assembler の変更で対応できる範囲という事でいいのかな？
;;; という事で、
;;; label にオフセット（省略可）を指定できるように syntax を変更する。
;;; (label <label-name>) -> (label <label-name> <offset>)
;;;
;;; offset が + の時は、label-name から求めた inst を進める。
;;; - の時は２つのポインタを使い、controller-text の最初に
;;; 強制的に埋め込んだ label位置に ポインタを設定し、一方を
;;; -offset だけ進めた後、label-name から 求めた inst に先に
;;; 進めたポインタがたどり着くまで２つのポインタを進める。
(define (assemble controller-text machine)
(set! contoller-text (cons '**main** controller-text))
(extract-labels controller-text
(lambda (insts labels)
(update-insts! insts labels machine)
insts)))
(define (label-exp-label exp) (cdr exp)) ;label-exp-lable-expb
(define (label-name label-expb) (car label-expb))
(define (label-offset label-expb)
(cond ((null? (cdr label-expb)) 0)
((number? (cadr label-expb)) (cadr label-expb))
(else (error "Offset must be number -- LABEL-EXPB" label-expb))))
(define (lookup-label labels label-expb)
(define (forward insts n)
(if (= n 0)
insts
(if (null? (cdr insts))
(error "Out of range -- ASSEMLBE" label-expb)
(forward (cdr insts) (- n 1)))))
(define (forward2 insts lead target)
(if (eq? lead target)
insts
(if (null? (cdr lead))
(error "Out of range -- ASSEMBLE" label-expb)
(forward2 (cdr insts) (cdr lead) target))))
(let ((name (label-name label-expb))
(offset (label-offset label-expb))
(insts '()))
(let ((val (assoc name labels)))
(if val
(set! insts (cdr val))
(error "Undefined label -- ASSEMBLE" name)))
(if (>= offset 0)
(forward insts offset)
(let ((ip (cdr (assoc '**main** labels))))
(forward2 ip (forward ip (* offset -1)) insts)))))
;; test program
(define ex5.10
(make-machine
'(a continue)
(list (list '+ +) (list 'display display) (list 'newline newline))
'(ex5.10
(assign a (const 0))
(assign continue (label t1e))
(goto (label s))
t1e
(assign a (const 0))
(assign continue (label t2e))
(goto (label s -1))
t2e
(assign a (const 0))
(assign continue (label t3e))
(goto (label s 1))
t3e
(goto (label ex5.10.done))
;
(assign a (op +) (reg a) (const 1))
s
(assign a (op +) (reg a) (const 1))
(assign a (op +) (reg a) (const 1))
(perform (op display) (reg a))
(perform (op newline))
(goto (reg continue))
;
ex5.10.done)
))
;;gosh> (start ex5.10)
;;2
;;3
;;1
;;done
Exercise 5.11
;;; a
;;; afterfib-n-2 の直後の
;;; (assign n (reg val)) (restore val)
;;; を
;;; (restore n)
;;; としても同じ結果を得ることができる。
;;; b と c
;;; stack の方法を stack-mode に保持する。
;;; a:オリジナル b:レジスタチェック c:レジスタ毎のスタック
(define stack-mode 'a)
;;; register にスタックを設ける。
(define (make-register name)
(let ((contents '*unassigned*)
(stack (make-stack)))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set) (lambda (value)
(set! contents value)))
((eq? message 'pop) (stack 'pop))
((eq? message 'push) (stack 'push))
((eq? message 'initialize) (stack 'initialize))
(else error "Unknown request -- REGISTER" message)))
dispatch))
;;; make-new-machine のオペレーション定義 'initialize-stack を変更
(list 'initialize-stack
(cond ((eq? stack-mode 'c)
(lambda () (for-each (lambda (regpair)
((cdr regpair) 'initialize))
register-table)))
(else (lambda () (stack 'initialize)))))
;;; make-save の変更
(define (make-save inst machine stack pc labels)
(let ((reg (get-register machine (stack-inst-reg-name inst))))
(lambda ()
(cond ((eq? stack-mode 'a) (push stack (get-contents reg)))
((eq? stack-mode 'b)
(push stack (get-contents reg)) (push stack (stack-inst-reg-name inst)))
((eq? stack-mode 'c) (push reg (get-contents reg))))
(advance-pc pc))))
;;; make-retore の変更
(define (make-restore inst machine stack pc labels)
(let ((reg (get-register machine (stack-inst-reg-name inst))))
(lambda ()
(cond ((eq? stack-mode 'a) (set-contents! reg (pop stack)))
((eq? stack-mode 'b)
(let ((reg-name (pop stack)))
(if (equal? reg-name (stack-inst-reg-name inst))
(set-contents! reg (pop stack))
(error "Pop-value was saved from " reg-name ': inst))))
((eq? stack-mode 'c) (set-contents! reg (pop reg))))
(advance-pc pc))))
;;; b の test program
(define ex5.11.b
(make-machine
'(a b)
(list (list 'display display) (list 'newline newline))
'(ex5.11.b
(assign a (const 11))
(save a)
(restore a)
(perform (op display) (reg a))
(perform (op newline))
(save a)
(restore b)
(perform (op display) (reg b))
(perform (op newline))
)
))
;;gosh> (start ex5.11.b)
;;11
;;*** ERROR: Pop-value was saved from a : (restore b)
;;Stack Trace:
;;; c の test program
(define ex5.11.c
(make-machine
'(a b)
(list (list 'display display) (list 'newline newline))
'(ex5.11.c
(assign a (const 1))
(assign b (const 2))
(save a)
(save b)
(assign a (const 10))
(assign b (const 10))
(restore a)
(restore b)
(perform (op display) (reg a))
(perform (op newline))
(perform (op display) (reg b))
(perform (op newline))
)
))
;;gosh> (start ex5.11.c)
;;1
;;2
Exercise 5.12
;;; make-new-machine の dispatch に以下を追加
((eq? message 'insts) the-instruction-sequence)
;;; コマンド追加
(define (static-analyze machine)
(s-analyze (machine 'insts)))
;;; insts から重複のない instuction text listを得る。
(define (unique insts)
(let ((uinstsl '()))
(for-each (lambda (inst)
(if (not (member (instruction-text inst) uinstsl))
(set! uinstsl (cons (instruction-text inst) uinstsl))))
insts)
uinstsl))
(define (analyze-report-inst title keys)
(display title) (newline)
(for-each (lambda (key)
(display " ") (display (car key)) (newline)
(for-each (lambda (text)
(display " ") (display text) (newline))
(rsort (cdr key))))
(rsort keys)))
(define (analyze-report-reg title regs)
(display title) (newline)
(for-each (lambda (reg) (display " ") (display reg)) (rsort regs))
(newline))
;;; リストをソートする。
(define (rsort items)
(sort items (lambda (x y) (= (comp x y) -1))))
(define (comp x y)
(cond ((and (null? x) (null? y)) 0)
((null? x) -1)
((null? y) 1)
((and (number? x) (number? y)) (compare x y))
((number? x) -1)
((number? y) 1)
((and (string? x) (string? y)) (compare x y))
((string? x) -1)
((string? y) 1)
((and (symbol? x) (symbol? y)) (compare (symbol->string x)
(symbol->string y)))
((symbol? x) -1)
((symbol? y) 1)
((and (pair? x) (pair? y)) (let ((f (comp (car x) (car y))))
(if (= f 0)
(comp (cdr x) (cdr y))
f)))
(else 1)
))
(define (s-analyze insts)
(let ((analyze-1 '()) ; instructions
(analyze-2 '()) ; registers refed by goto
(analyze-3 '()) ; registers saved or restored
(analyze-4 '())) ; assign instructions
(for-each (lambda (text)
(let ((insttype (assoc (car text) analyze-1)))
(if (not insttype)
(begin
(set! insttype (cons (car text) '()))
(set! analyze-1 (cons insttype analyze-1))))
(set-cdr! insttype (cons text (cdr insttype))))
(if (and (eq? (car text) 'goto)
(register-exp? (goto-dest text)))
(set! analyze-2
(cons (register-exp-reg (goto-dest text)) analyze-2)))
(if (or (eq? (car text) 'save)
(eq? (car text) 'restore))
(let ((reg (memq (stack-inst-reg-name text) analyze-3)))
(if (not reg)
(set! analyze-3
(cons (stack-inst-reg-name text) analyze-3)))))
(if (eq? (car text) 'assign)
(let ((reg (assoc (assign-reg-name text) analyze-4)))
(if (not reg)
(begin
(set! reg (cons (assign-reg-name text) '()))
(set! analyze-4 (cons reg analyze-4))))
(set-cdr! reg (cons text (cdr reg)))))
)
(unique insts))
(analyze-report-inst ";;Instructions" analyze-1)
(analyze-report-reg ";;Regs-refed-by-goto" analyze-2)
(analyze-report-reg ";;Regs-refed-by-save-restore" analyze-3)
(analyze-report-inst ";;Regs-source" analyze-4)
))
;; test program
(define fib
(make-machine
'(continue n val)
(list (list '< <) (list '- -) (list '+ +))
'(machine
(assign continue (label fib-done))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
;; set up to compute Fib(n - 1)
(save continue)
(assign continue (label afterfib-n-1))
(save n) ; save old value of n
(assign n (op -) (reg n) (const 1)); clobber n to n - 1
(goto (label fib-loop)) ; perform recursive call
afterfib-n-1 ; upon return, val contains Fib(n - 1)
(restore n)
(restore continue)
;; set up to compute Fib(n - 2)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val) ; save Fib(n - 1)
(goto (label fib-loop))
afterfib-n-2 ; upon return, val contains Fib(n - 2)
(assign n (reg val)) ; n now contains Fib(n - 2)
(restore val) ; val now contains Fib(n - 1)
(restore continue)
(assign val ; Fib(n - 1) + Fib(n - 2)
(op +) (reg val) (reg n))
(goto (reg continue)) ; return to caller, answer is in val
immediate-answer
(assign val (reg n)) ; base case: Fib(n) = n
(goto (reg continue))
fib-done)
))
;;gosh> (static-analyze fib)
;;;;Instructions
;; assign
;; (assign continue (label afterfib-n-1))
;; (assign continue (label afterfib-n-2))
;; (assign continue (label fib-done))
;; (assign n (op -) (reg n) (const 1))
;; (assign n (op -) (reg n) (const 2))
;; (assign n (reg val))
;; (assign val (op +) (reg val) (reg n))
;; (assign val (reg n))
;; branch
;; (branch (label immediate-answer))
;; goto
;; (goto (label fib-loop))
;; (goto (reg continue))
;; restore
;; (restore continue)
;; (restore n)
;; (restore val)
;; save
;; (save continue)
;; (save n)
;; (save val)
;; test
;; (test (op <) (reg n) (const 2))
;;;;Regs-refed-by-goto
;; continue
;;;;Regs-refed-by-save-restore
;; continue n val
;;;;Regs-source
;; continue
;; (assign continue (label afterfib-n-1))
;; (assign continue (label afterfib-n-2))
;; (assign continue (label fib-done))
;; n
;; (assign n (op -) (reg n) (const 1))
;; (assign n (op -) (reg n) (const 2))
;; (assign n (reg val))
;; val
;; (assign val (op +) (reg val) (reg n))
;; (assign val (reg n))
Exercise 5.13
;;; make-new-machine の内部定義手続き lookup-register を register
;;; が見つからなかったら作るよう変更する。
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(begin (allocate-register name)
(lookup-register name)))))
;; test program
(define expt-b
(make-machine
'()
(list (list '= =) (list '- -) (list '* *))
'(machine
(assign counter (reg n))
(assign product (const 1))
expt-loop
(test (op =) (reg counter) (const 0))
(branch (label expt-done))
(assign counter (op -) (reg counter) (const 1))
(assign product (op *) (reg b) (reg product))
(goto (label expt-loop))
expt-done)
))
(set-register-contents! expt-b 'b 2)
(set-register-contents! expt-b 'n 6)
;;gosh> (start expt-b)
;;done
;;gosh> (get-register-contents expt-b 'product)
;;64
Exercise 5.14
(define n!
(make-machine
'(continue n val)
(list (list '= =) (list '- -) (list '* *))
'(machine
(assign continue (label fact-done)) ; set up final return address
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
;; Set up for the recursive call by saving n and continue.
;; Set up continue so that the computation will continue
;; at after-fact when the subroutine returns.
(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)) ; val now contains n(n - 1)!
(goto (reg continue)) ; return to caller
base-case
(assign val (const 1)) ; base case: 1! = 1
(goto (reg continue)) ; return to caller
fact-done)
))
(define (ex5.14 num)
(define (iter c)
(if (> c num)
'done
(begin
((n! 'stack) 'initialize)
(set-register-contents! n! 'n c)
(start n!)
(format #t "n:~2d n!:~8d" c (get-register-contents n! 'val))
(display " ")
((n! 'stack) 'print-statistics)
(iter (+ c 1)))))
(iter 1))
;;gosh> (ex5.14 10)
;;n: 1 n!: 1 (total-pushes = 0 maximum-depth = 0)
;;n: 2 n!: 2 (total-pushes = 2 maximum-depth = 2)
;;n: 3 n!: 6 (total-pushes = 4 maximum-depth = 4)
;;n: 4 n!: 24 (total-pushes = 6 maximum-depth = 6)
;;n: 5 n!: 120 (total-pushes = 8 maximum-depth = 8)
;;n: 6 n!: 720 (total-pushes = 10 maximum-depth = 10)
;;n: 7 n!: 5040 (total-pushes = 12 maximum-depth = 12)
;;n: 8 n!: 40320 (total-pushes = 14 maximum-depth = 14)
;;n: 9 n!: 362880 (total-pushes = 16 maximum-depth = 16)
;;n:10 n!: 3628800 (total-pushes = 18 maximum-depth = 18)
;;done
Exercise 5.15
;;; make-new-machine に追加
;;ローカル変数追加
(instruction-counter 0)
;;内部定義手続き execute の末尾再帰の前に追加
(set! instruction-counter (+ instruction-counter 1))
;;内部定義手続き追加
(define (inst-count)
(let ((cnt instruction-counter))
(set! instruction-counter 0)
cnt))
;;メッセージ受付追加
((eq? message 'instruction-count) (inst-count))
;;; test program
(define icnt
(make-machine
'(n)
(list (list '= =) (list '- -))
'(machine
loop
(test (op =) (reg n) (const 1))
(branch (label loop-end))
(assign n (op -) (reg n) (const 1))
(goto (label loop))
loop-end)
))
(define (ex5.15 num)
(define (iter c)
(if (> c num)
'done
(begin
(set-register-contents! icnt 'n c)
(start icnt)
(format #t "n:~d instruction-count:~d~%" c (icnt 'instruction-count))
(iter (+ c 1)))))
(iter 1))
;;gosh> (ex5.15 5)
;;n:1 instruction-count:2
;;n:2 instruction-count:6
;;n:3 instruction-count:10
;;n:4 instruction-count:14
;;n:5 instruction-count:18
;;done
Exercise 5.16
;;; (trace <machine> 'on/'off)
;;; make-new-machine に追加
;;ローカル変数追加
(trace 'off)
;;内部定義手続き execute の instruction の実行の前に追加
(if (eq? trace 'on) (trace-out (car insts)))
;;メッセージ受付追加
((eq? message 'trace) (lambda (mode) (set! trace mode)))
;;; コマンドとトレース出力追加
(define (trace machine mode)
(if (or (eq? mode 'on) (eq? mode 'off))
((machine 'trace) mode)
(else (error "Mode must be 'on/'off" mode))))
(define (trace-out inst)
(format #t "trace: ~s~%" (instruction-text inst)))
;;; test program
(define icnt
(make-machine
'(n)
(list (list '= =) (list '- -))
'(loop
(test (op =) (reg n) (const 1))
(branch (label loop-end))
(assign n (op -) (reg n) (const 1))
(goto (label loop))
loop-end)
))
(define (ex5.16)
(set-register-contents! icnt 'n 1)
(start icnt)
(format #t "n:1 instruction-count:~d~%" (icnt 'instruction-count))
;
(trace icnt 'on)
(set-register-contents! icnt 'n 2)
(start icnt)
(format #t "n:2 instruction-count:~d~%" (icnt 'instruction-count))
;
(trace icnt 'off)
(set-register-contents! icnt 'n 3)
(start icnt)
(format #t "n:3 instruction-count:~d~%" (icnt 'instruction-count))
)
;;gosh> (ex5.16)
;;n:1 instruction-count:2
;;trace: (test (op =) (reg n) (const 1))
;;trace: (branch (label loop-end))
;;trace: (assign n (op -) (reg n) (const 1))
;;trace: (goto (label loop))
;;trace: (test (op =) (reg n) (const 1))
;;trace: (branch (label loop-end))
;;n:2 instruction-count:6
;;n:3 instruction-count:10
;;#<undef>
Exercise 5.17
;;; label 出力のため inst に label 情報を含める。
;;; inst を ((text . proc) label-name1 ...) の形式にし、、
;;; make-instruction, instruction-text, instruction-execution-proc,
;;; set-instruction-execution-proc!, make-label-entry を変更,
;;; instruction-labels を追加する。
(define (make-instruction text)
(cons (cons text '()) '()))
(define (instruction-text inst)
(caar inst))
(define (instruction-execution-proc inst)
(cdar inst))
(define (instruction-labels inst)
(cdr inst))
(define (set-instruction-execution-proc! inst proc)
(set-cdr! (car inst) proc))
(define (make-label-entry label-name insts)
(let ((lentry (cons label-name insts)))
(if (and (not (null? insts)) (not (eq? label-name '**main**)))
(set-cdr! (car insts) (cons label-name (instruction-labels (car insts)))))
lentry))
;;; 5.16 で作成した trace-out を変更する。
(define (trace-out inst)
(if (not (null? (instruction-labels inst)))
(for-each
(lambda (x) (format #t "trace:~s~%" x))
(instruction-labels inst)))
(format #t "trace: ~s~%" (instruction-text inst)))
;;; test program
(define expt-a
(make-machine
'(continue n b val)
(list (list '= =) (list '- -) (list '* *))
'(machine
(assign continue (label expt-done))
expt-loop
(test (op =) (reg n) (const 0))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterexpt))
(assign n (op -) (reg n) (const 1))
(goto (label expt-loop))
afterexpt
(restore continue)
(assign val (op *) (reg b) (reg val))
(goto (reg continue))
immediate-answer
(assign val (const 1))
(goto (reg continue))
expt-done)
))
(trace expt-a 'on)
(set-register-contents! expt-a 'b 2)
(set-register-contents! expt-a 'n 2)
;;gosh> (start expt-a)
;;trace:machine
;;trace: (assign continue (label expt-done))
;;trace:expt-loop
;;trace: (test (op =) (reg n) (const 0))
;;trace: (branch (label immediate-answer))
;;trace: (save continue)
;;trace: (assign continue (label afterexpt))
;;trace: (assign n (op -) (reg n) (const 1))
;;trace: (goto (label expt-loop))
;;trace:expt-loop
;;trace: (test (op =) (reg n) (const 0))
;;trace: (branch (label immediate-answer))
;;trace: (save continue)
;;trace: (assign continue (label afterexpt))
;;trace: (assign n (op -) (reg n) (const 1))
;;trace: (goto (label expt-loop))
;;trace:expt-loop
;;trace: (test (op =) (reg n) (const 0))
;;trace: (branch (label immediate-answer))
;;trace:immediate-answer
;;trace: (assign val (const 1))
;;trace: (goto (reg continue))
;;trace:afterexpt
;;trace: (restore continue)
;;trace: (assign val (op *) (reg b) (reg val))
;;trace: (goto (reg continue))
;;trace:afterexpt
;;trace: (restore continue)
;;trace: (assign val (op *) (reg b) (reg val))
;;trace: (goto (reg continue))
;;done
Exercise 5.18
;;; (register-trace <machine> '<regisetr-name> 'on/'off)
;;; make-register の引数 name はこのために用意されていたのか？
;;; make-register 変更
(define (make-register name)
(let ((contents '*unassigned*)
(stack (make-stack))
(trace 'off))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set) (lambda (value)
(if (eq? trace 'on)
(format #t "reg :[~s] ~s->~s~%"
name contents value))
(set! contents value)))
((eq? message 'pop) (stack 'pop))
((eq? message 'push) (stack 'push))
((eq? message 'initialize) (stack 'initialize))
((eq? message 'trace) (lambda (mode) (set! trace mode)))
(else error "Unknown request -- REGISTER" message)))
dispatch))
;;; 新規
(define (set-register-trace-mode! register mode)
(if (or (eq? mode 'on) (eq? mode 'off))
((register 'trace) mode)
(else (error "Mode must be 'on/'off" mode))))
(define (register-trace machine register-name mode)
(set-register-trace-mode! (get-register machine register-name) mode))
;;; test program
(define expt-a
(make-machine
'(continue n b val)
(list (list '= =) (list '- -) (list '* *))
'(machine
(assign continue (label expt-done))
expt-loop
(test (op =) (reg n) (const 0))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterexpt))
(assign n (op -) (reg n) (const 1))
(goto (label expt-loop))
afterexpt
(restore continue)
(assign val (op *) (reg b) (reg val))
(goto (reg continue))
immediate-answer
(assign val (const 1))
(goto (reg continue))
expt-done)
))
(set-register-contents! expt-a 'b 2)
(set-register-contents! expt-a 'n 2)
;;gosh> (register-trace expt-a 'val 'on)
;;on
;;gosh> (register-trace expt-a 'n 'on)
;;on
;;gosh> (start expt-a)
;;reg :[n] 2->1
;;reg :[n] 1->0
;;reg :[val] *unassigned*->1
;;reg :[val] 1->2
;;reg :[val] 2->4
;;done
;;gosh> (register-trace expt-a 'n 'off)
;;off
;;gosh> (set-register-contents! expt-a 'n 2)
;;done
;;gosh> (start expt-a)
;;reg :[val] 4->1
;;reg :[val] 1->2
;;reg :[val] 2->4
;;done
Exercise 5.19
;;; <n>の解釈を、問題で指定されている方法とは変えて、ブレークポイントは
;;; n番目のインストラクションを実行した後に(内部的には n+1 番目の
;;; インストラクションを実行する前に)働くようにする。
;;; 従って、label直後のインストラクションを実行する前にブレークポイント
;;; を働かせるためには、
;;; (set-breakpoint <machine> <label>)
;;; とする。
;;; <label> <n> は ex5.10 の形式を使用する。
;;; inst は ex5.17 の((text . proc) label-name1 ...) の形式を使用する。
;;; breakpointの設定は、上記の proc を breakpoint 処理を行う手続き(make-bp
;;; が返す手続き)に、トレースが出力されないよう text を 'breakに変更する。
;;; make-new-machine の内部手続き execute を instruction から break が返ると
;;; loop が終了するよう変更する。
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
(if (eq? trace 'on) (trace-out (car insts)))
(if (not (eq? make-bp ((instruction-execution-proc (car insts)))))
(begin
(set! instruction-counter (+ instruction-counter 1))
(execute))
)))))
;;; make-new-machine の message に proceed 用を追加する。
((eq? message 'execute) (execute))
;;; inst 変更用の手続きを追加する。
(define (set-instruction-text! inst text)
(set-car! (car inst) text))
;;; breakpoint が設定されている時はトレースを抑制する。
(define (trace-out inst)
(if (not (eq? (instruction-text inst) 'break))
(begin
(if (not (null? (instruction-labels inst)))
(for-each
(lambda (x) (format #t "trace:~s~%" x))
(instruction-labels inst)))
(format #t "trace: ~s~%" (instruction-text inst)))))
;;; 設定されている breakpoint を (inst1 inst2 ...) の形で保持
(define breakpoint-list '())
;;; breakpoint 設定
(define (set-breakpoint machine . label-exp)
(let ((tis (machine 'insts))
(name (label-name label-exp))
(offset (label-offset label-exp)))
(let ((insts (lookup-label-tis tis name offset)))
(let ((val (memq (car insts) breakpoint-list)))
(if (not val)
(begin (make-bp (car insts) name offset)
(set! breakpoint-list (cons (car insts) breakpoint-list))
(instruction-text (car insts)))
(warn "already set breakpoint :" label-exp))
))))
;;; breakpoint 停止後の再開。再開instructionの変更は未実装。
(define (proceed-machine machine . label-exp)
(if (eq? label-exp '())
(let ((insts (get-register-contents machine 'pc)))
(let ((val (memq (car insts) breakpoint-list)))
(if val
(begin
((instruction-execution-proc (car insts)) 'proceed)
(machine 'execute)
)
(error "Internal error -- PROCEED"))))
(begin
)
))
;;; breakpoint 解除
(define (cancel-breakpoint machine . label-exp)
(if (eq? label-exp '())
(begin ;all
(for-each (lambda (inst) (if (not (eq? inst '()))
((instruction-execution-proc inst) 'cancel)))
breakpoint-list)
(set! breakpoint-list '())
'done)
(begin ;the
(let ((tis (machine 'insts))
(name (label-name label-exp))
(offset (label-offset label-exp)))
(let ((insts (lookup-label-tis tis name offset)))
(let ((val (memq (car insts) breakpoint-list)))
(if val
(begin ((instruction-execution-proc (car isnts)) 'cancel)
(set-car! val '())
'ok)
(warn "not set breakpoint :" label-exp))
))))))
;;; breakpoint
(define (make-bp inst label offset)
(let ((proc (instruction-execution-proc inst)) ; save proc
(text (instruction-text inst)) ; save text
(flag 'break)) ; break on
(set-instruction-text! inst 'break) ; trace抑制
(set-instruction-execution-proc!
inst
(lambda arg
(if (null? arg)
;; run-time
(cond ((eq? flag 'break)
(format #t "break! ~s ~s~%" label offset)
make-bp)
((eq? flag 'proceed)
(set-instruction-text! inst 'break)
(set! flag 'break)
(proc))
(else (error "Undefined Breakflag :" flag)))
;; command
(cond ((eq? (car arg) 'proceed)
(set-instruction-text! inst text)
(set! flag 'proceed))
((eq? (car arg) 'cancel)
(set-instruction-execution-proc! inst proc))
(else (error "Undefined Breakflag :" arg))))))))
;;; ラベルとオフセットから insts を得る。
(define (lookup-label-tis tis name offset)
(define (forward insts n)
(if (= n 0)
insts
(if (null? (cdr insts))
(error "Out of range -- BREAKPOINT" (list name offset))
(forward (cdr insts) (- n 1)))))
(define (forward2 insts lead target)
(if (eq? lead target)
insts
(if (null? (cdr lead))
(error "Out of range -- BREAKPOINT" (list name offset))
(forward2 (cdr insts) (cdr lead) target))))
(let ((insts (find-tail (lambda (inst)
(and (not (null? (instruction-labels inst)))
(memq name (instruction-labels inst))))
tis)))
(if (not insts) (error "Undefined label -- BREAKPOINT" name))
(if (>= offset 0)
(forward insts offset)
(forward2 tis (forward tis (* offset -1)) insts))))
;;; test program
(define ex5.19
(make-machine
'(continue)
(list (list 'format format))
'(machine
(assign continue (label t1e))
(goto (label s -3))
t1e
(assign continue (label t2e))
(goto (label s -1))
t2e
(assign continue (label t3e))
(goto (label s 1))
t3e
(goto (label ex5.19.done))
;;
(perform (op format) (const #t) (const "stop s -2~%"))
(goto (reg continue))
(perform (op format) (const #t) (const "stop s~%"))
s
(goto (reg continue))
(perform (op format) (const #t) (const "stop s 2~%"))
(goto (reg continue))
;;
ex5.19.done)
))
;;gosh> (bp! 's -2) ; (set-breakpoint <machine> <label> <n>) の短縮形
;;break
;;gosh> (bp! 's)
;;break
;;gosh> (bp! 's 2)
;;break
;;gosh> (start ex5.19)
;;stop s -2
;;break! s -2
;;gosh> (go) ; (proceed-machine <machine>) の短縮形
;;stop s
;;break! s 0
;;gosh> (go)
;;stop s 2
;;break! s 2
;;gosh> (cbp!) ; (cancel-all-breakpoints <machine>) の短縮形
;;done
;;gosh> (start ex5.19)
;;stop s -2
;;stop s
;;stop s 2
;;done
最終更新：2009年06月14日 12:38
