Chapter 5, Computing with Register Machines
Exercise 5.15
Changes are marked with ;;;
:
(I also added it as an operation so that it can be called from within machine.)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(instruction-count 0)) ;;;
(define (reset-instruction-count) ;;;
(newline) ;;;
(display (list "Total instructions executed: " ;;;
instruction-count)) ;;;
(set! instruction-count 0) ;;;
'done) ;;;
(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)))
(list 'reset-instruction-count reset-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)))
(set! instruction-count (+ instruction-count 1))
(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)
((eq? message 'reset-instruction-count) (reset-instruction-count)) ;;;
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
Output:
By passing message to machine:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
1 ]=>
(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)))
;Value 7: (register simulator loaded)
1 ]=>
;Value: gcd-machine
1 ]=> (set-register-contents! gcd-machine 'a 50)
;Value: done
1 ]=> (set-register-contents! gcd-machine 'b 375)
;Value: done
1 ]=> (gcd-machine 'reset-instruction-count)
(Total instructions executed: 0)
;Value: done
1 ]=> (start gcd-machine)
;Value: done
1 ]=> (gcd-machine 'reset-instruction-count)
(Total instructions executed: 20)
;Value: done
1 ]=> (gcd-machine 'reset-instruction-count)
(Total instructions executed: 0)
;Value: done
1 ]=>
By installing it in the solution of previous exercise:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
1 ]=>
(define (print . items)
(newline)
(display items))
(define (read-at-newline)
(newline)
(read))
(define fact-machine
(make-machine
'(n val continue)
(list (list '= =) (list '* *) (list '- -) (list 'read read-at-newline) (list 'print print))
'(start
(perform (op reset-instruction-count))
(assign n (op read))
(perform (op initialize-stack))
(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))
(perform (op print) (reg val))
(goto (label start)))))
;Value: print
1 ]=>
;Value: read-at-newline
1 ]=>
;Value: fact-machine
1 ]=> (start fact-machine)
(Total instructions executed: 0)
1
(total-pushes = 0 maximum-depth = 0)
(1)
(Total instructions executed: 11)
2
(total-pushes = 2 maximum-depth = 2)
(2)
(Total instructions executed: 22)
3
(total-pushes = 4 maximum-depth = 4)
(6)
(Total instructions executed: 33)
4
(total-pushes = 6 maximum-depth = 6)
(24)
(Total instructions executed: 44)
5
(total-pushes = 8 maximum-depth = 8)
(120)
(Total instructions executed: 55)