;; file: 5_01.rkt
;; 5_01 / 5_02
;;
;; ref:
;; Figure 5.3: A specification of the GCD machine. (data-path + controller)
;; Figure 5.4: A GCD machine that reads inputs and prints results. (gdc + read / print)
;; 5.2 A Register-Machine Simulator - (define gcd-machine ...)
;; TODO Draw data-path and controller diagrams for this machine.
'(define (factorial n)
(define (iter product counter)
(if (> counter n)
product
(iter (* counter product)
(+ counter 1))))
(iter 1 1))
;; file: 5_02.rkt
;; 5_01 / 5_02
;; register-machine언어를 사용하여 iterative factorial 머신을 기술하라(연습문제 5.1에서 만든)
'(define (factorial n)
(define (iter product counter)
(if (> counter n)
product
(iter (* counter product)
(+ counter 1))))
(iter 1 1))
'(data-paths
(registers
((name n))
((name product)
(buttons ((name product<-1)
(source (constant 1)))
((name product<-mul)
(source (operation *)))))
((name count)
(buttons ((name counter<-1)
(source (constant 1)))
((name counter<-add)
(source (operation +))))))
(operations
((name factorial)
(inputs (register n)))
((name iter)
(inputs (constant 1) (constant 1)))
((name >)
(inputs (register a) (register b)))
((name *)
(inputs (register a) (register b)))
((name +)
(inputs (register a) (constant 0)))))
'(controller
(assign n (op read))
(assign product (const 1))
(assign counter (const 1))
loop-iter
(test (op =) (reg counter) (reg n))
(branch
(label done-iter))
(assign product (op *) (reg counter) (reg product))
(assign counter (op +) (reg counter) (const 1))
(goto
(label loop-iter))
done-iter
;; (read product)
)
;; file: 5_03.rkt
#|
(define (sqrt x)
(define (good-enough? guess)
(< (abs (- (square guess) x)) 0.001))
(define (improve guess)
(average guess (/ x guess)))
(define (sqrt-iter guess)
(if (good-enough? guess)
guess
(sqrt-iter (improve guess))))
(sqrt-iter 1.0))
- sqrt 각 버전의 머신 설계를 data-path 다이어그램으로, 레지스터 머신 언어로 controller 정의를 작성하여 설명.
|#
;; - good-enough?와 improve 연산자는 primitive로 사용 가능하다고 가정.
'(controller
(assign x (op read))
(assign guess (constant 1.0))
loop-sqrt-iter
(test (op good-enough?) (reg guess) (reg x))
(branch
(label done-loop-sqrt-iter))
(assign guess (op improve) (reg guess) (reg x))
(goto
(label loop-sqrt-iter))
done-loop-sqrt-iter
;; (read guess)
)
;; - 두 연산자를 산술 연산으로 확장하여 구현
'(controller
(assign x (op read))
(assign guess (constant 1.0))
loop
;; (define (good-enough? guess)
;; (< (abs (- (square guess) x)) 0.001))
(assign good-enough-s (op square) (reg guess)) ; (square guess)
(assign good-enough-m (op -) (reg good-enough-s) (reg x)) ; (- x)
(assign good-enough-abs (op abs) (reg good-enough-m)) ; (abs)
(test (op <) (register good-enough-abs) (constant 0.001)) ; (< 0.001)
(branch
(label done))
;; (define (improve guess)
;; (average guess (/ x guess)))
(assign improve-d (op /) (reg x) (reg guess)) ; (/ x guess)
(assign guess (op average) (reg guess) (reg improve-d)) ; (average)
(goto
(label loop))
done
;; (read guess)
)
;; file: 5_04.rkt
;; 5_04 / 5_07
(#%require (prefix racket: racket))
(racket:provide
expt-recur-controller
expt-iter-controller)
;; ref:
;; - Figure 5.11 - factorial
;; controller 랑 data-path다이어그램
;; Recursive exponentiation:
#|
(define (expt b n)
(if (= n 0)
1
(* b (expt b (- n 1)))))
|#
(define expt-recur-data-path
'(data-paths
(registers
((name b)
(buttons ((name b<-b)
(source (register b)))))
((name n)
(buttons ((name n<-n-1)
(source (operator -)))))
((name val)
(buttons ((name val<-expt-n-1)
(source (operator expt)))))
((name continue)
))
(operations
((name expt)
(inputs (register b) (register n)))
((name =)
(inputs (register n) (constant 0)))
((name -)
(inputs (register n) (constant 1)))
((name *)
(inputs (register b) (register val))))))
(define expt-recur-controller
'(controller
;; (assign b (op read))
;; (assign n (op read))
(assign continue
(label done))
loop
(test (op =) (reg n) (const 0)) ; (if (= n 0)
(branch
(label base-case))
(save continue)
;;(save n)
(assign n (op -) (reg n) (const 1))
(assign continue
(label after))
(goto
(label loop))
after
;;(restore n)
(restore continue)
(assign val (op *) (reg b) (reg val)) ; (* b (expt b (- n 1)))))
(goto
(reg continue))
base-case
(assign val (const 1)) ; 1
(goto
(reg continue))
done
;; (read val)
))
;; Iterative exponentiation:
#|
(define (expt b n)
(define (expt-iter counter product)
(if (= counter 0)
product
(expt-iter (- counter 1)
(* b product))))
(expt-iter n 1))
|#
(define expt-iter-data-path
'(data-paths
(registers
((name b))
((name n))
((name counter)
(buttons ((name counter<-n)
(source (register n)))
((name counter<-minus)
(source (operation -)))))
((name product)
(buttons ((name product<-1)
(source (constant 1)))
((name counter<-mul)
(source (operation *))))))
(operations
((name expt)
(inputs (register b) (register n)))
((name expt-iter)
(inputs (register n) (constant 1)))
((name =)
(inputs (register counter) (constant 0)))
((name -)
(inputs (register counter) (constant 1)))
((name *)
(inputs (register b) (register product))))))
(define expt-iter-controller
'(controller
;; (assign b (op read))
;; (assign n (op read))
(assign counter (reg n))
(assign product (const 1))
loop-iter
(test (op =) (reg counter) (const 0))
(branch
(label done-iter))
(assign counter (op -) (reg counter) (const 1))
(assign product (op *) (reg b) (reg product))
(goto
(label loop-iter))
done-iter
;; (read product)
))
;; file: 5_05.rkt
;; ref:
;; - Figure 5.11 - factorial
;; - Figure 5.12 - fibonacchi
#|
TOOD 팩토리얼(factorial)과 피보나치(Fibonacci) 머신을 손으로 시뮬레이션하시오.
이때, 최소한 한 번의 재귀 호출이 실행되는 nontrivial 입력을 사용하시오.
실행의 각 중요한 지점에서 스택의 내용을 보여주시오.
|#
;; file: 5_06.rkt
;; ref:
;; - Figure 5.12
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
#|
Ben Bitdiddle 은 피보나치 머신의 컨트롤러 시퀀스에 불필요한 save와 restore 명령이 포함되어 있으며,
이를 제거하면 더 빠른 머신을 만들 수 있는 것을 알아차렸습니다.
이 명령들은 어디에 있습니까?
|#
(#%require "../allcode/ch5-regsim.rkt")
'(define (fib n)
(if (< n 2)
n
(+ (fib (- n 1)) (fib (- n 2)))))
(define fib-controller
'(controller
(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) ; - save1 continue
(assign continue
(label afterfib-n-1))
(save n) ; save old value of n ; - save2 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) ; - restore1 n
;;(restore continue) ; - restore2 continue <<------
;; set up to compute Fib(n - 2)
(assign n (op -) (reg n) (const 2))
;;(save continue) ; - save3 continue <<------
(assign continue
(label afterfib-n-2))
(save val) ; save Fib(n - 1) ; - save4 val
(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) ; - restore3 val
(restore continue) ; - restore4 continue
(assign val ; Fib(n - 1) + Fib(n - 2)
(op +)
(reg val)
(reg n))
(goto ; return to caller,
(reg continue)) ; answer is in val
immediate-answer
(assign val
(reg n)) ; base case: Fib(n) = n
(goto
(reg continue))
fib-done))
(define fib-machine
(make-machine
'(n continue val)
(list (list '< <)
(list '- -)
(list '+ +))
(rest fib-controller)
))
(define (fib n)
(set-register-contents! fib-machine 'n n)
(start fib-machine)
(get-register-contents fib-machine 'val))
(check-equal? (fib 0)
0)
(check-equal? (fib 1)
1)
(check-equal? (fib 2)
1)
(check-equal? (fib 3)
2)
(check-equal? (fib 10)
55)
;; file: 5_07.rkt
;; 5_04 / 5_07
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
;; simulator를 사용해여 머신을 테스트라하(연습문제 5.4에서 디자인한)
(#%require "../allcode/ch5-regsim.rkt")
(#%require "5_04.rkt")
(define add-machine
(make-machine
;; 레지스터 목록
'(n val sum continue)
;; 연산 목록
(list (list '+ +)
(list '- -)
(list '= =))
;; 컨트롤러
'(
#;(assign continue (label done))
loop
(test (op =) (reg n) (const 0)) ; if n == 0
(branch (label done)) ; break
(assign sum (op +) (reg sum) (reg val)) ; sum += val
(assign n (op -) (reg n) (const 1)) ; n -= 1
(goto (label loop))
done)))
(~> add-machine
(set-register-contents! 'val 3)
(check-equal? 'done))
(~> add-machine
(set-register-contents! 'n 5)
(check-equal? 'done))
(~> add-machine
(set-register-contents!'sum 0) ; 결과 저장용
(check-equal? 'done))
(~> add-machine
(start)
(check-equal? 'done))
(~> add-machine
(get-register-contents 'sum)
(check-equal? 15))
(define gcd-machine
(make-machine
'(a b t)
(list (list 'rem remainder) (list '= =))
'(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(~> gcd-machine
(set-register-contents! 'a 206)
(check-equal? 'done))
(~> gcd-machine
(set-register-contents! 'b 40)
(check-equal? 'done))
(~> gcd-machine
(start)
(check-equal? 'done))
(~> gcd-machine
(get-register-contents 'a) ; 결과: 2 (206과 40의 GCD)
(check-equal? 2))
;; ================
(define expt-recur-machine
(make-machine
'(b n continue val)
(list (list '= =)
(list '- -)
(list '* *))
(rest expt-recur-controller)))
(define (expr-recur b n)
(set-register-contents! expt-recur-machine 'b b)
(set-register-contents! expt-recur-machine 'n n)
(start expt-recur-machine)
(get-register-contents expt-recur-machine 'val))
(check-equal? (expr-recur 2 0)
1)
(check-equal? (expr-recur 2 10)
1024)
;; ================
(define expt-iter-machine
(make-machine
'(b n counter product)
(list (list '= =)
(list '- -)
(list '* *))
(rest expt-iter-controller)
))
(define (expr-iter b n)
(set-register-contents! expt-iter-machine 'b b)
(set-register-contents! expt-iter-machine 'n n)
(start expt-iter-machine)
(get-register-contents expt-iter-machine 'product))
(check-equal? (expr-iter 2 0)
1)
(check-equal? (expr-iter 2 10)
1024)
;; file: 5_08.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
(_extract-labels origin-extract-labels)))
;; 시율레이터에서 there까지 돌렸을 때 레지스터 a 값은?
(define expr
'(start
(goto (label here))
here
(assign a (const 3))
(goto (label there))
here
(assign a (const 4))
(goto (label there))
there))
(define add-machine
(make-machine
'(a)
'()
expr))
(~> add-machine
(start)
(check-equal? 'done))
(~> add-machine
(get-register-contents 'a)
(check-equal? 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)
;; before
;; (receive insts
;; (cons (make-label-entry next-inst
;; insts)
;; labels))
;;
;; after
(if (assoc next-inst labels)
(error "duplicate labels:" next-inst)
(receive insts
(cons (make-label-entry next-inst
insts)
labels)))
(receive (cons (make-instruction next-inst)
insts)
labels)))))))
(override-extract-labels! extract-labels)
(check-exn
#rx"duplicate labels: here"
(lambda ()
(extract-labels expr (lambda (insts labels) nil))))
;; file: 5_09.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
machine operation을 다룰때 (constant / register 뿐만 아니라) label에도 다룰 수 있도록 되었는데,
expression을 처리하는 프로시져를 수정하여 constant / register 에만 사용 가능하도록 조건을 강제해라.
|#
(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
(_make-operation-exp origin-make-operation-exp)))
(define (is-operation-operand-exp? exp)
(cond ((constant-exp? exp)
true)
((register-exp? exp)
true)
((label-exp? exp)
false)
(else
false)))
(define (make-operation-exp exp machine labels operations)
(let ((op (lookup-prim (operation-exp-op exp) operations))
(aprocs
(map (lambda (e)
;; before
;; (make-primitive-exp e machine labels)
;;
;; after
(if (not (is-operation-operand-exp? e))
(error "is not operation operand exp:" e)
(make-primitive-exp e machine labels))
)
(operation-exp-operands exp))))
(lambda ()
(apply op (map (lambda (p) (p)) aprocs)))))
(override-make-operation-exp! make-operation-exp)
(check-exn
#rx"is not operation operand exp: \\(label hello\\)"
(lambda ()
(make-machine
'(a b c x)
(list (list '+ +))
'(
hello
(assign x (const 1))
(assign a (op +) (reg x) (reg x))
(assign b (op +) (const 1) (const 2))
(assign c (op +) (label hello) (label hello))
))
))
;; file: 5_10.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
새로운 문법을 추가할 수 있으면 추가해봐라.
|#
(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
(_make-execution-procedure origin-make-execution-procedure)))
(define (make-inc inst machine labels operations pc)
(display (second inst))
(newline)
(let* ((register-name (second inst))
(target (get-register machine register-name))
(r (get-register machine register-name)))
(lambda ()
(set-contents! target (inc (get-contents r)))
(advance-pc pc))))
(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))
((eq? (first inst) 'inc)
(make-inc inst machine labels ops pc))
(else (error "Unknown instruction type -- ASSEMBLE"
inst))))
(override-make-execution-procedure! make-execution-procedure)
(define dummy-machine
(make-machine
'(x)
'()
'((assign x (const 1))
(inc x)
(inc x)
)))
(~> dummy-machine
(start)
(check-equal? 'done))
(~> dummy-machine
(get-register-contents 'x)
(check-equal? 3))
;; file: 5_11.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
(racket:provide
make-kv-stack)
#|
a)
(restore y)는 스택에 저장된 마지막 값을, 그 값이 어떤 레지스터에서 왔는지 상관없이 y에 넣습니다.
이것이 우리 시뮬레이터의 동작 방식입니다.
이 동작을 활용하여 5.1.4의 피보나치 머신(그림 5.12)에서 하나의 명령어를 제거하는 방법을 보여주세요.
|#
(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
(_make-save origin-make-save)
(_make-restore origin-make-restore)))
(define (dummy-machine-maker)
(make-machine
'(x y)
'()
'((assign x (const 1))
(assign y (const 2))
(save y)
(save x)
(restore y)
)
))
(define dummy-machine (dummy-machine-maker))
(~> dummy-machine
(start)
(check-equal? 'done))
(~> dummy-machine
(get-register-contents 'x)
(check-equal? 1))
(~> dummy-machine
(get-register-contents 'y)
(check-equal? 1))
;; a) (restore y)는 스택에 마지막 저장한 값으로 y를 설정.
(define fib-controller
'(controller
(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) ; - save1 continue
(assign continue
(label afterfib-n-1))
(save n) ; save old value of n ; - save2 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) ; - restore1 n
(restore continue) ; - restore2 continue
;; set up to compute Fib(n - 2)
(assign n (op -) (reg n) (const 2))
(save continue) ; - save3 continue
(assign continue
(label afterfib-n-2))
(save val) ; save Fib(n - 1) ; - save4 val
(goto (label fib-loop))
afterfib-n-2 ; upon return, val contains Fib(n - 2)
;; before a)
;; (assign n (reg val)) ; n now contains Fib(n - 2)
;; (restore val) ; val now contains Fib(n - 1) ; - restore3 val
;;
;; after a)
(restore n) ; <<<<<<<
(restore continue) ; - restore4 continue
(assign val ; Fib(n - 1) + Fib(n - 2)
(op +)
(reg val)
(reg n))
(goto ; return to caller,
(reg continue)) ; answer is in val
immediate-answer
(assign val
(reg n)) ; base case: Fib(n) = n
(goto
(reg continue))
fib-done))
(define fib-machine
(make-machine
'(n continue val)
(list (list '< <)
(list '- -)
(list '+ +))
(rest fib-controller)
))
(define (fib n)
(set-register-contents! fib-machine 'n n)
(start fib-machine)
(get-register-contents fib-machine 'val))
(check-equal? (fib 0)
0)
(check-equal? (fib 1)
1)
(check-equal? (fib 2)
1)
(check-equal? (fib 3)
2)
(check-equal? (fib 10)
55)
#|
b)
(restore y)는 스택에 저장된 마지막 값을 y에 넣지만, 그 값이 y에서 저장된 경우에만 해당됩니다.
그렇지 않으면 오류를 표시합니다.
시뮬레이터를 이 방식으로 동작하도록 수정하세요.
save를 변경하여 값과 함께 레지스터 이름을 스택에 저장해야 합니다.
|#
(define (make-save-b inst machine stack pc)
(let* ((reg-name (stack-inst-reg-name inst))
(reg (get-register machine reg-name)))
(lambda ()
(push stack (cons reg-name (get-contents reg)))
(advance-pc pc))))
(define (make-restore-b inst machine stack pc)
(let* ((restore-reg-name (stack-inst-reg-name inst))
(reg (get-register machine restore-reg-name)))
(lambda ()
(let* ((poped (pop stack))
(pop-reg-name (first poped))
(pop-reg-val (rest poped)))
(if (not (eq? restore-reg-name pop-reg-name))
(error "restore-reg-name:" restore-reg-name 'pop-reg-name: pop-reg-name))
(set-contents! reg pop-reg-val)
(advance-pc pc)))))
(override-make-save! make-save-b)
(override-make-restore! make-restore-b)
(set! dummy-machine (dummy-machine-maker))
(check-exn
#rx"restore-reg-name: y pop-reg-name: x"
(lambda ()
(start dummy-machine)))
#|
c)
(restore y)는 y 이후에 다른 레지스터들이 저장되고 복원되지 않았더라도, y에서 저장된 마지막 값을 y에 넣습니다.
시뮬레이터를 이 방식으로 동작하도록 수정하세요.
각 레지스터에 별도의 스택을 연결해야 합니다.
initialize-stack 작업이 모든 레지스터 스택을 초기화하도록 해야 합니다.
|#
(reset!)
(define (make-kv-stack)
(define (kv-stack-init!)
(list 'kv-stack))
(define (kv-stack-push! kv-pop key new-value)
(define (last-pair lst)
(if (null? (rest lst))
lst
(last-pair (rest lst))))
(let ((rest-kv-pop (rest kv-pop)))
(if (null? rest-kv-pop)
(begin
(set-cdr! kv-pop (list (list key (list new-value))))
kv-pop)
(let loop ((current rest-kv-pop))
(cond
((null? current)
(set-cdr! (last-pair rest-kv-pop)
(list (list key (list new-value))))
kv-pop)
(else
(let* ((key-stack (first current))
(k (first key-stack))
(stack (second key-stack)))
(if (eq? k key)
(begin
(set-car! (rest key-stack) (cons new-value stack))
kv-pop)
(loop (rest current))))))))))
(define (kv-stack-pop! kv-pop key)
(let ((rest-kv-pop (rest kv-pop)))
(let loop ((current rest-kv-pop))
(cond
((null? current)
(error "Key not found:" key))
(else
(let* ((key-stack (first current))
(k (first key-stack))
(stack (second key-stack)))
(if (eq? k key)
(if (null? (second key-stack))
(error "Value list is empty for key:" key)
(let ((value (first stack)))
(set-car! (rest key-stack) (rest stack))
value))
(loop (rest current)))))))))
(let ((s (kv-stack-init!)))
(define (push x)
(let ((k (first x))
(v (rest x)))
(kv-stack-push! s k v)))
(define (pop k)
(kv-stack-pop! s k))
(define (initialize)
(set! s (kv-stack-init!))
'done)
(define (stack)
s)
(define (dispatch message)
(cond ((eq? message 'push) push)
((eq? message 'pop) pop)
((eq? message 'initialize) (initialize))
((eq? message 'stack) (stack))
(else (error "Unknown request -- STACK"
message))))
dispatch))
(define (make-save-c inst machine stack pc)
(let* ((reg-name (stack-inst-reg-name inst))
(reg (get-register machine reg-name)))
(lambda ()
(push stack (cons reg-name (get-contents reg)))
(advance-pc pc))))
(define (make-restore-c inst machine stack pc)
(let* ((restore-reg-name (stack-inst-reg-name inst))
(reg (get-register machine restore-reg-name)))
(lambda ()
;; (pop stack) 함수를 호출하는 곳이 여기에만 있음.
;; (pop stack)함수를 override 할 수 있게 수정하는 대신
;; (stack 'pop)으로 직접 콜하는 방식으로 대신함.
(let* ((poped ((stack 'pop) restore-reg-name)))
(set-contents! reg poped)
(advance-pc pc)))))
(override-make-stack! make-kv-stack)
(override-make-save! make-save-c)
(override-make-restore! make-restore-c)
(set! dummy-machine (dummy-machine-maker))
(~> dummy-machine
(start)
(check-equal? 'done))
(~> dummy-machine
(get-register-contents 'x)
(check-equal? 1))
(~> dummy-machine
(get-register-contents 'y)
(check-equal? 2))
(~> ((dummy-machine 'stack) 'stack)
(check-equal?
'(kv-stack (y ()) (x (1)))))
;; file: 5_12.rkt
;; ref:
;; - Figure 5.11: A recursive factorial machine.
;; - Figure 5.12: Controller for a machine to compute Fibonacci numbers.
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
(racket:provide
make-set
make-kv-set)
#|
어셈블러를 확장하여 기계 모델에 다음 정보를 저장하도록 하세요:
1. 모든 명령어의 목록(중복 제거, 명령어 유형(assign, goto 등)으로 정렬됨).
2. 진입점(entry point)을 저장하는 데 사용되는 레지스터의 목록(중복 없이, goto 명령어에서 참조된 레지스터).
3. save되거나 restore되는 레지스터의 목록(중복 없이).
4. 각 레지스터에 대해, 해당 레지스터에 할당되는 소스(source)의 목록(중복 없이).
- 예를 들어, 그림 5.11의 팩토리얼 기계에서 레지스터 val의 소스는 (const 1)과 ((op *) (reg n) (reg val))입니다.
기계의 메시지 패싱 인터페이스를 확장하여 이 새로운 정보에 접근할 수 있도록 하세요.
분석기를 테스트하기 위해 그림 5.12의 피보나치 기계를 정의하고, 생성한 목록들을 확인하세요.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
#|
중복 안되며서 추가가능한 자료구조가 필요함.
set / 그리고 kv-set
1~4 이름 짓고
1. instruction-set
2. entry-register-set
3. save-restore-register-set
4. register-source-kv-set
그리고 controller-text처리하는 곳을 따라가야함
- 호출부 make-machine
- 정보 저장하려면 make-new-machine
- 그리고 참고용 install-instruction-sequence를 처리하는
-(assemble controller-text machine)함수를 보면 extract-labels로 insts를 얻어올 수 있음.
|#
(define (make-set)
(define (set-init!)
(list 'set))
(define (contains? set x)
(member x (rest set)))
(define (add! set x)
(if (contains? set x)
set
(let ((y (rest set)))
(set-cdr! set (cons x (rest set)))
set)))
(define (del! set x)
(let loop ((prev set)
(current (rest set)))
(cond ((null? current) set)
((equal? (car current) x)
(set-cdr! prev (cdr current))
set)
(else
(loop current (cdr current))))))
(let ((s (set-init!)))
(define (add x)
(add! s x))
(define (del x)
(del! s x))
(define (set)
s)
(define (contains x)
(contains? s x))
(define (dispatch message)
(cond ((eq? message 'set) (set))
((eq? message 'add) add)
((eq? message 'del) del)
((eq? message 'contains?) contains)
(else (error "Unknown request -- SET" message))))
dispatch))
(define my-set (make-set))
(check-equal? (my-set 'set) '(set))
(check-equal? ((my-set 'add) 1) '(set 1))
(check-equal? ((my-set 'add) 2) '(set 2 1))
(check-equal? ((my-set 'add) 2) '(set 2 1))
(check-equal? ((my-set 'del) 2) '(set 1))
(check-equal? ((my-set 'del) 2) '(set 1))
(define (make-kv-set)
(define (kv-set-init!)
(list 'kv-set))
(define (contains? lst x)
(member x lst))
(define (kv-set-add! kv-set key value)
(let ((rest-kv-set (rest kv-set)))
(if (null? rest-kv-set)
(begin
(set-cdr! kv-set (list (list key (list value))))
kv-set)
(let loop ((current rest-kv-set))
(cond
((null? current)
(set-cdr! (last-pair rest-kv-set)
(list (list key (list value))))
kv-set)
(else
(let* ((key-set (first current))
(k (first key-set))
(values (second key-set)))
(if (eq? k key)
(begin
(if (not (contains? values value))
(set-car! (rest key-set) (cons value values)))
kv-set)
(loop (rest current))))))))))
(define (last-pair lst)
(if (null? (rest lst))
lst
(last-pair (rest lst))))
(let ((s (kv-set-init!)))
(define (add k v)
(kv-set-add! s k v))
(define (set)
s)
(define (dispatch message)
(cond ((eq? message 'add) add)
((eq? message 'set) (set))
(else (error "Unknown request -- KV-SET" message))))
dispatch))
(define my-kv-set (make-kv-set))
(check-equal? (my-kv-set 'set) '(kv-set))
(check-equal? ((my-kv-set 'add) 'k1 1) '(kv-set (k1 (1))))
(check-equal? ((my-kv-set 'add) 'k1 2) '(kv-set (k1 (2 1))))
(check-equal? ((my-kv-set 'add) 'k1 2) '(kv-set (k1 (2 1))))
;; ===========
(racket:require "../allcode/ch5-regsim.rkt")
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(instruction-set nil) ; 1.
(entry-register-set nil) ; 2.
(save-restore-register-set nil) ; 3.
(register-source-kv-set (make-kv-set)) ; 4.
)
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(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)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
(execute)))))
(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 'instruction-set) instruction-set) ; 1.
((eq? message 'entry-register-set) entry-register-set) ; 2.
((eq? message 'save-restore-register-set) save-restore-register-set) ; 3.
((eq? message 'register-source-kv-set) register-source-kv-set) ; 4.
((eq? message 'install-instruction-set) ; 1.
(lambda (instructions)
(set! instruction-set instructions)))
((eq? message 'install-entry-register-set) ; 2.
(lambda (registers)
(set! entry-register-set registers)))
((eq? message 'install-save-restore-register-set) ; 3.
(lambda (save-restore-registers)
(set! save-restore-register-set save-restore-registers)))
((eq? message 'install-register-source-kv-set) ; 4.
(lambda (register-source-list)
(map (lambda (x)
(let ((k (first x))
(v (second x)))
((register-source-kv-set 'add) k v)))
register-source-list)
(register-source-kv-set 'set)))
((eq? message 'operations) the-ops)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(override-make-new-machine! make-new-machine)
(define (contains? lst x)
(cond ((null? lst) false)
((equal? x (first lst)) true)
(else (contains? (rest lst) x))))
(define (remove-duplicates lst)
(define (iter acc lst)
(cond ((null? lst)
(reverse acc))
((contains? acc (first lst))
(iter acc (rest lst)))
(else
(iter (cons (first lst) acc) (rest lst)))))
(iter '() lst))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
(define (get-all-instructions controller-text)
(~> controller-text
(extract-labels
(lambda (insts labels)
(~>> insts
(map first)
(map (lambda (x) (first x))))))
(remove-duplicates)))
(define (get-entry-registers controller-text)
(~> controller-text
(extract-labels
(lambda (insts labels)
(~>> insts
(map first)
(filter (lambda (x)
(eq? 'goto (first x))))
(flatmap (lambda (x)
(filter (lambda (xx)
(register-exp? xx))
x)))
(map second)
(remove-duplicates))))))
(define (get-save-restore-registers controller-text)
(~> controller-text
(extract-labels
(lambda (insts labels)
(~>> insts
(map first)
(filter (lambda (x)
(or (eq? 'save (first x))
(eq? 'restore (first x)))))
(map second ))))
(remove-duplicates)))
(define (get-register-source-list controller-text)
(~> controller-text
(extract-labels
(lambda (insts labels)
(~>> insts
(map first)
(filter (lambda (x)
(eq? 'assign (first x))))
(map rest)
)))
(~>>
(map (lambda (x)
(let ((reg (first x))
(source (rest x)))
(list reg source)))))))
(check-equal?
; 1. all-instructions
'(assign test branch save goto restore)
(~> figure-5-11
(rest)
(get-all-instructions)))
(check-equal?
; 2. entry-register-set
'(continue)
(~> figure-5-11
(rest)
(get-entry-registers)))
(check-equal?
; 3. save-restore-registers
'(continue n)
(~> figure-5-11
(rest)
(get-save-restore-registers)))
(check-equal?
; 4. register-source-list
'((continue ((label fact-done)))
(n ((op -) (reg n) (const 1)))
(continue ((label after-fact)))
(val ((op *) (reg n) (reg val)))
(val ((const 1))))
(~> figure-5-11
(rest)
(get-register-source-list)))
(define (make-machine register-names ops controller-text)
(let ((machine (make-new-machine)))
(for-each (lambda (register-name)
((machine 'allocate-register) register-name))
register-names)
((machine 'install-operations) ops)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
((machine 'install-instruction-set) ; 1.
(get-all-instructions controller-text))
((machine 'install-entry-register-set) ; 2.
(get-entry-registers controller-text))
((machine 'install-save-restore-register-set) ; 3.
(get-save-restore-registers controller-text))
((machine 'install-register-source-kv-set) ; 4.
(get-register-source-list controller-text))
machine))
(override-make-machine! make-machine)
(define machine-figure-5-11
(make-machine
'(n val continue)
(list (list '= =)
(list '- -)
(list '* *))
(rest figure-5-11)))
(check-equal? (machine-figure-5-11 'instruction-set)
'(assign test branch save goto restore))
(check-equal? (machine-figure-5-11 'entry-register-set)
'(continue))
(check-equal? (machine-figure-5-11 'save-restore-register-set)
'(continue n))
(check-equal? ((machine-figure-5-11 'register-source-kv-set) 'set)
'(kv-set
(continue (((label after-fact))
((label fact-done))))
(n (((op -) (reg n) (const 1))))
(val (((const 1))
((op *) (reg n) (reg val))))))
(define machine-figure-5-12
(make-machine
'(n val continue)
(list (list '< <)
(list '- -)
(list '+ +))
(rest figure-5-12)))
(check-equal? (machine-figure-5-12 'instruction-set)
'(assign test branch save goto restore))
(check-equal? (machine-figure-5-12 'entry-register-set)
'(continue))
(check-equal? (machine-figure-5-12 'save-restore-register-set)
'(continue n val))
(check-equal? ((machine-figure-5-12 'register-source-kv-set) 'set)
'(kv-set
(continue (((label afterfib-n-2))
((label afterfib-n-1))
((label fib-done))))
(n (((reg val))
((op -) (reg n) (const 2))
((op -) (reg n) (const 1))))
(val (((reg n))
((op +) (reg val) (reg n))))))
;; file: 5_13.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
(racket:provide
make-machine-5-13)
#|
레지스터 목록을 make-machine에 인자로 넘기는 대신 컨트롤러 시퀀스를 사용하도록 해라.
make-machine에서 레지스터를 미리 할당하는 대신, 명령어 조립 중에 레지스터가 처음 등장할 때 하나씩 할당할 수 있다.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
(define (contains? lst x)
(cond ((null? lst) false)
((equal? x (first lst)) true)
(else (contains? (rest lst) x))))
(define (remove-duplicates lst)
(define (iter acc lst)
(cond ((null? lst)
(reverse acc))
((contains? acc (first lst))
(iter acc (rest lst)))
(else
(iter (cons (first lst) acc) (rest lst)))))
(iter '() lst))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
(define (get-all-registers controller-text)
(~> controller-text
(extract-labels
(lambda (insts labels)
(~>> insts
(map first)
(flatmap (lambda (x)
(filter (lambda (xx)
(register-exp? xx))
x)))
(map second)
(remove-duplicates))))))
(define (make-new-machine-5-13)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '()))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(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)
;; 5.13
;;
;; before
;; (error "Unknown register:" name)
;;
;; after
;; make-machine에서 레지스터를 미리 할당하는 대신,
;; 명령어 조립 중에 레지스터가 처음 등장할 때 하나씩 할당할 수 있다.
(begin
(allocate-register name)
(lookup-register name)))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
(execute)))))
(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)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(define (make-machine-5-13 ops controller-text)
(let ((machine (make-new-machine-5-13)))
;; NOTE(pyoung): 이런 식으로 먼저 구문 분석해서 레지스터를 미리 추가할 수 도 있다.
;; (let ((register-names (get-all-registers controller-text)))
;; (for-each (lambda (register-name)
;; ((machine 'allocate-register) register-name))
;; register-names))
((machine 'install-operations) ops)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
(define machine-figure-5-11
(make-machine-5-13
(list (list '= =)
(list '- -)
(list '* *))
(rest figure-5-11)))
(~> machine-figure-5-11
(set-register-contents! 'n 10)
(check-equal? 'done))
(~> machine-figure-5-11
(start)
(check-equal? 'done))
(~> machine-figure-5-11
(get-register-contents 'val)
(check-equal? 3628800))
(define machine-figure-5-12
(make-machine-5-13
(list (list '< <)
(list '- -)
(list '+ +))
(rest figure-5-12)))
(~> machine-figure-5-12
(set-register-contents! 'n 10)
(check-equal? 'done))
(~> machine-figure-5-12
(start)
(check-equal? 'done))
(~> machine-figure-5-12
(get-register-contents 'val)
(check-equal? 55))
;; file: 5_14.rkt
;; ref:
;; figure-5-11
;; figure-5-4
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
1. figure-5-11에 대해 다양한 n에 대한 필요한 푸시 횟수와 최대 스택 깊이를 측정하시오.
2. 임의의 n > 1 에 대해, n! 을 계산할 때 사용되는 총 푸시 연산 횟수와 최대 스택 깊이에 대한 n 의 함수로서의 공식을 구하라.
- 각각은 n의 선형 함수이며, 따라서 두 개의 상수로 결정된다는 점에 유의하시오.
- 통계 정보를 출력하려면, 팩토리얼 기계에 스택을 초기화하고 통계를 출력하는 명령어를 추가해야 합니다.
3. 또한, 기계를 수정하여 n 값을 반복적으로 읽고, 팩토리얼을 계산하며, 결과를 출력하도록 할 수 있습니다(그림 5.4의 GCD 기계에서 했던 것처럼).
- 이렇게 하면 get-register-contents, set-register-contents!, start를 반복적으로 호출하지 않아도 됩니다.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
(override-make-stack! make-stack-5-2-4)
(define (run-machine-figure-5-11 n)
(define machine-figure-5-11
(make-machine
'(n continue val)
(list (list '= =)
(list '- -)
(list '* *))
(rest figure-5-11)))
(~> machine-figure-5-11
(set-register-contents! 'n n))
(~> machine-figure-5-11
(start))
((machine-figure-5-11 'stack) 'print-statistics))
(check-output?
"\n(total-pushes = 2 maximum-depth = 2)"
;; n 2
;; p 2
;; d 2
(run-machine-figure-5-11 2))
(check-output?
"\n(total-pushes = 8 maximum-depth = 8)"
;; n 5
;; p 8
;; d 8
(run-machine-figure-5-11 5))
(check-output?
"\n(total-pushes = 18 maximum-depth = 18)"
;; n 10
;; p 18
;; d 18
(run-machine-figure-5-11 10))
#|
따라서 p = d = 2n - 2
|#
(define figure-5-11-loop
;; factorial
'(controller
(perform (op initialize-stack)) ; ** 5.14
(assign n (op read)) ; ** 5.14
(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
(perform (op print-stack-statistics)) ; ** 5.14
(goto (label controller)) ; ** 5.14
))
(define (run-machine-figure-5-11-loop)
(define machine-figure-5-11-loop
(make-machine
'(n continue val)
(list (list '= =)
(list '- -)
(list '* *)
(list 'read read) ; ** 5.14
)
figure-5-11-loop))
(~> machine-figure-5-11-loop
(start)))
;; 루프 실행
;; (run-machine-figure-5-11-loop)
;; file: 5_15.rkt
;; 5_15 / 5_16 / 5_17 / 5_19
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
연습문제 5.15: 레지스터 머신 시뮬레이션에 명령어 카운팅 기능을 추가하시오.
즉, 머신 모델이 실행된 명령어의 수를 추적하도록 하시오.
머신 모델의 인터페이스를 확장하여 명령어 카운트 값을 출력하고 카운트를 0으로 재설정하는 새로운 메시지를 수락하도록 하시오.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
#;(override-make-stack! make-stack-5-2-4)
(define (make-new-machine-5-15)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(instruction-count 0))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))
;; added : 5-15
(list 'initialize-instruction-count
(lambda ()
(set! instruction-count 0)))
(list 'print-instruction-count
(lambda ()
(newline)
(display (list 'print-instruction-count '= instruction-count))))))
(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)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
;; added: 5-15
(set! instruction-count (inc instruction-count))
(execute)))))
(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)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(override-make-new-machine! make-new-machine-5-15)
(define dummy-machine
(make-machine
'(x y)
'()
'((assign x (const 1)) ; 0 -> 1
(assign y (const 2)) ; 1 -> 2
(perform (op print-instruction-count)) ; 출력(2) -> 3
(perform (op print-instruction-count)) ; 출력(3) -> 4
(perform (op initialize-instruction-count)) ; reset(0) -> 1
(perform (op print-instruction-count)) ; 출력(1) -> 2
)
))
(check-output?
"
(print-instruction-count = 2)
(print-instruction-count = 3)
(print-instruction-count = 1)"
(start dummy-machine))
;; file: 5_16.rkt
;; 5_15 / 5_16 / 5_17 / 5_19
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
연습문제 5.16: 시뮬레이터를 확장하여 명령어 추적 기능을 제공하시오.
즉, 각 명령어가 실행되기 전에 시뮬레이터가 해당 명령어의 텍스트를 출력하도록 하시오.
머신 모델이 trace-on과 trace-off 메시지를 수락하여 추적 기능을 켜고 끌 수 있도록 하시오.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
(define (make-new-machine-5-16)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(is-trace-on false) ; added : 5-16
)
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))
;; added : 5-16
(list 'trace-on
(lambda ()
(set! is-trace-on true)))
(list 'trace-off
(lambda ()
(set! is-trace-on false)))))
(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)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
;; added : 5-16
(if is-trace-on
(begin
(newline)
(display (first (first insts)))))
((instruction-execution-proc (first insts)))
(execute)))))
(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)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(override-make-new-machine! make-new-machine-5-16)
(define dummy-machine
(make-machine
'(x y)
'()
'((assign x (const 1))
(assign y (const 2))
(perform (op trace-on))
(assign x (const 1))
(assign y (const 2))
(perform (op trace-off))
(assign x (const 1))
(assign y (const 2))
)
))
(check-output?
"
(assign x (const 1))
(assign y (const 2))
(perform (op trace-off))"
(start dummy-machine))
;; file: 5_17.rkt
;; 5_15 / 5_16 / 5_17 / 5_19
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
연습문제 5.17: 연습문제 5.16의 명령어 추적 기능을 확장하여,
명령어를 출력하기 전에 시뮬레이터가 컨트롤러 시퀀스에서 해당 명령어 바로 앞에 오는 레이블을 출력하도록 하시오.
이 작업이 명령어 카운팅(연습문제 5.15)과 간섭하지 않도록 주의해서 구현해야 합니다.
시뮬레이터가 필요한 레이블 정보를 유지하도록 해야 합니다.
|#
#|
extract-labels
text를 insts랑 labels로 분리.
insts : ((insruction) ...)
labels: ((labelA instruction-A1 instruction-A2 ...) (labelB instruction-B1 instruction-B2 ...) ...)
assemble에서
insts: ((insruction) ...)
update-insts!
insts : ((instruction . func) ...)
insts가 바뀌면서 메모리를 공유하는 labels도 따라 바뀐다.
labels: ((labelA (instruction-A1 . func) (instruction-A2 . func) ...) ...)
|#
#|
기존 코드에서 pc가 어셈의 instruction pointer처럼 index기반으로 동작했으면, 수정하기 보다 편했으려나...
인덱스 기반으로 싹 바꿀 마음도 있었지만, 대대적 수정이 있을꺼라 패스.
assemble / extract-labels / update-insts!에서 instruction안에 label정보를 찡겨 넣을까 생각해 봤지만,
대신 labels를 머신에 찡겨넣고, labels에서 instruction을 찾는 방식이 좋겠다.
- extract-labels에서 나온 labels 구조가 좀 골때림.
- 처음에는 각 labels마다 instruction을 담는줄 알아서 find시 첫번째 label만 나오길레 이상해서 보니
- labels 아레로 나온 Instruction전부를 포함하는 구조로 됨.
- 그래서 미리 reverse를 시켜 줘서 find가 잘 찾도록 수정
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
(override-make-stack! make-stack-5-2-4)
(define (assemble controller-text machine)
(extract-labels controller-text
(lambda (insts labels)
(update-insts! insts labels machine)
(list insts labels))))
(override-assemble! assemble)
(define (contains? lst x)
(cond ((null? lst) false)
((equal? x (first lst)) true)
(else (contains? (rest lst) x))))
(define (find-label-name labels instruction)
(if (null? labels)
'**non-label-name**
(let* ((label (first labels))
(label-name (first label))
(insts (rest label)))
(if (contains? insts instruction)
label-name
(find-label-name (rest labels) instruction)))))
(define (make-new-machine-5-17)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(instruction-count 0) ; added : 5-15
(is-trace-on false) ; added : 5-16
(the-labels nil) ; added : 5-17
)
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))
;; added : 5-15
(list 'initialize-instruction-count
(lambda ()
(set! instruction-count 0)))
(list 'print-instruction-count
(lambda ()
(newline)
(display (list 'print-instruction-count '= instruction-count))))
;; added : 5-16
(list 'trace-on
(lambda ()
(set! is-trace-on true)))
(list 'trace-off
(lambda ()
(set! is-trace-on false)))
))
(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)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
;; added : 5-17
(if is-trace-on
(begin
(newline)
(let ((label-name (find-label-name the-labels (first insts))))
(display (list "==========================" label-name)))))
;; added : 5-16
(if is-trace-on
(begin
(newline)
(display (first (first insts)))))
((instruction-execution-proc (car insts)))
;; added: 5-15
(set! instruction-count (inc instruction-count))
(execute)))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
;; before: 5-17
;; (lambda (seq)
;; (set! the-instruction-sequence seq))
;; after: 5-17
(lambda (insts-labels)
(let ((seq (first insts-labels))
(labels (second insts-labels)))
(set! the-instruction-sequence seq)
(set! the-labels (reverse labels)) ; // reverse를 한 것에 주의.
))
)
((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)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(override-make-new-machine! make-new-machine-5-17)
(define dummy-machine
(make-machine
'(x y)
'()
'(label-A
(assign x (const 1))
(assign y (const 2))
label-B
(perform (op trace-on))
(assign x (const 1))
label-C
(assign y (const 2))
(save x)
(restore x)
label-D
(perform (op trace-off))
(assign x (const 1))
(assign y (const 2))
)
))
(check-output?
"
(========================== label-B)
(assign x (const 1))
(========================== label-C)
(assign y (const 2))
(========================== label-C)
(save x)
(========================== label-C)
(restore x)
(========================== label-D)
(perform (op trace-off))
(total-pushes = 1 maximum-depth = 1)"
(start dummy-machine)
((dummy-machine 'stack) 'print-statistics))
;; file: 5_18.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
연습문제 5.18: 5.2.1절의 make-register 프로시저를 수정하여 레지스터를 추적할 수 있도록 하세요.
1. 레지스터는 추적을 켜고 끄는 메시지를 받아들여야 합니다.
2. 레지스터가 추적 중일 때, 레지스터에 값을 할당하면 레지스터의 이름, 기존 내용, 그리고 새로 할당되는 내용을 출력해야 합니다.
3. 기계 모델의 인터페이스를 확장하여 지정된 기계 레지스터에 대해 추적을 켜고 끌 수 있도록 하세요.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
(define (make-register name)
(let ((contents '*unassigned*)
(is-tracking false) ; added: 5-18 - 1.
)
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set)
(lambda (value)
;; added: 5-18 - 2.
(if is-tracking
(begin
(newline)
(display (list 'register "(" name ")" contents '>>>>> value))))
(set! contents value)))
;; added: 5-18 - 1.
((eq? message 'set-is-tracking)
(lambda (value) (set! is-tracking value)))
(else
(error "Unknown request -- REGISTER" message))))
dispatch))
(override-make-register! make-register)
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '()))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(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)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
(execute)))))
(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)
;; added: 5-18 - 3.
((eq? message 'register-track)
(lambda (reg-name is-tracking)
(let ((reg (lookup-register reg-name)))
((reg 'set-is-tracking) is-tracking))))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(override-make-new-machine! make-new-machine)
(define dummy-machine
(make-machine
'(x y)
'()
'((assign x (const 1))
(assign y (const 2))
(assign x (reg y))
(assign y (reg x))
(assign x (const 3))
)
))
(check-output?
"
(register ( x ) *unassigned* >>>>> 1)
(register ( x ) 1 >>>>> 2)
(register ( x ) 2 >>>>> 3)"
((dummy-machine 'register-track) 'x true)
(start dummy-machine))
;; file: 5_19.rkt
;; 5_15 / 5_16 / 5_17 / 5_19
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
(set-breakpoint ⟨machine⟩ ⟨label⟩ ⟨n⟩) : 1. label에서 n만큼 떨어진 곳에 breakpoint 설정
(proceed-machine ⟨machine⟩) ; 2. 실행 이어가기
(cancel-breakpoint ⟨machine⟩ ⟨label⟩ ⟨n⟩) ; 3. breakpoint 제거
(cancel-all-breakpoints ⟨machine⟩) ; 4. 모든 breakpoints 제거
|#
#|
1.
- n번째 찾는건 5_17 에서처럼 labels를 들고있다가 거기서 인덱스 만큼 떨어진 곳에 instruction을 찾을 수 있을거임.
- breakpoint table같은걸 만들어서 거기에 해당 instruction을 키로 해서 넣으면 될듯.
- 머신을 실행을 지속시키는것은 (execute) 루프
- breakpoint를 만나면 루프를 중지시키면 됨.
2.
- proceed-machine은 단순이 execute를 시켜주면 알아서 진행될꺼임.
- 단 첫 실행시 breakpoint 우회 방법 필요.
3.
- 1.에서 처럼 labels에서 instruction을 찾은 후 breakpoint 테이블에서 지우면 될꺼고
4.
- breakpoint 테이블 자체를 클리어 시키면 됨.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
figure-5-11
figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
(racket:require (racket:only-in "5_12.rkt"
make-set))
(reset!)
(define (assemble controller-text machine)
(extract-labels controller-text
(lambda (insts labels)
(update-insts! insts labels machine)
(list insts labels))))
(override-assemble! assemble)
(define (set-breakpoint machine label n)
((machine 'set-breakpoint) label n))
(define (proceed-machine machine)
(machine 'proceed-machine))
(define (cancel-breakpoint machine label n)
((machine 'cancel-breakpoint) label n))
(define (cancel-all-breakpoints machine)
(machine 'cancel-all-breakpoints))
(define (nth lst n)
(cond ((null? lst) (error "Index out of bounds"))
((< n 0) (error "Index cannot be negative"))
((= n 0) (car lst))
(else (nth (cdr lst) (- n 1)))))
(define (find-inst labels in-label-name in-n)
(if (null? labels)
nil
(let* ((label (first labels))
(label-name (first label))
(insts (rest label)))
(if (eq? in-label-name label-name)
(nth insts in-n)
(find-inst (rest labels) in-label-name in-n)))))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(breakpoint-set (make-set)) ; added: 5_19
(the-labels nil) ; added: 5_19
)
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(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)
(error "Unknown register:" name))))
;; before: 5-19
;; (define (execute)
;; (let ((insts (get-contents pc)))
;; (if (null? insts)
;; 'done
;; (begin
;; ((instruction-execution-proc (car insts)))
;; (execute)))))
;; after: 5-19
(define (execute is-breakable-flag)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
(let ((inst (car insts)))
(if (and is-breakable-flag ((breakpoint-set 'contains?) inst))
'**break**
(begin
((instruction-execution-proc (car insts)))
(execute true))))))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute true))
((eq? message 'install-instruction-sequence)
;; before: 5-19
;; (lambda (seq)
;; (set! the-instruction-sequence seq))
;; after: 5-19
(lambda (insts-labels)
(let ((seq (first insts-labels))
(labels (second insts-labels)))
(set! the-instruction-sequence seq)
(set! the-labels (reverse labels)) ; // reverse를 한 것에 주의.
))
)
((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)
;; added: 5-19
((eq? message 'set-breakpoint)
(lambda (label-name n)
(let ((inst (find-inst the-labels label-name n)))
(if (not (null? inst))
(begin
((breakpoint-set 'add) inst)
(list '**break-marked**
'lable: label-name
':idx n
'inst: (first inst)))))))
((eq? message 'proceed-machine)
(execute false))
((eq? message 'cancel-breakpoint)
(lambda (label-name n)
(let ((inst (find-inst the-labels label-name n)))
(if (null? inst)
(list 'cancel-breakpoint
'fail-to-find-inst
'lable: label-name
':idx n)
(if (not ((breakpoint-set 'contains?) inst))
(list 'cancel-breakpoint '**break-already-canceled**
'lable: label-name
':idx n
'inst: (first inst))
(let ((deleted-set ((breakpoint-set 'del) inst)))
(list 'cancel-breakpoint '**break-canceled**
'lable: label-name
':idx n
'inst: (first inst))))))))
((eq? message 'cancel-all-breakpoints)
(set! breakpoint-set (make-set))
'**cancel-all-breakpoints**)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(override-make-new-machine! make-new-machine)
(define gcd-machine
(make-machine
'(a b t)
(list (list 'rem remainder) (list '= =))
'(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
gcd-done)))
(~> gcd-machine
(set-breakpoint 'test-b 4)
(check-equal? '(**break-marked** lable: test-b :idx 4 inst: (assign b (reg t)))))
(~> gcd-machine
(set-register-contents! 'a 206)
(check-equal? 'done))
(~> gcd-machine
(set-register-contents! 'b 40)
(check-equal? 'done))
(~> gcd-machine
(start)
(check-equal? '**break**))
(~> gcd-machine
(get-register-contents 'a)
(check-equal? 40))
(~> gcd-machine
(get-register-contents 'b)
(check-equal? 40))
(~> gcd-machine
(get-register-contents 't)
(check-equal? 6))
(~> gcd-machine
(proceed-machine)
(check-equal? '**break**))
(~> gcd-machine
(get-register-contents 'a)
(check-equal? 6))
(~> gcd-machine
(get-register-contents 'b)
(check-equal? 6))
(~> gcd-machine
(get-register-contents 't)
(check-equal? 4))
(~> gcd-machine
(set-register-contents! 'a 40)
(check-equal? 'done))
(~> gcd-machine
(set-register-contents! 'b 40)
(check-equal? 'done))
(~> gcd-machine
(set-register-contents! 't 6)
(check-equal? 'done))
(~> gcd-machine
(proceed-machine)
(check-equal? '**break**))
(~> gcd-machine
(get-register-contents 'a)
(check-equal? 6))
(~> gcd-machine
(cancel-breakpoint 'test-c 1)
(check-equal? '(cancel-breakpoint fail-to-find-inst lable: test-c :idx 1)))
(~> gcd-machine
(cancel-breakpoint 'test-b 4)
(check-equal? '(cancel-breakpoint **break-canceled** lable: test-b :idx 4 inst: (assign b (reg t)))))
(~> gcd-machine
(cancel-breakpoint 'test-b 4)
(check-equal? '(cancel-breakpoint **break-already-canceled** lable: test-b :idx 4 inst: (assign b (reg t)))))
#;(~> gcd-machine
(cancel-all-breakpoints)
(check-equal? '**cancel-all-breakpoints**))
(~> gcd-machine
(proceed-machine)
(check-equal? 'done))
(~> gcd-machine
(get-register-contents 'a)
(check-equal? 2))
;; file: 5_20.rkt
#|
연습문제 5.20: 다음 코드로 생성된 리스트 구조의 박스-포인터 다이어그램과 메모리 벡터 표현(그림 5.14와 같은 형식)을 그리시오:
(define x (cons 1 2))
(define y (list x x))
초기 free 포인터는 p1.
최종 free 포인터의 값은 무엇인가? 변수 x와 y의 값을 나타내는 포인터는 무엇인가?
|#
#|
| p | pointer |
| n | number |
| e | empty list |
e0 : 빈리스트 - '()
|#
#|
x = (cons 1 2)
<p1> = (cons 1 2)
+-+-+-+-+
| | |--> n2
+-+-+-+-+
|
v
n1
y = (list x y) = (cons x (cons x '()))
| <p2> = (cons x '()) = (cons <p1> <e0>)
| <p3> = (cons x <p2>) = (cons <p1> <e2>)
y = <p3>
<p3> <p2>
+-+-+-+-+ +-+-+-+-+
| | |--> | | |--> e0
+-+-+-+-+ +-+-+-+-+
| |
v v
x<p1> x<p1>
| index | 0 | 1 | 2 | 3 | 4 |
| -------- | --- | --- | --- | --- | --- |
| the-cars | | n1 | p1 | p1 | |
| the-cdrs | | n2 | e0 | p2 | |
즉,
x : p1
y : p3
free : p4
|#
;; file: 5_21.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
연습문제 5.21: 다음 프로시저에 대한 레지스터 머신 구현
리스트 구조 메모리 연산이 머신 기본 연산(primitive)으로 사용 가능하다고 가정하고, 아래 프로시저에 대한 레지스터 머신을 구현하시오.
1. 재귀적 count-leaves:
(define (count-leaves tree)
(cond ((null? tree) 0)
((not (pair? tree)) 1)
(else
(+ (count-leaves (car tree))
(count-leaves (cdr tree))))))
2. 명시적 카운터를 사용한 재귀적 count-leaves:
(define (count-leaves tree)
(define (count-iter tree n)
(cond ((null? tree) n)
((not (pair? tree)) (+ n 1))
(else
(count-iter
(cdr tree)
(count-iter (car tree)
n)))))
(count-iter tree 0))
|#
#|
1번은 figure 5.12와 닮아 있음.
|#
(racket:require "../allcode/ch5-regsim.rkt")
(override-make-stack! make-stack-5-2-4)
(define (count-leaves-v1 tree)
(cond ((null? tree) 0)
((not (pair? tree)) 1)
(else
(+ (count-leaves-v1 (car tree))
(count-leaves-v1 (cdr tree))))))
(define (count-leaves-v2 tree)
(define (count-iter tree n)
(cond ((null? tree) n)
((not (pair? tree)) (+ n 1))
(else
(count-iter
(cdr tree)
(count-iter (car tree)
n)))))
(count-iter tree 0))
(define sample-tree
'((1 (2 3 (4 5)) (6 7)) (8 (9 (10 (11) 12)))))
(check-equal? (count-leaves-v1 sample-tree)
12)
(check-equal? (count-leaves-v2 sample-tree)
12)
;; v1 =====================================================================
(define controller-count-leaves-v1
'(BEGIN
(assign continue (label END))
LOOP
(test (op null?) (reg tree)) ; cond - ((null? tree) 0)
(branch
(label CASE-0))
(assign temp1 (op pair?) (reg tree)) ; cond - ((not (pair? tree)) 1)
(test (op not) (reg temp1))
(branch
(label CASE-1))
(save continue)
(assign continue (label AFTER-car-tree))
(save tree)
(assign tree (op car) (reg tree)) ; prepare : (count-leaves (car tree))
(goto
(label LOOP)) ; do : (count-leaves (car tree))
AFTER-car-tree
(restore tree)
(restore continue)
(assign tree (op cdr) (reg tree)) ; prepare : (count-leaves (cdr tree))
(save continue)
(assign continue (label AFTER-cdr-tree))
(save val) ; save : (count-leaves (car tree))
(goto
(label LOOP)) ; do : (count-leaves (cdr tree))
AFTER-cdr-tree
(assign tree (reg val)) ; save : (count-leaves (cdr tree))
(restore val) ; restore : (count-leaves (car tree))
(restore continue)
(assign val (op +) (reg val) (reg tree)) ; cond - (+ (count-leaves-v1 (car tree))
; (count-leaves-v1 (cdr tree)))
(goto
(reg continue))
CASE-0
(assign val (const 0))
(goto
(reg continue))
CASE-1
(assign val (const 1))
(goto
(reg continue))
END))
(define machine-count-leaves-v1
(make-machine
'(tree temp1 continue val)
(list (list 'null? null?)
(list 'pair? pair?)
(list 'not not)
(list '+ +)
(list 'car car)
(list 'cdr cdr)
)
controller-count-leaves-v1
))
(~> machine-count-leaves-v1
(set-register-contents! 'tree sample-tree)
(check-equal? 'done))
(~> machine-count-leaves-v1
(start)
(check-equal? 'done))
(~> machine-count-leaves-v1
(get-register-contents 'val)
(check-equal? 12))
(check-output?
"
(total-pushes = 80 maximum-depth = 18)"
((machine-count-leaves-v1 'stack) 'print-statistics))
;; v2 =====================================================================
(define controller-count-leaves-v2
'(BEGIN
(assign continue (label END))
(assign n (const 0)) ; (count-iter tree 0)
LOOP
(test (op null?) (reg tree)) ; cond - ((null? tree) n)
(branch
(label CASE-n))
(assign temp1 (op pair?) (reg tree)) ; cond - ((not (pair? tree)) (+ n 1))
(test (op not) (reg temp1))
(branch
(label CASE-n+1))
;; (count-iter (cdr tree)
;; (count-iter (car tree) n))))))
(save continue)
(assign continue (label AFTER-car-tree))
(save tree)
(assign tree (op car) (reg tree))
(goto
(label LOOP))
AFTER-car-tree
(restore tree)
(restore continue)
(assign tree (op cdr) (reg tree))
(assign n (reg val))
(goto
(label LOOP))
CASE-n
(assign val (reg n))
(goto
(reg continue))
CASE-n+1
(assign val (op +) (reg n) (const 1))
(goto
(reg continue))
END))
(define machine-count-leaves-v2
(make-machine
'(tree n temp1 continue val)
(list (list 'null? null?)
(list 'pair? pair?)
(list 'not not)
(list '+ +)
(list 'car car)
(list 'cdr cdr)
)
controller-count-leaves-v2
))
(~> machine-count-leaves-v2
(set-register-contents! 'tree sample-tree)
(check-equal? 'done))
(~> machine-count-leaves-v2
(start)
(check-equal? 'done))
(~> machine-count-leaves-v2
(get-register-contents 'val)
(check-equal? 12))
(check-output?
"
(total-pushes = 40 maximum-depth = 10)"
((machine-count-leaves-v2 'stack) 'print-statistics))
;; file: 5_22.rkt
;; 3_12 / 5_22
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
연습문제 3.12에 나온 append와 append!에 대한 머신 설계.
|#
(racket:require "../allcode/ch5-regsim.rkt")
(define (append x y)
(if (null? x)
y
(cons (car x) (append (cdr x) y))))
(define (append! x y)
(set-cdr! (last-pair x) y)
x)
(define (last-pair x)
(if (null? (cdr x))
x
(last-pair (cdr x))))
(define x1 '(1 2))
(define y1 '(3 4))
(check-equal? (append x1 y1)
'(1 2 3 4))
(check-equal? x1 '(1 2))
(check-equal? y1 '(3 4))
(define x2 '(1 2))
(define y2 '(3 4))
(check-equal? (append! x2 y2)
'(1 2 3 4))
(check-equal? x2 '(1 2 3 4))
(check-equal? y2 '(3 4))
;; append =====================================================================
(define controller-append
#|
(define (append x y)
(if (null? x)
y
(cons (car x) (append (cdr x) y))))
|#
'(BEGIN
(assign continue (label END))
LOOP
(test (op null?) (reg x)) ; (if (null? x)
(branch
(label CASE-y))
(save continue)
(assign continue (label AFTER-append-cdr))
(save x)
(assign x (op cdr) (reg x)) ; prepare : (append (cdr x) y)
(goto
(label LOOP)) ; do : (append (cdr x) y)
AFTER-append-cdr
(restore x)
(restore continue)
(assign x (op car) (reg x))
(assign val (op cons) (reg x) (reg val)) ; do : (cons (car x) (append (cdr x) y))))
(goto
(reg continue))
CASE-y
(assign val (reg y))
(goto
(reg continue))
END))
(define machine-append
(make-machine
'(x y val continue)
(list (list 'null? null?)
(list 'car car)
(list 'cdr cdr)
(list 'cons cons)
)
controller-append
))
(define a1 '(1 2))
(define b1 '(3 4))
(~> machine-append
(set-register-contents! 'x a1)
(check-equal? 'done))
(~> machine-append
(set-register-contents! 'y b1)
(check-equal? 'done))
(~> machine-append
(start)
(check-equal? 'done))
(~> machine-append
(get-register-contents 'val)
(check-equal? '(1 2 3 4)))
(check-equal? a1 '(1 2))
(check-equal? b1 '(3 4))
;; append! =====================================================================
(define controller-append!
'(BEGIN
(assign iter-x (reg x))
LOOP-last-pair
(assign temp1 (op cdr) (reg iter-x)) ; (if (null? (cdr x))
(test (op null?) (reg temp1))
(branch
(label CASE-x))
(assign iter-x (op cdr) (reg iter-x))
(goto
(label LOOP-last-pair))
CASE-x
(perform (op set-cdr!) (reg iter-x) (reg y))
END))
(define machine-append!
(make-machine
'(x y iter-x temp1)
(list (list 'null? null?)
(list 'set-cdr! set-cdr!)
(list 'cdr cdr)
(list 'cons cons)
)
controller-append!
))
(define a2 '(1 2))
(define b2 '(3 4))
(~> machine-append!
(set-register-contents! 'x a2)
(check-equal? 'done))
(~> machine-append!
(set-register-contents! 'y b2)
(check-equal? 'done))
(~> machine-append!
(start)
(check-equal? 'done))
(~> machine-append!
(get-register-contents 'x)
(check-equal? '(1 2 3 4)))
(check-equal? a2 '(1 2 3 4))
(check-equal? b2 '(3 4))
;; file: 5_23.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)
#|
cond와 let을 처리할 수 있도록 확장해라.
(cond->if와 같은 변환을 연산으로 쓸 수 있다고 가정)
|#
(racket:require "../allcode/load-eceval.rkt")
(racket:require (racket:prefix-in syntax: "../allcode/ch5-syntax.rkt"))
(reset-the-global-environment!)
;; 4_06 연섭문제
(define (let? exp) (syntax:tagged-list? exp 'let))
(define (let->combination let-clause)
(let* ((bindings (second let-clause))
(vars (map first bindings))
(exps (map second bindings))
(body (rest (rest let-clause))))
(cons (syntax:make-lambda vars body)
exps)))
(define eceval
(make-machine
'(exp env val proc argl continue unev)
(append eceval-operations
(list (list 'cond? syntax:cond?)
(list 'cond->if syntax:cond->if)
(list 'let? let?)
(list 'let->combination let->combination)
))
'(
;;SECTION 5.4.4
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))
print-result
;;**following instruction optional -- if use it, need monitored stack
(perform (op print-stack-statistics))
(perform
(op announce-output) (const ";;; EC-Eval value:"))
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
|#
;; 한번만 실행하도록 하고, 바로 END로
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (label eval-dispatch))
print-result
(goto (label END))
unknown-expression-type
(assign val (const unknown-expression-type-error))
(goto (label signal-error))
unknown-procedure-type
(restore continue)
(assign val (const unknown-procedure-type-error))
(goto (label signal-error))
signal-error
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
;;SECTION 5.4.1
eval-dispatch
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
;; added: 5-23
(test (op cond?) (reg exp))
(branch (label ev-cond))
;; added: 5-23
(test (op let?) (reg exp))
(branch (label ev-let))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op application?) (reg exp))
(branch (label ev-application))
(goto (label unknown-expression-type))
ev-self-eval
(assign val (reg exp))
(goto (reg continue))
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(goto (reg continue))
ev-quoted
(assign val (op text-of-quotation) (reg exp))
(goto (reg continue))
ev-lambda
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure)
(reg unev) (reg exp) (reg env))
(goto (reg continue))
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))
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))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg))
(goto (label eval-dispatch))
ev-appl-accumulate-arg
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop))
ev-appl-last-arg
(assign continue (label ev-appl-accum-last-arg))
(goto (label eval-dispatch))
ev-appl-accum-last-arg
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(goto (label unknown-procedure-type))
primitive-apply
(assign val (op apply-primitive-procedure)
(reg proc)
(reg argl))
(restore continue)
(goto (reg continue))
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))
;;;SECTION 5.4.2
ev-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
ev-sequence
(assign exp (op first-exp) (reg unev))
(test (op last-exp?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (label ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue
(restore env)
(restore unev)
(assign unev (op rest-exps) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp
(restore continue)
(goto (label eval-dispatch))
;;;SECTION 5.4.3
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
ev-if-alternative
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
;; added: 5-23
ev-cond
(assign exp (op cond->if) (reg exp))
(goto (label ev-if))
;; added: 5-23
ev-let
(assign exp (op let->combination) (reg exp))
(goto (label ev-application))
ev-assignment
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1
(restore continue)
(restore env)
(restore unev)
(perform
(op set-variable-value!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform
(op define-variable!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
END)))
(~> eceval
(set-register-contents! 'exp '(cond ((= 1 2) 'a)
((= 3 4) 'b)
(else 'c)))
(check-equal? 'done))
(~> eceval
(start)
(check-equal? 'done))
(~> eceval
(get-register-contents 'val)
(check-equal? 'c))
(~> eceval
(set-register-contents! 'exp '(let ((x 1)
(y 2))
(+ x y)))
(check-equal? 'done))
(~> eceval
(start)
(check-equal? 'done))
(~> eceval
(get-register-contents 'val)
(check-equal? 3))
;; file: 5_24.rkt
;; file: 5_25.rkt
;; file: 5_26.rkt
;; file: 5_27.rkt
;; file: 5_28.rkt
;; file: 5_29.rkt
;; file: 5_30.rkt
;; file: 5_31.rkt
;; file: 5_32.rkt
;; file: 5_33.rkt
;; file: 5_34.rkt
;; file: 5_35.rkt
;; file: 5_36.rkt
;; file: 5_37.rkt
;; file: 5_38.rkt
;; file: 5_39.rkt
;; file: 5_40.rkt
;; file: 5_41.rkt
;; file: 5_42.rkt
;; file: 5_43.rkt
;; file: 5_44.rkt
;; file: 5_45.rkt
;; file: 5_46.rkt
;; file: 5_47.rkt
;; file: 5_48.rkt
;; file: 5_49.rkt
;; file: 5_50.rkt
;; file: 5_51.rkt
;; file: 5_52.rkt