1 665c255d 2023-08-04 jrmu (define (make-machine register-names ops controller-text)
2 665c255d 2023-08-04 jrmu (let ((machine (make-new-machine)))
3 665c255d 2023-08-04 jrmu (for-each (lambda (register-name)
4 665c255d 2023-08-04 jrmu ((machine 'allocate-register) register-name))
5 665c255d 2023-08-04 jrmu register-names)
6 665c255d 2023-08-04 jrmu ((machine 'install-operations) ops)
7 665c255d 2023-08-04 jrmu ((machine 'install-instruction-sequence)
8 665c255d 2023-08-04 jrmu (assemble controller-text machine))
10 665c255d 2023-08-04 jrmu (define (make-register name)
11 665c255d 2023-08-04 jrmu (let ((contents '*unassigned*))
12 665c255d 2023-08-04 jrmu (define (dispatch message)
13 665c255d 2023-08-04 jrmu (cond ((eq? message 'get) contents)
14 665c255d 2023-08-04 jrmu ((eq? message 'set)
15 665c255d 2023-08-04 jrmu (lambda (value) (set! contents value)))
17 665c255d 2023-08-04 jrmu (error "Unknown request -- REGISTER" message))))
19 665c255d 2023-08-04 jrmu (define (get-contents register)
20 665c255d 2023-08-04 jrmu (register 'get))
21 665c255d 2023-08-04 jrmu (define (set-contents! register value)
22 665c255d 2023-08-04 jrmu ((register 'set) value))
23 665c255d 2023-08-04 jrmu ;; (define (make-stack)
24 665c255d 2023-08-04 jrmu ;; (let ((s '())
25 665c255d 2023-08-04 jrmu ;; (number-pushes 0)
26 665c255d 2023-08-04 jrmu ;; (max-depth 0)
27 665c255d 2023-08-04 jrmu ;; (current-depth 0))
28 665c255d 2023-08-04 jrmu ;; (define (push x)
29 665c255d 2023-08-04 jrmu ;; (set! s (cons x s))
30 665c255d 2023-08-04 jrmu ;; (set! number-pushes (+ 1 number-pushes))
31 665c255d 2023-08-04 jrmu ;; (set! current-depth (+ 1 current-depth))
32 665c255d 2023-08-04 jrmu ;; (set! max-depth (max current-depth max-depth)))
33 665c255d 2023-08-04 jrmu ;; (define (pop)
34 665c255d 2023-08-04 jrmu ;; (if (null? s)
35 665c255d 2023-08-04 jrmu ;; (error "Empty stack -- POP")
36 665c255d 2023-08-04 jrmu ;; (let ((top (car s)))
37 665c255d 2023-08-04 jrmu ;; (set! s (cdr s))
38 665c255d 2023-08-04 jrmu ;; (set! current-depth (- current-depth 1))
40 665c255d 2023-08-04 jrmu ;; (define (initialize)
41 665c255d 2023-08-04 jrmu ;; (set! s '())
42 665c255d 2023-08-04 jrmu ;; (set! number-pushes 0)
43 665c255d 2023-08-04 jrmu ;; (set! max-depth 0)
44 665c255d 2023-08-04 jrmu ;; (set! current-depth 0)
46 665c255d 2023-08-04 jrmu ;; (define (print-statistics)
47 665c255d 2023-08-04 jrmu ;; (newline)
48 665c255d 2023-08-04 jrmu ;; (display (list 'total-pushes '= number-pushes
49 665c255d 2023-08-04 jrmu ;; 'maximum-depth '= max-depth)))
50 665c255d 2023-08-04 jrmu ;; (define (dispatch message)
51 665c255d 2023-08-04 jrmu ;; (cond ((eq? message 'push) push)
52 665c255d 2023-08-04 jrmu ;; ((eq? message 'pop) (pop))
53 665c255d 2023-08-04 jrmu ;; ((eq? message 'initialize) (initialize))
54 665c255d 2023-08-04 jrmu ;; ((eq? message 'print-statistics)
55 665c255d 2023-08-04 jrmu ;; (print-statistics))
57 665c255d 2023-08-04 jrmu ;; (error "Unknown request -- STACK" message))))
58 665c255d 2023-08-04 jrmu ;; dispatch))
59 665c255d 2023-08-04 jrmu (define (pop stack)
60 665c255d 2023-08-04 jrmu (stack 'pop))
61 665c255d 2023-08-04 jrmu (define (push stack value)
62 665c255d 2023-08-04 jrmu ((stack 'push) value))
63 665c255d 2023-08-04 jrmu (define (make-new-machine)
64 665c255d 2023-08-04 jrmu (let ((pc (make-register 'pc))
65 665c255d 2023-08-04 jrmu (flag (make-register 'flag))
66 665c255d 2023-08-04 jrmu (stack (make-stack))
67 665c255d 2023-08-04 jrmu (the-instruction-sequence '()))
68 665c255d 2023-08-04 jrmu (let ((the-ops
69 665c255d 2023-08-04 jrmu (list (list 'initialize-stack
70 665c255d 2023-08-04 jrmu (lambda () (stack 'initialize)))
71 665c255d 2023-08-04 jrmu (list 'print-stack-statistics
72 665c255d 2023-08-04 jrmu (lambda () (stack 'print-statistics)))))
73 665c255d 2023-08-04 jrmu (register-table
74 665c255d 2023-08-04 jrmu (list (list 'pc pc) (list 'flag flag))))
75 665c255d 2023-08-04 jrmu (define (allocate-register name)
76 665c255d 2023-08-04 jrmu (if (assoc name register-table)
77 665c255d 2023-08-04 jrmu (error "Multiply defined register: " name)
78 665c255d 2023-08-04 jrmu (set! register-table
79 665c255d 2023-08-04 jrmu (cons (list name (make-register name))
80 665c255d 2023-08-04 jrmu register-table)))
81 665c255d 2023-08-04 jrmu 'register-allocated)
82 665c255d 2023-08-04 jrmu (define (lookup-register name)
83 665c255d 2023-08-04 jrmu (let ((val (assoc name register-table)))
86 665c255d 2023-08-04 jrmu (error "Unknown register:" name))))
87 665c255d 2023-08-04 jrmu (define (execute)
88 665c255d 2023-08-04 jrmu (let ((insts (get-contents pc)))
89 665c255d 2023-08-04 jrmu (if (null? insts)
92 665c255d 2023-08-04 jrmu ((instruction-execution-proc (car insts)))
93 665c255d 2023-08-04 jrmu (execute)))))
94 665c255d 2023-08-04 jrmu (define (dispatch message)
95 665c255d 2023-08-04 jrmu (cond ((eq? message 'start)
96 665c255d 2023-08-04 jrmu (set-contents! pc the-instruction-sequence)
98 665c255d 2023-08-04 jrmu ((eq? message 'install-instruction-sequence)
99 665c255d 2023-08-04 jrmu (lambda (seq) (set! the-instruction-sequence seq)))
100 665c255d 2023-08-04 jrmu ((eq? message 'allocate-register) allocate-register)
101 665c255d 2023-08-04 jrmu ((eq? message 'get-register) lookup-register)
102 665c255d 2023-08-04 jrmu ((eq? message 'install-operations)
103 665c255d 2023-08-04 jrmu (lambda (ops) (set! the-ops (append the-ops ops))))
104 665c255d 2023-08-04 jrmu ((eq? message 'stack) stack)
105 665c255d 2023-08-04 jrmu ((eq? message 'operations) the-ops)
106 665c255d 2023-08-04 jrmu (else (error "Unknown request -- MACHINE" message))))
107 665c255d 2023-08-04 jrmu dispatch)))
108 665c255d 2023-08-04 jrmu (define (start machine)
109 665c255d 2023-08-04 jrmu (machine 'start))
110 665c255d 2023-08-04 jrmu (define (get-register-contents machine register-name)
111 665c255d 2023-08-04 jrmu (get-contents (get-register machine register-name)))
112 665c255d 2023-08-04 jrmu (define (set-register-contents! machine register-name value)
113 665c255d 2023-08-04 jrmu (set-contents! (get-register machine register-name) value)
115 665c255d 2023-08-04 jrmu (define (get-register machine reg-name)
116 665c255d 2023-08-04 jrmu ((machine 'get-register) reg-name))
117 665c255d 2023-08-04 jrmu (define (assemble controller-text machine)
118 665c255d 2023-08-04 jrmu (extract-labels controller-text
119 665c255d 2023-08-04 jrmu (lambda (insts labels)
120 665c255d 2023-08-04 jrmu (update-insts! insts labels machine)
122 665c255d 2023-08-04 jrmu (define (extract-labels text receive)
123 665c255d 2023-08-04 jrmu (if (null? text)
124 665c255d 2023-08-04 jrmu (receive '() '())
125 665c255d 2023-08-04 jrmu (extract-labels (cdr text)
126 665c255d 2023-08-04 jrmu (lambda (insts labels)
127 665c255d 2023-08-04 jrmu (let ((next-inst (car text)))
128 665c255d 2023-08-04 jrmu (if (symbol? next-inst)
129 665c255d 2023-08-04 jrmu (if (label-defined? labels next-inst)
130 665c255d 2023-08-04 jrmu (error "Duplicate label -- ASSEMBLE"
134 665c255d 2023-08-04 jrmu (cons (make-label-entry next-inst
138 665c255d 2023-08-04 jrmu (cons (make-instruction next-inst)
140 665c255d 2023-08-04 jrmu labels)))))))
141 665c255d 2023-08-04 jrmu (define (update-insts! insts labels machine)
142 665c255d 2023-08-04 jrmu (let ((pc (get-register machine 'pc))
143 665c255d 2023-08-04 jrmu (flag (get-register machine 'flag))
144 665c255d 2023-08-04 jrmu (stack (machine 'stack))
145 665c255d 2023-08-04 jrmu (ops (machine 'operations)))
147 665c255d 2023-08-04 jrmu (lambda (inst)
148 665c255d 2023-08-04 jrmu (set-instruction-execution-proc!
150 665c255d 2023-08-04 jrmu (make-execution-procedure
151 665c255d 2023-08-04 jrmu (instruction-text inst) labels machine
152 665c255d 2023-08-04 jrmu pc flag stack ops)))
154 665c255d 2023-08-04 jrmu (define (make-instruction text)
155 665c255d 2023-08-04 jrmu (cons text '()))
156 665c255d 2023-08-04 jrmu (define (instruction-text inst)
157 665c255d 2023-08-04 jrmu (car inst))
158 665c255d 2023-08-04 jrmu (define (instruction-execution-proc inst)
159 665c255d 2023-08-04 jrmu (cdr inst))
160 665c255d 2023-08-04 jrmu (define (set-instruction-execution-proc! inst proc)
161 665c255d 2023-08-04 jrmu (set-cdr! inst proc))
162 665c255d 2023-08-04 jrmu (define (make-label-entry label-name insts)
163 665c255d 2023-08-04 jrmu (cons label-name insts))
164 665c255d 2023-08-04 jrmu (define (label-defined? labels label-name)
165 665c255d 2023-08-04 jrmu (not (false? (assoc label-name labels))))
166 665c255d 2023-08-04 jrmu (define (lookup-label labels label-name)
167 665c255d 2023-08-04 jrmu (let ((val (assoc label-name labels)))
170 665c255d 2023-08-04 jrmu (error "Undefined label -- ASSEMBLE" label-name))))
171 665c255d 2023-08-04 jrmu (define (make-execution-procedure inst labels machine
172 665c255d 2023-08-04 jrmu pc flag stack ops)
173 665c255d 2023-08-04 jrmu (cond ((eq? (car inst) 'assign)
174 665c255d 2023-08-04 jrmu (make-assign inst machine labels ops pc))
175 665c255d 2023-08-04 jrmu ((eq? (car inst) 'test)
176 665c255d 2023-08-04 jrmu (make-test inst machine labels ops flag pc))
177 665c255d 2023-08-04 jrmu ((eq? (car inst) 'branch)
178 665c255d 2023-08-04 jrmu (make-branch inst machine labels flag pc))
179 665c255d 2023-08-04 jrmu ((eq? (car inst) 'goto)
180 665c255d 2023-08-04 jrmu (make-goto inst machine labels pc))
181 665c255d 2023-08-04 jrmu ((eq? (car inst) 'save)
182 665c255d 2023-08-04 jrmu (make-save inst machine stack pc))
183 665c255d 2023-08-04 jrmu ((eq? (car inst) 'restore)
184 665c255d 2023-08-04 jrmu (make-restore inst machine stack pc))
185 665c255d 2023-08-04 jrmu ((eq? (car inst) 'perform)
186 665c255d 2023-08-04 jrmu (make-perform inst machine labels ops pc))
187 665c255d 2023-08-04 jrmu (else (error "Unknown instruction type -- ASSEMBLE"
189 665c255d 2023-08-04 jrmu (define (make-assign inst machine labels operations pc)
190 665c255d 2023-08-04 jrmu (let ((target
191 665c255d 2023-08-04 jrmu (get-register machine (assign-reg-name inst)))
192 665c255d 2023-08-04 jrmu (value-exp (assign-value-exp inst)))
193 665c255d 2023-08-04 jrmu (let ((value-proc
194 665c255d 2023-08-04 jrmu (if (operation-exp? value-exp)
195 665c255d 2023-08-04 jrmu (make-operation-exp
196 665c255d 2023-08-04 jrmu value-exp machine labels operations)
197 665c255d 2023-08-04 jrmu (make-primitive-exp
198 665c255d 2023-08-04 jrmu (car value-exp) machine labels))))
199 665c255d 2023-08-04 jrmu (lambda () ; execution procedure for assign
200 665c255d 2023-08-04 jrmu (set-contents! target (value-proc))
201 665c255d 2023-08-04 jrmu (advance-pc pc)))))
202 665c255d 2023-08-04 jrmu (define (assign-reg-name assign-instruction)
203 665c255d 2023-08-04 jrmu (cadr assign-instruction))
204 665c255d 2023-08-04 jrmu (define (assign-value-exp assign-instruction)
205 665c255d 2023-08-04 jrmu (cddr assign-instruction))
206 665c255d 2023-08-04 jrmu (define (advance-pc pc)
207 665c255d 2023-08-04 jrmu (set-contents! pc (cdr (get-contents pc))))
208 665c255d 2023-08-04 jrmu (define (make-test inst machine labels operations flag pc)
209 665c255d 2023-08-04 jrmu (let ((condition (test-condition inst)))
210 665c255d 2023-08-04 jrmu (if (operation-exp? condition)
211 665c255d 2023-08-04 jrmu (let ((condition-proc
212 665c255d 2023-08-04 jrmu (make-operation-exp
213 665c255d 2023-08-04 jrmu condition machine labels operations)))
215 665c255d 2023-08-04 jrmu (set-contents! flag (condition-proc))
216 665c255d 2023-08-04 jrmu (advance-pc pc)))
217 665c255d 2023-08-04 jrmu (error "Bad TEST instruction -- ASSEMBLE" inst))))
218 665c255d 2023-08-04 jrmu (define (test-condition test-instruction)
219 665c255d 2023-08-04 jrmu (cdr test-instruction))
220 665c255d 2023-08-04 jrmu (define (make-branch inst machine labels flag pc)
221 665c255d 2023-08-04 jrmu (let ((dest (branch-dest inst)))
222 665c255d 2023-08-04 jrmu (if (label-exp? dest)
223 665c255d 2023-08-04 jrmu (let ((insts
224 665c255d 2023-08-04 jrmu (lookup-label labels (label-exp-label dest))))
226 665c255d 2023-08-04 jrmu (if (get-contents flag)
227 665c255d 2023-08-04 jrmu (set-contents! pc insts)
228 665c255d 2023-08-04 jrmu (advance-pc pc))))
229 665c255d 2023-08-04 jrmu (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
230 665c255d 2023-08-04 jrmu (define (branch-dest branch-instruction)
231 665c255d 2023-08-04 jrmu (cadr branch-instruction))
232 665c255d 2023-08-04 jrmu (define (make-goto inst machine labels pc)
233 665c255d 2023-08-04 jrmu (let ((dest (goto-dest inst)))
234 665c255d 2023-08-04 jrmu (cond ((label-exp? dest)
235 665c255d 2023-08-04 jrmu (let ((insts
236 665c255d 2023-08-04 jrmu (lookup-label labels
237 665c255d 2023-08-04 jrmu (label-exp-label dest))))
238 665c255d 2023-08-04 jrmu (lambda () (set-contents! pc insts))))
239 665c255d 2023-08-04 jrmu ((register-exp? dest)
241 665c255d 2023-08-04 jrmu (get-register machine
242 665c255d 2023-08-04 jrmu (register-exp-reg dest))))
244 665c255d 2023-08-04 jrmu (set-contents! pc (get-contents reg)))))
245 665c255d 2023-08-04 jrmu (else (error "Bad GOTO instruction -- ASSEMBLE"
247 665c255d 2023-08-04 jrmu (define (goto-dest goto-instruction)
248 665c255d 2023-08-04 jrmu (cadr goto-instruction))
249 665c255d 2023-08-04 jrmu (define (make-stack-pair reg-name contents)
250 665c255d 2023-08-04 jrmu (cons reg-name contents))
251 665c255d 2023-08-04 jrmu (define (stack-pair-reg-name pair)
252 665c255d 2023-08-04 jrmu (car pair))
253 665c255d 2023-08-04 jrmu (define (stack-pair-val pair)
254 665c255d 2023-08-04 jrmu (cdr pair))
255 665c255d 2023-08-04 jrmu (define (make-save inst machine stack pc)
256 665c255d 2023-08-04 jrmu (let* ((reg-name (stack-inst-reg-name inst))
257 665c255d 2023-08-04 jrmu (reg (get-register machine reg-name)))
259 665c255d 2023-08-04 jrmu (push stack (make-stack-pair reg-name (get-contents reg)))
260 665c255d 2023-08-04 jrmu (advance-pc pc))))
261 665c255d 2023-08-04 jrmu (define (make-restore inst machine stack pc)
262 665c255d 2023-08-04 jrmu (let* ((reg-name (stack-inst-reg-name inst))
263 665c255d 2023-08-04 jrmu (reg (get-register machine reg-name)))
265 665c255d 2023-08-04 jrmu (let* ((stack-pair (pop stack))
266 665c255d 2023-08-04 jrmu (stack-reg-name (stack-pair-reg-name stack-pair))
267 665c255d 2023-08-04 jrmu (stack-val (stack-pair-val stack-pair)))
268 665c255d 2023-08-04 jrmu (if (eq? stack-reg-name reg-name)
269 665c255d 2023-08-04 jrmu (begin (set-contents! reg stack-val)
270 665c255d 2023-08-04 jrmu (advance-pc pc))
271 665c255d 2023-08-04 jrmu (error "Stack/register mismatch -- Save/Restore: "
272 665c255d 2023-08-04 jrmu stack-reg-name reg-name))))))
273 665c255d 2023-08-04 jrmu (define (stack-inst-reg-name stack-instruction)
274 665c255d 2023-08-04 jrmu (cadr stack-instruction))
275 665c255d 2023-08-04 jrmu (define (make-perform inst machine labels operations pc)
276 665c255d 2023-08-04 jrmu (let ((action (perform-action inst)))
277 665c255d 2023-08-04 jrmu (if (operation-exp? action)
278 665c255d 2023-08-04 jrmu (let ((action-proc
279 665c255d 2023-08-04 jrmu (make-operation-exp
280 665c255d 2023-08-04 jrmu action machine labels operations)))
282 665c255d 2023-08-04 jrmu (action-proc)
283 665c255d 2023-08-04 jrmu (advance-pc pc)))
284 665c255d 2023-08-04 jrmu (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
285 665c255d 2023-08-04 jrmu (define (perform-action inst) (cdr inst))
286 665c255d 2023-08-04 jrmu (define (make-primitive-exp exp machine labels)
287 665c255d 2023-08-04 jrmu (cond ((constant-exp? exp)
288 665c255d 2023-08-04 jrmu (let ((c (constant-exp-value exp)))
289 665c255d 2023-08-04 jrmu (lambda () c)))
290 665c255d 2023-08-04 jrmu ((label-exp? exp)
291 665c255d 2023-08-04 jrmu (let ((insts
292 665c255d 2023-08-04 jrmu (lookup-label labels
293 665c255d 2023-08-04 jrmu (label-exp-label exp))))
294 665c255d 2023-08-04 jrmu (lambda () insts)))
295 665c255d 2023-08-04 jrmu ((register-exp? exp)
296 665c255d 2023-08-04 jrmu (let ((r (get-register machine
297 665c255d 2023-08-04 jrmu (register-exp-reg exp))))
298 665c255d 2023-08-04 jrmu (lambda () (get-contents r))))
300 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ASSEMBLE" exp))))
301 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
302 665c255d 2023-08-04 jrmu (and (pair? exp) (eq? (car exp) tag)))
303 665c255d 2023-08-04 jrmu (define (register-exp? exp) (tagged-list? exp 'reg))
304 665c255d 2023-08-04 jrmu (define (register-exp-reg exp) (cadr exp))
305 665c255d 2023-08-04 jrmu (define (constant-exp? exp) (tagged-list? exp 'const))
306 665c255d 2023-08-04 jrmu (define (constant-exp-value exp) (cadr exp))
307 665c255d 2023-08-04 jrmu (define (label-exp? exp) (tagged-list? exp 'label))
308 665c255d 2023-08-04 jrmu (define (label-exp-label exp) (cadr exp))
309 665c255d 2023-08-04 jrmu (define (make-operation-exp exp machine labels operations)
310 665c255d 2023-08-04 jrmu (let ((op (lookup-prim (operation-exp-op exp) operations))
312 665c255d 2023-08-04 jrmu (map (lambda (e)
313 665c255d 2023-08-04 jrmu ;; (if (label-exp? e)
314 665c255d 2023-08-04 jrmu ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
316 665c255d 2023-08-04 jrmu (make-primitive-exp e machine labels))
317 665c255d 2023-08-04 jrmu (operation-exp-operands exp))))
319 665c255d 2023-08-04 jrmu (apply op (map (lambda (p) (p)) aprocs)))))
320 665c255d 2023-08-04 jrmu (define (operation-exp? exp)
321 665c255d 2023-08-04 jrmu (and (pair? exp) (tagged-list? (car exp) 'op)))
322 665c255d 2023-08-04 jrmu (define (operation-exp-op operation-exp)
323 665c255d 2023-08-04 jrmu (cadr (car operation-exp)))
324 665c255d 2023-08-04 jrmu (define (operation-exp-operands operation-exp)
325 665c255d 2023-08-04 jrmu (cdr operation-exp))
326 665c255d 2023-08-04 jrmu (define (lookup-prim symbol operations)
327 665c255d 2023-08-04 jrmu (let ((val (assoc symbol operations)))
330 665c255d 2023-08-04 jrmu (error "Unknown operation -- ASSEMBLE" symbol))))
332 665c255d 2023-08-04 jrmu ;; test suite
334 665c255d 2023-08-04 jrmu (define (test-case actual expected)
336 665c255d 2023-08-04 jrmu (display "Actual: ")
337 665c255d 2023-08-04 jrmu (display actual)
339 665c255d 2023-08-04 jrmu (display "Expected: ")
340 665c255d 2023-08-04 jrmu (display expected)
343 665c255d 2023-08-04 jrmu (define gcd-machine
344 665c255d 2023-08-04 jrmu (make-machine
346 665c255d 2023-08-04 jrmu (list (list 'rem remainder) (list '= =))
348 665c255d 2023-08-04 jrmu (test (op =) (reg b) (const 0))
349 665c255d 2023-08-04 jrmu (branch (label gcd-done))
350 665c255d 2023-08-04 jrmu (assign t (op rem) (reg a) (reg b))
351 665c255d 2023-08-04 jrmu (assign a (reg b))
352 665c255d 2023-08-04 jrmu (assign b (reg t))
353 665c255d 2023-08-04 jrmu (goto (label test-b))
354 665c255d 2023-08-04 jrmu gcd-done)))
355 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'a 206)
356 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'b 40)
357 665c255d 2023-08-04 jrmu (start gcd-machine)
358 665c255d 2023-08-04 jrmu (test-case (get-register-contents gcd-machine 'a) 2)
360 665c255d 2023-08-04 jrmu (define fib-machine
361 665c255d 2023-08-04 jrmu (make-machine
362 665c255d 2023-08-04 jrmu '(n val continue)
363 665c255d 2023-08-04 jrmu `((< ,<) (- ,-) (+ ,+))
364 665c255d 2023-08-04 jrmu '(controller
365 665c255d 2023-08-04 jrmu (assign continue (label fib-done))
367 665c255d 2023-08-04 jrmu (test (op <) (reg n) (const 2))
368 665c255d 2023-08-04 jrmu (branch (label immediate-answer))
369 665c255d 2023-08-04 jrmu (save continue)
370 665c255d 2023-08-04 jrmu (assign continue (label afterfib-n-1))
372 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
373 665c255d 2023-08-04 jrmu (goto (label fib-loop))
374 665c255d 2023-08-04 jrmu afterfib-n-1
375 665c255d 2023-08-04 jrmu (restore n)
376 665c255d 2023-08-04 jrmu (restore continue)
377 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 2))
378 665c255d 2023-08-04 jrmu (save continue)
379 665c255d 2023-08-04 jrmu (assign continue (label afterfib-n-2))
381 665c255d 2023-08-04 jrmu (goto (label fib-loop))
382 665c255d 2023-08-04 jrmu afterfib-n-2
383 665c255d 2023-08-04 jrmu (assign n (reg val))
384 665c255d 2023-08-04 jrmu (restore val)
385 665c255d 2023-08-04 jrmu (restore continue)
386 665c255d 2023-08-04 jrmu (assign val
387 665c255d 2023-08-04 jrmu (op +) (reg val) (reg n))
388 665c255d 2023-08-04 jrmu (goto (reg continue))
389 665c255d 2023-08-04 jrmu immediate-answer
390 665c255d 2023-08-04 jrmu (assign val (reg n))
391 665c255d 2023-08-04 jrmu (goto (reg continue))
392 665c255d 2023-08-04 jrmu fib-done)))
393 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'val 0)
394 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'n 15)
395 665c255d 2023-08-04 jrmu (start fib-machine)
396 665c255d 2023-08-04 jrmu (test-case (get-register-contents fib-machine 'val) 610)
398 665c255d 2023-08-04 jrmu (define fact-iter
399 665c255d 2023-08-04 jrmu (make-machine
400 665c255d 2023-08-04 jrmu '(product counter n)
401 665c255d 2023-08-04 jrmu `((> ,>) (* ,*) (+ ,+))
402 665c255d 2023-08-04 jrmu '((assign product (const 1))
403 665c255d 2023-08-04 jrmu (assign counter (const 1))
405 665c255d 2023-08-04 jrmu (test (op >) (reg counter) (reg n))
406 665c255d 2023-08-04 jrmu (branch (label fact-end))
407 665c255d 2023-08-04 jrmu (assign product (op *) (reg counter) (reg product))
408 665c255d 2023-08-04 jrmu (assign counter (op +) (reg counter) (const 1))
409 665c255d 2023-08-04 jrmu (goto (label fact-loop))
410 665c255d 2023-08-04 jrmu fact-end)))
411 665c255d 2023-08-04 jrmu (set-register-contents! fact-iter 'n 10)
412 665c255d 2023-08-04 jrmu (start fact-iter)
413 665c255d 2023-08-04 jrmu (test-case (get-register-contents fact-iter 'product) 3628800)
415 665c255d 2023-08-04 jrmu (define (sqrt x)
416 665c255d 2023-08-04 jrmu (define (good-enough? guess)
417 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
418 665c255d 2023-08-04 jrmu (define (improve guess)
419 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
420 665c255d 2023-08-04 jrmu (define (sqrt-iter guess)
421 665c255d 2023-08-04 jrmu (if (good-enough? guess)
423 665c255d 2023-08-04 jrmu (sqrt-iter (improve guess))))
424 665c255d 2023-08-04 jrmu (sqrt-iter 1.0))
426 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
427 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
428 665c255d 2023-08-04 jrmu (define (improve guess x)
429 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
430 665c255d 2023-08-04 jrmu (define (average x y)
431 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
432 665c255d 2023-08-04 jrmu (define sqrt-iter-ops
433 665c255d 2023-08-04 jrmu (make-machine
435 665c255d 2023-08-04 jrmu `((good-enough? ,good-enough?)
436 665c255d 2023-08-04 jrmu (improve ,improve)
438 665c255d 2023-08-04 jrmu (square ,square)
439 665c255d 2023-08-04 jrmu (average ,average)
443 665c255d 2023-08-04 jrmu '((assign guess (const 1.0))
445 665c255d 2023-08-04 jrmu (test (op good-enough?) (reg guess) (reg x))
446 665c255d 2023-08-04 jrmu (branch (label sqrt-done))
447 665c255d 2023-08-04 jrmu (assign guess (op improve) (reg guess) (reg x))
448 665c255d 2023-08-04 jrmu (goto (label sqrt-iter))
449 665c255d 2023-08-04 jrmu sqrt-done)))
451 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 27)
452 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
453 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
454 665c255d 2023-08-04 jrmu 5.19615242)
456 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
457 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
458 665c255d 2023-08-04 jrmu (define (improve guess x)
459 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
460 665c255d 2023-08-04 jrmu (define (average x y)
461 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
462 665c255d 2023-08-04 jrmu (define sqrt-iter
463 665c255d 2023-08-04 jrmu (make-machine
464 665c255d 2023-08-04 jrmu '(guess x temp)
465 665c255d 2023-08-04 jrmu `((abs ,abs)
466 665c255d 2023-08-04 jrmu (square ,square)
467 665c255d 2023-08-04 jrmu (average ,average)
471 665c255d 2023-08-04 jrmu '((assign guess (const 1.0))
473 665c255d 2023-08-04 jrmu ;; (test (op good-enough?) (reg guess) (reg x))
474 665c255d 2023-08-04 jrmu (assign temp (op square) (reg guess))
475 665c255d 2023-08-04 jrmu (assign temp (op -) (reg temp) (reg x))
476 665c255d 2023-08-04 jrmu (assign temp (op abs) (reg temp))
477 665c255d 2023-08-04 jrmu (test (op <) (reg temp) (const 0.001))
478 665c255d 2023-08-04 jrmu (branch (label sqrt-done))
479 665c255d 2023-08-04 jrmu ;; (assign guess (op improve) (reg guess) (reg x))
480 665c255d 2023-08-04 jrmu (assign temp (op /) (reg x) (reg guess))
481 665c255d 2023-08-04 jrmu (assign guess (op average) (reg guess) (reg temp))
482 665c255d 2023-08-04 jrmu (goto (label sqrt-iter))
483 665c255d 2023-08-04 jrmu sqrt-done)))
484 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 91)
485 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
486 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
487 665c255d 2023-08-04 jrmu 9.53939201)
489 665c255d 2023-08-04 jrmu (define (expt b n)
490 665c255d 2023-08-04 jrmu (if (= n 0)
492 665c255d 2023-08-04 jrmu (* b (expt b (- n 1)))))
494 665c255d 2023-08-04 jrmu (define expt-rec
495 665c255d 2023-08-04 jrmu (make-machine
496 665c255d 2023-08-04 jrmu '(b n product continue)
500 665c255d 2023-08-04 jrmu '((assign continue (label expt-done))
502 665c255d 2023-08-04 jrmu (test (op =) (reg n) (const 0))
503 665c255d 2023-08-04 jrmu (branch (label base-case))
504 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
505 665c255d 2023-08-04 jrmu (save continue)
506 665c255d 2023-08-04 jrmu (assign continue (label after-b-n-1))
507 665c255d 2023-08-04 jrmu (goto (label expt-rec))
508 665c255d 2023-08-04 jrmu after-b-n-1
509 665c255d 2023-08-04 jrmu (restore continue)
510 665c255d 2023-08-04 jrmu (assign product (op *) (reg b) (reg product))
511 665c255d 2023-08-04 jrmu (goto (reg continue))
513 665c255d 2023-08-04 jrmu (assign product (const 1))
514 665c255d 2023-08-04 jrmu (goto (reg continue))
515 665c255d 2023-08-04 jrmu expt-done)))
517 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'b 3.2)
518 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'n 6)
519 665c255d 2023-08-04 jrmu (start expt-rec)
520 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-rec 'product)
521 665c255d 2023-08-04 jrmu 1073.74182)
523 665c255d 2023-08-04 jrmu (define (expt b n)
524 665c255d 2023-08-04 jrmu (define (expt-iter counter product)
525 665c255d 2023-08-04 jrmu (if (= counter 0)
527 665c255d 2023-08-04 jrmu (expt-iter (- counter 1) (* b product))))
528 665c255d 2023-08-04 jrmu (expt-iter n 1))
530 665c255d 2023-08-04 jrmu (define expt-iter
531 665c255d 2023-08-04 jrmu (make-machine
532 665c255d 2023-08-04 jrmu '(b n counter product)
536 665c255d 2023-08-04 jrmu '((assign counter (reg n))
537 665c255d 2023-08-04 jrmu (assign product (const 1))
539 665c255d 2023-08-04 jrmu (test (op =) (reg counter) (const 0))
540 665c255d 2023-08-04 jrmu (branch (label expt-iter-done))
541 665c255d 2023-08-04 jrmu (assign counter (op -) (reg counter) (const 1))
542 665c255d 2023-08-04 jrmu (assign product (op *) (reg b) (reg product))
543 665c255d 2023-08-04 jrmu (goto (label expt-iter))
544 665c255d 2023-08-04 jrmu expt-iter-done)))
545 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'b 1.6)
546 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'n 17)
547 665c255d 2023-08-04 jrmu (start expt-iter)
548 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-iter 'product)
549 665c255d 2023-08-04 jrmu 2951.47905)
551 665c255d 2023-08-04 jrmu ;; (define amb-machine
552 665c255d 2023-08-04 jrmu ;; (make-machine
556 665c255d 2023-08-04 jrmu ;; (goto (label here))
558 665c255d 2023-08-04 jrmu ;; (assign a (const 3))
559 665c255d 2023-08-04 jrmu ;; (goto (label there))
561 665c255d 2023-08-04 jrmu ;; (assign a (const 4))
562 665c255d 2023-08-04 jrmu ;; (goto (label there))
563 665c255d 2023-08-04 jrmu ;; there)))
565 665c255d 2023-08-04 jrmu ;; (start amb-machine)
566 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents amb-machine 'a)
568 665c255d 2023-08-04 jrmu ;; this now raises an error
570 665c255d 2023-08-04 jrmu ;; Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
572 665c255d 2023-08-04 jrmu ;; (save y)
573 665c255d 2023-08-04 jrmu ;; (save x)
574 665c255d 2023-08-04 jrmu ;; (restore y)
576 665c255d 2023-08-04 jrmu ;; There are several reasonable possibilities for the meaning of restore:
578 665c255d 2023-08-04 jrmu ;; a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
580 665c255d 2023-08-04 jrmu ;; (assign n (reg val))
581 665c255d 2023-08-04 jrmu ;; (restore val)
583 665c255d 2023-08-04 jrmu ;; can now be shortened to
585 665c255d 2023-08-04 jrmu ;; (restore n)
587 665c255d 2023-08-04 jrmu ;; b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
589 665c255d 2023-08-04 jrmu ;; (define mismatch-machine
590 665c255d 2023-08-04 jrmu ;; (make-machine
593 665c255d 2023-08-04 jrmu ;; '((assign x (const 5))
594 665c255d 2023-08-04 jrmu ;; (assign y (const 4))
595 665c255d 2023-08-04 jrmu ;; (save y)
596 665c255d 2023-08-04 jrmu ;; (save x)
597 665c255d 2023-08-04 jrmu ;; (restore y))))
598 665c255d 2023-08-04 jrmu ;; (start mismatch-machine)
601 665c255d 2023-08-04 jrmu ;; c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.
603 665c255d 2023-08-04 jrmu ;; got bored, didn't implement
605 665c255d 2023-08-04 jrmu (define (make-stack)
606 665c255d 2023-08-04 jrmu (let ((s '()))
607 665c255d 2023-08-04 jrmu (define (push x reg-name)
608 665c255d 2023-08-04 jrmu (let ((reg-pair (assoc reg-name s)))
609 665c255d 2023-08-04 jrmu (if (null? reg-pair)
610 665c255d 2023-08-04 jrmu (error "No stack for " reg-name)
611 665c255d 2023-08-04 jrmu (let ((stack (cdr reg-pair)))
612 665c255d 2023-08-04 jrmu (set-cdr! reg-pair (cons x (cdr reg-pair)))))))
613 665c255d 2023-08-04 jrmu (define (pop reg-name)
614 665c255d 2023-08-04 jrmu (let ((reg-pair (assoc reg-name s)))
615 665c255d 2023-08-04 jrmu (if (null? reg-pair)
616 665c255d 2023-08-04 jrmu (error "No stack for " reg-name)
617 665c255d 2023-08-04 jrmu (let ((stack (cdr reg-pair)))
618 665c255d 2023-08-04 jrmu (if (null? stack)
619 665c255d 2023-08-04 jrmu (error "Empty stack -- POP")
620 665c255d 2023-08-04 jrmu (let ((top (car stack)))
621 665c255d 2023-08-04 jrmu (set-cdr! reg-pair (cdr stack))
623 665c255d 2023-08-04 jrmu (define (initialize)
624 665c255d 2023-08-04 jrmu (set! s '())
626 665c255d 2023-08-04 jrmu (define (print-statistics)
628 665c255d 2023-08-04 jrmu (display (list 'total-pushes '= number-pushes
629 665c255d 2023-08-04 jrmu 'maximum-depth '= max-depth)))
630 665c255d 2023-08-04 jrmu (define (dispatch message)
631 665c255d 2023-08-04 jrmu (cond ((eq? message 'push) push)
632 665c255d 2023-08-04 jrmu ((eq? message 'pop) pop)
633 665c255d 2023-08-04 jrmu ((eq? message 'initialize) (initialize))
634 665c255d 2023-08-04 jrmu ((eq? message 'print-statistics)
635 665c255d 2023-08-04 jrmu (print-statistics))
637 665c255d 2023-08-04 jrmu (error "Unknown request -- STACK" message))))
639 665c255d 2023-08-04 jrmu (define (pop stack reg-name)
640 665c255d 2023-08-04 jrmu ((stack 'pop) reg-name))
641 665c255d 2023-08-04 jrmu (define (push stack value reg-name)
642 665c255d 2023-08-04 jrmu ((stack 'push) value reg-name))
