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-stack-pair reg-name contents)
250 (cons reg-name contents))
251 (define (stack-pair-reg-name pair)
253 (define (stack-pair-val pair)
255 (define (make-save inst machine stack pc)
256 (let* ((reg-name (stack-inst-reg-name inst))
257 (reg (get-register machine reg-name)))
259 (push stack (make-stack-pair reg-name (get-contents reg)))
261 (define (make-restore inst machine stack pc)
262 (let* ((reg-name (stack-inst-reg-name inst))
263 (reg (get-register machine reg-name)))
265 (let* ((stack-pair (pop stack))
266 (stack-reg-name (stack-pair-reg-name stack-pair))
267 (stack-val (stack-pair-val stack-pair)))
268 (if (eq? stack-reg-name reg-name)
269 (begin (set-contents! reg stack-val)
271 (error "Stack/register mismatch -- Save/Restore: "
272 stack-reg-name reg-name))))))
273 (define (stack-inst-reg-name stack-instruction)
274 (cadr stack-instruction))
275 (define (make-perform inst machine labels operations pc)
276 (let ((action (perform-action inst)))
277 (if (operation-exp? action)
280 action machine labels operations)))
284 (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
285 (define (perform-action inst) (cdr inst))
286 (define (make-primitive-exp exp machine labels)
287 (cond ((constant-exp? exp)
288 (let ((c (constant-exp-value exp)))
293 (label-exp-label exp))))
296 (let ((r (get-register machine
297 (register-exp-reg exp))))
298 (lambda () (get-contents r))))
300 (error "Unknown expression type -- ASSEMBLE" exp))))
301 (define (tagged-list? exp tag)
302 (and (pair? exp) (eq? (car exp) tag)))
303 (define (register-exp? exp) (tagged-list? exp 'reg))
304 (define (register-exp-reg exp) (cadr exp))
305 (define (constant-exp? exp) (tagged-list? exp 'const))
306 (define (constant-exp-value exp) (cadr exp))
307 (define (label-exp? exp) (tagged-list? exp 'label))
308 (define (label-exp-label exp) (cadr exp))
309 (define (make-operation-exp exp machine labels operations)
310 (let ((op (lookup-prim (operation-exp-op exp) operations))
313 ;; (if (label-exp? e)
314 ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
316 (make-primitive-exp e machine labels))
317 (operation-exp-operands exp))))
319 (apply op (map (lambda (p) (p)) aprocs)))))
320 (define (operation-exp? exp)
321 (and (pair? exp) (tagged-list? (car exp) 'op)))
322 (define (operation-exp-op operation-exp)
323 (cadr (car operation-exp)))
324 (define (operation-exp-operands operation-exp)
326 (define (lookup-prim symbol operations)
327 (let ((val (assoc symbol operations)))
330 (error "Unknown operation -- ASSEMBLE" symbol))))
334 (define (test-case actual expected)
339 (display "Expected: ")
346 (list (list 'rem remainder) (list '= =))
348 (test (op =) (reg b) (const 0))
349 (branch (label gcd-done))
350 (assign t (op rem) (reg a) (reg b))
353 (goto (label test-b))
355 (set-register-contents! gcd-machine 'a 206)
356 (set-register-contents! gcd-machine 'b 40)
358 (test-case (get-register-contents gcd-machine 'a) 2)
363 `((< ,<) (- ,-) (+ ,+))
365 (assign continue (label fib-done))
367 (test (op <) (reg n) (const 2))
368 (branch (label immediate-answer))
370 (assign continue (label afterfib-n-1))
372 (assign n (op -) (reg n) (const 1))
373 (goto (label fib-loop))
377 (assign n (op -) (reg n) (const 2))
379 (assign continue (label afterfib-n-2))
381 (goto (label fib-loop))
387 (op +) (reg val) (reg n))
388 (goto (reg continue))
391 (goto (reg continue))
393 (set-register-contents! fib-machine 'val 0)
394 (set-register-contents! fib-machine 'n 15)
396 (test-case (get-register-contents fib-machine 'val) 610)
401 `((> ,>) (* ,*) (+ ,+))
402 '((assign product (const 1))
403 (assign counter (const 1))
405 (test (op >) (reg counter) (reg n))
406 (branch (label fact-end))
407 (assign product (op *) (reg counter) (reg product))
408 (assign counter (op +) (reg counter) (const 1))
409 (goto (label fact-loop))
411 (set-register-contents! fact-iter 'n 10)
413 (test-case (get-register-contents fact-iter 'product) 3628800)
416 (define (good-enough? guess)
417 (< (abs (- (square guess) x)) 0.001))
418 (define (improve guess)
419 (average guess (/ x guess)))
420 (define (sqrt-iter guess)
421 (if (good-enough? guess)
423 (sqrt-iter (improve guess))))
426 (define (good-enough? guess x)
427 (< (abs (- (square guess) x)) 0.001))
428 (define (improve guess x)
429 (average guess (/ x guess)))
430 (define (average x y)
432 (define sqrt-iter-ops
435 `((good-enough? ,good-enough?)
443 '((assign guess (const 1.0))
445 (test (op good-enough?) (reg guess) (reg x))
446 (branch (label sqrt-done))
447 (assign guess (op improve) (reg guess) (reg x))
448 (goto (label sqrt-iter))
451 (set-register-contents! sqrt-iter-ops 'x 27)
452 (start sqrt-iter-ops)
453 (test-case (get-register-contents sqrt-iter-ops 'guess)
456 (define (good-enough? guess x)
457 (< (abs (- (square guess) x)) 0.001))
458 (define (improve guess x)
459 (average guess (/ x guess)))
460 (define (average x y)
471 '((assign guess (const 1.0))
473 ;; (test (op good-enough?) (reg guess) (reg x))
474 (assign temp (op square) (reg guess))
475 (assign temp (op -) (reg temp) (reg x))
476 (assign temp (op abs) (reg temp))
477 (test (op <) (reg temp) (const 0.001))
478 (branch (label sqrt-done))
479 ;; (assign guess (op improve) (reg guess) (reg x))
480 (assign temp (op /) (reg x) (reg guess))
481 (assign guess (op average) (reg guess) (reg temp))
482 (goto (label sqrt-iter))
484 (set-register-contents! sqrt-iter-ops 'x 91)
485 (start sqrt-iter-ops)
486 (test-case (get-register-contents sqrt-iter-ops 'guess)
492 (* b (expt b (- n 1)))))
496 '(b n product continue)
500 '((assign continue (label expt-done))
502 (test (op =) (reg n) (const 0))
503 (branch (label base-case))
504 (assign n (op -) (reg n) (const 1))
506 (assign continue (label after-b-n-1))
507 (goto (label expt-rec))
510 (assign product (op *) (reg b) (reg product))
511 (goto (reg continue))
513 (assign product (const 1))
514 (goto (reg continue))
517 (set-register-contents! expt-rec 'b 3.2)
518 (set-register-contents! expt-rec 'n 6)
520 (test-case (get-register-contents expt-rec 'product)
524 (define (expt-iter counter product)
527 (expt-iter (- counter 1) (* b product))))
532 '(b n counter product)
536 '((assign counter (reg n))
537 (assign product (const 1))
539 (test (op =) (reg counter) (const 0))
540 (branch (label expt-iter-done))
541 (assign counter (op -) (reg counter) (const 1))
542 (assign product (op *) (reg b) (reg product))
543 (goto (label expt-iter))
545 (set-register-contents! expt-iter 'b 1.6)
546 (set-register-contents! expt-iter 'n 17)
548 (test-case (get-register-contents expt-iter 'product)
551 ;; (define amb-machine
556 ;; (goto (label here))
558 ;; (assign a (const 3))
559 ;; (goto (label there))
561 ;; (assign a (const 4))
562 ;; (goto (label there))
565 ;; (start amb-machine)
566 ;; (test-case (get-register-contents amb-machine 'a)
568 ;; this now raises an error
570 ;; Exercise 5.14. Measure the number of pushes and the maximum stack depth required to compute n! for various small values of n using the factorial machine shown in figure 5.11. From your data determine formulas in terms of n for the total number of push operations and the maximum stack depth used in computing n! for any n > 1. Note that each of these is a linear function of n and is thus determined by two constants. In order to get the statistics printed, you will have to augment the factorial machine with instructions to initialize the stack and print the statistics. You may want to also modify the machine so that it repeatedly reads a value for n, computes the factorial, and prints the result (as we did for the GCD machine in figure 5.4), so that you will not have to repeatedly invoke get-register-contents, set-register-contents!, and start.
575 `((= ,=) (- ,-) (* ,*))
576 '((assign continue (label fact-done)) ; set up final return address
578 (test (op =) (reg n) (const 1))
579 (branch (label base-case))
580 ;; Set up for the recursive call by saving n and continue.
581 ;; Set up continue so that the computation will continue
582 ;; at after-fact when the subroutine returns.
585 (assign n (op -) (reg n) (const 1))
586 (assign continue (label after-fact))
587 (goto (label fact-loop))
591 (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
592 (goto (reg continue)) ; return to caller
594 (assign val (const 1)) ; base case: 1! = 1
595 (goto (reg continue)) ; return to caller
597 (perform (op print-stack-statistics)))))
600 (define (test-fact-statistics n)
601 (set-register-contents! fact-rec 'n n)
608 (test-fact-statistics 1)
609 (test-fact-statistics 2)
610 (test-fact-statistics 3)
611 (test-fact-statistics 4)
612 (test-fact-statistics 5)
613 (test-fact-statistics 6)
614 (test-fact-statistics 7)
615 (test-fact-statistics 8)
616 (test-fact-statistics 9)
617 (test-fact-statistics 10)
619 ;; push operations is 4n-6 for n >= 2, maximum depth is 2n-2