/
5_18.scm
131 lines (126 loc) · 4.72 KB
/
5_18.scm
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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
(load "5_17.scm")
(define (trace-on-register machine name)
((machine 'trace-on-register) name))
(define (trace-off-register machine name)
((machine 'trace-off-register) name))
(define (make-register name)
(let ((contents '*unassigned*)
(tracing #f))
(define (set value)
(if tracing
(begin
(display "register-name: ")
(display name)
(display "\nold value: ")
(display contents)
(display "\nnew value: ")
(display value)
(newline)))
(set! contents value))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set) set)
((eq? message 'trace-on) (set! tracing #t) 'ok)
((eq? message 'trace-off) (set! tracing #f) 'ok)
(else
(error "Unknown request -- REGISTER" message))))
dispatch))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(inst-count 0)
(inst-tracing #f))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table
(list (list 'pc pc) (list 'flag flag))))
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined register: " name)
(set! register-table
(cons (list name (make-register name))
register-table)))
'register-allocated)
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(let ((instruction (car insts)))
(begin
(set! inst-count (+ inst-count 1))
(if inst-tracing
(begin
(if (not-null? (instruction-preced-label instruction))
(begin (display (instruction-preced-label instruction))
(newline)))
(display (instruction-text instruction))
(newline)))
((instruction-execution-proc instruction))
(execute))))))
(define (get-inst-count) inst-count)
(define (reset-inst-count)
(set! inst-count 0)
'ok)
(define (trace-on) (set! inst-tracing #t) 'ok)
(define (trace-off) (set! inst-tracing #f) 'ok)
(define (trace-on-register name)
((lookup-register name) 'trace-on))
(define (trace-off-register name)
((lookup-register name) 'trace-off))
(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 'get-inst-count) (get-inst-count))
((eq? message 'reset-inst-count) (reset-inst-count))
((eq? message 'trace-on) (trace-on))
((eq? message 'trace-off) (trace-off))
((eq? message 'trace-on-register) trace-on-register)
((eq? message 'trace-off-register) trace-off-register)
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(define fact-machine
(make-machine
'(n continue val)
(list (list '= =) (list '* *) (list '+ +) (list '- -) (list '< <))
'((assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
fact-done)))
(trace-on-register fact-machine 'val)
(set-register-contents! fact-machine 'n 4)
(fact-machine 'trace-on)
(start fact-machine)
(get-register-contents fact-machine 'val)