1 (define (make-machine register-names ops controller-text)
2 (let ((machine (make-new-machine)))
3 (for-each (lambda (register-name)
4 ((machine 'allocate-register) register-name))
6 ((machine 'install-operations) ops)
7 ((machine 'install-instruction-sequence)
8 (assemble controller-text machine))
10 (define (make-register name)
11 (let ((contents '*unassigned*))
12 (define (dispatch message)
13 (cond ((eq? message 'get) contents)
15 (lambda (value) (set! contents value)))
17 (error "Unknown request -- REGISTER" message))))
19 (define (get-contents register)
21 (define (set-contents! register value)
22 ((register 'set) value))
30 (set! number-pushes (+ 1 number-pushes))
31 (set! current-depth (+ 1 current-depth))
32 (set! max-depth (max current-depth max-depth)))
35 (error "Empty stack -- POP")
38 (set! current-depth (- current-depth 1))
42 (set! number-pushes 0)
44 (set! current-depth 0)
46 (define (print-statistics)
48 (display (list 'total-pushes '= number-pushes
49 'maximum-depth '= max-depth)))
50 (define (dispatch message)
51 (cond ((eq? message 'push) push)
52 ((eq? message 'pop) (pop))
53 ((eq? message 'initialize) (initialize))
54 ((eq? message 'print-statistics)
57 (error "Unknown request -- STACK" message))))
61 (define (push stack value)
62 ((stack 'push) value))
63 (define (make-new-machine)
64 (let ((pc (make-register 'pc))
65 (flag (make-register 'flag))
67 (the-instruction-sequence '()))
69 (list (list 'initialize-stack
70 (lambda () (stack 'initialize)))
71 (list 'print-stack-statistics
72 (lambda () (stack 'print-statistics)))))
74 (list (list 'pc pc) (list 'flag flag))))
75 (define (allocate-register name)
76 (if (assoc name register-table)
77 (error "Multiply defined register: " name)
79 (cons (list name (make-register name))
82 (define (lookup-register name)
83 (let ((val (assoc name register-table)))
86 (error "Unknown register:" name))))
88 (let ((insts (get-contents pc)))
92 ((instruction-execution-proc (car insts)))
94 (define (dispatch message)
95 (cond ((eq? message 'start)
96 (set-contents! pc the-instruction-sequence)
98 ((eq? message 'install-instruction-sequence)
99 (lambda (seq) (set! the-instruction-sequence seq)))
100 ((eq? message 'allocate-register) allocate-register)
101 ((eq? message 'get-register) lookup-register)
102 ((eq? message 'install-operations)
103 (lambda (ops) (set! the-ops (append the-ops ops))))
104 ((eq? message 'stack) stack)
105 ((eq? message 'operations) the-ops)
106 (else (error "Unknown request -- MACHINE" message))))
108 (define (start machine)
110 (define (get-register-contents machine register-name)
111 (get-contents (get-register machine register-name)))
112 (define (set-register-contents! machine register-name value)
113 (set-contents! (get-register machine register-name) value)
115 (define (get-register machine reg-name)
116 ((machine 'get-register) reg-name))
117 (define (assemble controller-text machine)
118 (extract-labels controller-text
119 (lambda (insts labels)
120 (update-insts! insts labels machine)
122 (define (extract-labels text receive)
125 (extract-labels (cdr text)
126 (lambda (insts labels)
127 (let ((next-inst (car text)))
128 (if (symbol? next-inst)
129 (if (label-defined? labels next-inst)
130 (error "Duplicate label -- ASSEMBLE"
134 (cons (make-label-entry next-inst
138 (cons (make-instruction next-inst)
141 (define (update-insts! insts labels machine)
142 (let ((pc (get-register machine 'pc))
143 (flag (get-register machine 'flag))
144 (stack (machine 'stack))
145 (ops (machine 'operations)))
148 (set-instruction-execution-proc!
150 (make-execution-procedure
151 (instruction-text inst) labels machine
154 (define (make-instruction text)
156 (define (instruction-text inst)
158 (define (instruction-execution-proc inst)
160 (define (set-instruction-execution-proc! inst proc)
161 (set-cdr! inst proc))
162 (define (make-label-entry label-name insts)
163 (cons label-name insts))
164 (define (label-defined? labels label-name)
165 (not (false? (assoc label-name labels))))
166 (define (lookup-label labels label-name)
167 (let ((val (assoc label-name labels)))
170 (error "Undefined label -- ASSEMBLE" label-name))))
171 (define (make-execution-procedure inst labels machine
173 (cond ((eq? (car inst) 'assign)
174 (make-assign inst machine labels ops pc))
175 ((eq? (car inst) 'test)
176 (make-test inst machine labels ops flag pc))
177 ((eq? (car inst) 'branch)
178 (make-branch inst machine labels flag pc))
179 ((eq? (car inst) 'goto)
180 (make-goto inst machine labels pc))
181 ((eq? (car inst) 'save)
182 (make-save inst machine stack pc))
183 ((eq? (car inst) 'restore)
184 (make-restore inst machine stack pc))
185 ((eq? (car inst) 'perform)
186 (make-perform inst machine labels ops pc))
187 (else (error "Unknown instruction type -- ASSEMBLE"
189 (define (make-assign inst machine labels operations pc)
191 (get-register machine (assign-reg-name inst)))
192 (value-exp (assign-value-exp inst)))
194 (if (operation-exp? value-exp)
196 value-exp machine labels operations)
198 (car value-exp) machine labels))))
199 (lambda () ; execution procedure for assign
200 (set-contents! target (value-proc))
202 (define (assign-reg-name assign-instruction)
203 (cadr assign-instruction))
204 (define (assign-value-exp assign-instruction)
205 (cddr assign-instruction))
206 (define (advance-pc pc)
207 (set-contents! pc (cdr (get-contents pc))))
208 (define (make-test inst machine labels operations flag pc)
209 (let ((condition (test-condition inst)))
210 (if (operation-exp? condition)
211 (let ((condition-proc
213 condition machine labels operations)))
215 (set-contents! flag (condition-proc))
217 (error "Bad TEST instruction -- ASSEMBLE" inst))))
218 (define (test-condition test-instruction)
219 (cdr test-instruction))
220 (define (make-branch inst machine labels flag pc)
221 (let ((dest (branch-dest inst)))
222 (if (label-exp? dest)
224 (lookup-label labels (label-exp-label dest))))
226 (if (get-contents flag)
227 (set-contents! pc insts)
229 (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
230 (define (branch-dest branch-instruction)
231 (cadr branch-instruction))
232 (define (make-goto inst machine labels pc)
233 (let ((dest (goto-dest inst)))
234 (cond ((label-exp? dest)
237 (label-exp-label dest))))
238 (lambda () (set-contents! pc insts))))
239 ((register-exp? dest)
241 (get-register machine
242 (register-exp-reg dest))))
244 (set-contents! pc (get-contents reg)))))
245 (else (error "Bad GOTO instruction -- ASSEMBLE"
247 (define (goto-dest goto-instruction)
248 (cadr goto-instruction))
249 (define (make-save inst machine stack pc)
250 (let ((reg (get-register machine
251 (stack-inst-reg-name inst))))
253 (push stack (get-contents reg))
255 (define (make-restore inst machine stack pc)
256 (let ((reg (get-register machine
257 (stack-inst-reg-name inst))))
259 (set-contents! reg (pop stack))
261 (define (stack-inst-reg-name stack-instruction)
262 (cadr stack-instruction))
263 (define (make-perform inst machine labels operations pc)
264 (let ((action (perform-action inst)))
265 (if (operation-exp? action)
268 action machine labels operations)))
272 (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
273 (define (perform-action inst) (cdr inst))
274 (define (make-primitive-exp exp machine labels)
275 (cond ((constant-exp? exp)
276 (let ((c (constant-exp-value exp)))
281 (label-exp-label exp))))
284 (let ((r (get-register machine
285 (register-exp-reg exp))))
286 (lambda () (get-contents r))))
288 (error "Unknown expression type -- ASSEMBLE" exp))))
289 (define (tagged-list? exp tag)
290 (and (pair? exp) (eq? (car exp) tag)))
291 (define (register-exp? exp) (tagged-list? exp 'reg))
292 (define (register-exp-reg exp) (cadr exp))
293 (define (constant-exp? exp) (tagged-list? exp 'const))
294 (define (constant-exp-value exp) (cadr exp))
295 (define (label-exp? exp) (tagged-list? exp 'label))
296 (define (label-exp-label exp) (cadr exp))
297 (define (make-operation-exp exp machine labels operations)
298 (let ((op (lookup-prim (operation-exp-op exp) operations))
301 (make-primitive-exp e machine labels))
302 (operation-exp-operands exp))))
304 (apply op (map (lambda (p) (p)) aprocs)))))
305 (define (operation-exp? exp)
306 (and (pair? exp) (tagged-list? (car exp) 'op)))
307 (define (operation-exp-op operation-exp)
308 (cadr (car operation-exp)))
309 (define (operation-exp-operands operation-exp)
311 (define (lookup-prim symbol operations)
312 (let ((val (assoc symbol operations)))
315 (error "Unknown operation -- ASSEMBLE" symbol))))
319 (define (test-case actual expected)
324 (display "Expected: ")
331 (list (list 'rem remainder) (list '= =))
333 (test (op =) (reg b) (const 0))
334 (branch (label gcd-done))
335 (assign t (op rem) (reg a) (reg b))
338 (goto (label test-b))
340 (set-register-contents! gcd-machine 'a 206)
341 (set-register-contents! gcd-machine 'b 40)
343 (test-case (get-register-contents gcd-machine 'a) 2)
348 `((< ,<) (- ,-) (+ ,+))
350 (assign continue (label fib-done))
352 (test (op <) (reg n) (const 2))
353 (branch (label immediate-answer))
355 (assign continue (label afterfib-n-1))
357 (assign n (op -) (reg n) (const 1))
358 (goto (label fib-loop))
362 (assign n (op -) (reg n) (const 2))
364 (assign continue (label afterfib-n-2))
366 (goto (label fib-loop))
372 (op +) (reg val) (reg n))
373 (goto (reg continue))
376 (goto (reg continue))
378 (set-register-contents! fib-machine 'val 0)
379 (set-register-contents! fib-machine 'n 15)
381 (test-case (get-register-contents fib-machine 'val) 610)
386 `((> ,>) (* ,*) (+ ,+))
387 '((assign product (const 1))
388 (assign counter (const 1))
390 (test (op >) (reg counter) (reg n))
391 (branch (label fact-end))
392 (assign product (op *) (reg counter) (reg product))
393 (assign counter (op +) (reg counter) (const 1))
394 (goto (label fact-loop))
396 (set-register-contents! fact-iter 'n 10)
398 (test-case (get-register-contents fact-iter 'product) 3628800)
401 (define (good-enough? guess)
402 (< (abs (- (square guess) x)) 0.001))
403 (define (improve guess)
404 (average guess (/ x guess)))
405 (define (sqrt-iter guess)
406 (if (good-enough? guess)
408 (sqrt-iter (improve guess))))
411 (define (good-enough? guess x)
412 (< (abs (- (square guess) x)) 0.001))
413 (define (improve guess x)
414 (average guess (/ x guess)))
415 (define (average x y)
417 (define sqrt-iter-ops
420 `((good-enough? ,good-enough?)
428 '((assign guess (const 1.0))
430 (test (op good-enough?) (reg guess) (reg x))
431 (branch (label sqrt-done))
432 (assign guess (op improve) (reg guess) (reg x))
433 (goto (label sqrt-iter))
436 (set-register-contents! sqrt-iter-ops 'x 27)
437 (start sqrt-iter-ops)
438 (test-case (get-register-contents sqrt-iter-ops 'guess)
441 (define (good-enough? guess x)
442 (< (abs (- (square guess) x)) 0.001))
443 (define (improve guess x)
444 (average guess (/ x guess)))
445 (define (average x y)
456 '((assign guess (const 1.0))
458 ;; (test (op good-enough?) (reg guess) (reg x))
459 (assign temp (op square) (reg guess))
460 (assign temp (op -) (reg temp) (reg x))
461 (assign temp (op abs) (reg temp))
462 (test (op <) (reg temp) (const 0.001))
463 (branch (label sqrt-done))
464 ;; (assign guess (op improve) (reg guess) (reg x))
465 (assign temp (op /) (reg x) (reg guess))
466 (assign guess (op average) (reg guess) (reg temp))
467 (goto (label sqrt-iter))
469 (set-register-contents! sqrt-iter-ops 'x 91)
470 (start sqrt-iter-ops)
471 (test-case (get-register-contents sqrt-iter-ops 'guess)
477 (* b (expt b (- n 1)))))
481 '(b n product continue)
485 '((assign continue (label expt-done))
487 (test (op =) (reg n) (const 0))
488 (branch (label base-case))
489 (assign n (op -) (reg n) (const 1))
491 (assign continue (label after-b-n-1))
492 (goto (label expt-rec))
495 (assign product (op *) (reg b) (reg product))
496 (goto (reg continue))
498 (assign product (const 1))
499 (goto (reg continue))
502 (set-register-contents! expt-rec 'b 3.2)
503 (set-register-contents! expt-rec 'n 6)
505 (test-case (get-register-contents expt-rec 'product)
509 (define (expt-iter counter product)
512 (expt-iter (- counter 1) (* b product))))
517 '(b n counter product)
521 '((assign counter (reg n))
522 (assign product (const 1))
524 (test (op =) (reg counter) (const 0))
525 (branch (label expt-iter-done))
526 (assign counter (op -) (reg counter) (const 1))
527 (assign product (op *) (reg b) (reg product))
528 (goto (label expt-iter))
530 (set-register-contents! expt-iter 'b 1.6)
531 (set-register-contents! expt-iter 'n 17)
533 (test-case (get-register-contents expt-iter 'product)
536 ;; Exercise 5.8. The following register-machine code is ambiguous, because the label here is defined more than once:
552 ;; With the simulator as written, what will the contents of register a be when control reaches there? Modify the extract-labels procedure so that the assembler will signal an error if the same label name is used to indicate two different locations.
555 (test-case (get-register-contents amb-machine 'a)
557 ;; extract-labels builds insts/labels from the very last instruction to the first instruction and conses them in that order so that the insts/labels are in the same order as in the instruction
558 ;; since lookup-label uses assoc, the labels will also be accessed in the same order as the instruction sequence. Therefore, the (goto (label here)) will branch to the first here label and not the second one
560 Exercise 5.9. The treatment of machine operations above permits them to operate on labels as well as on constants and the contents of registers. Modify the expression-processing procedures to enforce the condition that operations can be used only with registers and constants.