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))
5               register-names)
6     ((machine 'install-operations) ops)    
7     ((machine 'install-instruction-sequence)
8      (assemble controller-text machine))
9     machine))
10 (define (make-register name)
11   (let ((contents '*unassigned*))
12     (define (dispatch message)
13       (cond ((eq? message 'get) contents)
14             ((eq? message 'set)
15              (lambda (value) (set! contents value)))
16             (else
17              (error "Unknown request -- REGISTER" message))))
18     dispatch))
19 (define (get-contents register)
20   (register 'get))
21 (define (set-contents! register value)
22   ((register 'set) value))
23 (define (make-stack)
24   (let ((s '())
25         (number-pushes 0)
26         (max-depth 0)
27         (current-depth 0))
28     (define (push x)
29       (set! s (cons x s))
30       (set! number-pushes (+ 1 number-pushes))
31       (set! current-depth (+ 1 current-depth))
32       (set! max-depth (max current-depth max-depth)))
33     (define (pop)
34       (if (null? s)
35           (error "Empty stack -- POP")
36           (let ((top (car s)))
37             (set! s (cdr s))
38             (set! current-depth (- current-depth 1))
39             top)))    
40     (define (initialize)
41       (set! s '())
42       (set! number-pushes 0)
43       (set! max-depth 0)
44       (set! current-depth 0)
45       'done)
46     (define (print-statistics)
47       (newline)
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)
55              (print-statistics))
56             (else
57              (error "Unknown request -- STACK" message))))
58     dispatch))
59 (define (pop stack)
60   (stack 'pop))
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))
66         (stack (make-stack))
67         (the-instruction-sequence '()))
68     (let ((the-ops
69 	   (list (list 'initialize-stack
70 		       (lambda () (stack 'initialize)))
71 		 (list 'print-stack-statistics
72 		       (lambda () (stack 'print-statistics)))))
73           (register-table
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)
78             (set! register-table
79                   (cons (list name (make-register name))
80                         register-table)))
81         'register-allocated)
82       (define (lookup-register name)
83         (let ((val (assoc name register-table)))
84           (if val
85               (cadr val)
86               (error "Unknown register:" name))))
87       (define (execute)
88         (let ((insts (get-contents pc)))
89           (if (null? insts)
90               'done
91               (begin
92                 ((instruction-execution-proc (car insts)))
93                 (execute)))))
94       (define (dispatch message)
95         (cond ((eq? message 'start)
96                (set-contents! pc the-instruction-sequence)
97                (execute))
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))))
107       dispatch)))
108 (define (start machine)
109   (machine 'start))
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)
114   'done)
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)
121       insts)))
122 (define (extract-labels text receive)
123   (if (null? text)
124       (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"
131 			  next-inst)
132 		   (receive 
133 		       insts
134 		       (cons (make-label-entry next-inst
135 					       insts)
136 			     labels)))
137                (receive
138 		   (cons (make-instruction next-inst)
139 			 insts)
140 		   labels)))))))
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)))
146     (for-each
147      (lambda (inst)
148        (set-instruction-execution-proc! 
149         inst
150         (make-execution-procedure
151          (instruction-text inst) labels machine
152          pc flag stack ops)))
153      insts)))
154 (define (make-instruction text)
155   (cons text '()))
156 (define (instruction-text inst)
157   (car inst))
158 (define (instruction-execution-proc inst)
159   (cdr 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)))
168     (if val
169         (cdr val)
170         (error "Undefined label -- ASSEMBLE" label-name))))
171 (define (make-execution-procedure inst labels machine
172                                   pc flag stack ops)
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"
188                      inst))))
189 (define (make-assign inst machine labels operations pc)
190   (let ((target
191          (get-register machine (assign-reg-name inst)))
192         (value-exp (assign-value-exp inst)))
193     (let ((value-proc
194            (if (operation-exp? value-exp)
195                (make-operation-exp
196                 value-exp machine labels operations)
197                (make-primitive-exp
198                 (car value-exp) machine labels))))
199       (lambda ()                ; execution procedure for assign
200         (set-contents! target (value-proc))
201         (advance-pc pc)))))
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
212                (make-operation-exp
213                 condition machine labels operations)))
214           (lambda ()
215             (set-contents! flag (condition-proc))
216             (advance-pc pc)))
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)
223         (let ((insts
224                (lookup-label labels (label-exp-label dest))))
225           (lambda ()
226             (if (get-contents flag)
227                 (set-contents! pc insts)
228                 (advance-pc pc))))
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)
235            (let ((insts
236                   (lookup-label labels
237                                 (label-exp-label dest))))
238              (lambda () (set-contents! pc insts))))
239           ((register-exp? dest)
240            (let ((reg
241                   (get-register machine
242                                 (register-exp-reg dest))))
243              (lambda ()
244                (set-contents! pc (get-contents reg)))))
245           (else (error "Bad GOTO instruction -- ASSEMBLE"
246                        inst)))))
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)
252   (car pair))
253 (define (stack-pair-val pair)
254   (cdr 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)))
258     (lambda ()
259       (push stack (make-stack-pair reg-name (get-contents reg)))
260       (advance-pc pc))))
261 (define (make-restore inst machine stack pc)
262   (let* ((reg-name (stack-inst-reg-name inst))
263 	 (reg (get-register machine reg-name)))
264     (lambda ()
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)
270 		   (advance-pc pc))
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)
278         (let ((action-proc
279                (make-operation-exp
280                 action machine labels operations)))
281           (lambda ()
282             (action-proc)
283             (advance-pc pc)))
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)))
289            (lambda () c)))
290         ((label-exp? exp)
291          (let ((insts
292                 (lookup-label labels
293                               (label-exp-label exp))))
294            (lambda () insts)))
295         ((register-exp? exp)
296          (let ((r (get-register machine
297                                 (register-exp-reg exp))))
298            (lambda () (get-contents r))))
299         (else
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)) 
311         (aprocs
312          (map (lambda (e)
313 		;; (if (label-exp? e)
314 		;;     (error "Operation exp cannot operate on labels -- ASSEMBLE"
315 		;; 	   exp)
316 		(make-primitive-exp e machine labels))
317               (operation-exp-operands exp))))
318     (lambda ()
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)
325   (cdr operation-exp))
326 (define (lookup-prim symbol operations)
327   (let ((val (assoc symbol operations)))
328     (if val
329         (cadr val)
330         (error "Unknown operation -- ASSEMBLE" symbol))))
331 
332 ;; test suite
333 
334 (define (test-case actual expected)
335   (newline)
336   (display "Actual:   ")
337   (display actual)
338   (newline)
339   (display "Expected: ")
340   (display expected)
341   (newline))
342 
343 (define gcd-machine
344   (make-machine
345    '(a b t)
346    (list (list 'rem remainder) (list '= =))
347    '(test-b
348        (test (op =) (reg b) (const 0))
349        (branch (label gcd-done))
350        (assign t (op rem) (reg a) (reg b))
351        (assign a (reg b))
352        (assign b (reg t))
353        (goto (label test-b))
354      gcd-done)))
355 (set-register-contents! gcd-machine 'a 206)
356 (set-register-contents! gcd-machine 'b 40)
357 (start gcd-machine)
358 (test-case (get-register-contents gcd-machine 'a) 2)
359 
360 (define fib-machine
361   (make-machine 
362    '(n val continue)
363    `((< ,<) (- ,-) (+ ,+))
364    '(controller
365      (assign continue (label fib-done))
366      fib-loop
367      (test (op <) (reg n) (const 2))
368      (branch (label immediate-answer))
369      (save continue)
370      (assign continue (label afterfib-n-1))
371      (save n)
372      (assign n (op -) (reg n) (const 1))
373      (goto (label fib-loop))
374      afterfib-n-1           
375      (restore n)
376      (restore continue)
377      (assign n (op -) (reg n) (const 2))
378      (save continue)
379      (assign continue (label afterfib-n-2))
380      (save val)
381      (goto (label fib-loop))
382      afterfib-n-2
383      (assign n (reg val))
384      (restore val)       
385      (restore continue)
386      (assign val         
387 	     (op +) (reg val) (reg n)) 
388      (goto (reg continue))
389      immediate-answer
390      (assign val (reg n)) 
391      (goto (reg continue))
392      fib-done)))
393 (set-register-contents! fib-machine 'val 0)
394 (set-register-contents! fib-machine 'n 15)
395 (start fib-machine)
396 (test-case (get-register-contents fib-machine 'val) 610)
397 
398 (define fact-iter
399   (make-machine
400    '(product counter n)
401    `((> ,>) (* ,*) (+ ,+))
402    '((assign product (const 1))
403      (assign counter (const 1))
404      fact-loop
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))
410      fact-end)))
411 (set-register-contents! fact-iter 'n 10)
412 (start fact-iter)
413 (test-case (get-register-contents fact-iter 'product) 3628800)
414 
415 (define (sqrt x)
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)
422         guess
423         (sqrt-iter (improve guess))))
424   (sqrt-iter 1.0))
425 
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)
431   (/ (+ x y) 2))
432 (define sqrt-iter-ops
433   (make-machine
434    '(guess x)
435    `((good-enough? ,good-enough?)
436      (improve ,improve)
437      (abs ,abs)
438      (square ,square) 
439      (average ,average)
440      (< ,<)
441      (- ,-)
442      (/ ,/))
443    '((assign guess (const 1.0))
444      sqrt-iter
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))
449      sqrt-done)))
450 
451 (set-register-contents! sqrt-iter-ops 'x 27)
452 (start sqrt-iter-ops)
453 (test-case (get-register-contents sqrt-iter-ops 'guess)
454 	   5.19615242)
455 
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)
461   (/ (+ x y) 2))
462 (define sqrt-iter
463   (make-machine
464    '(guess x temp)
465    `((abs ,abs)
466      (square ,square) 
467      (average ,average)
468      (< ,<)
469      (- ,-)
470      (/ ,/))
471    '((assign guess (const 1.0))
472      sqrt-iter
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))
483      sqrt-done)))
484 (set-register-contents! sqrt-iter-ops 'x 91)
485 (start sqrt-iter-ops)
486 (test-case (get-register-contents sqrt-iter-ops 'guess)
487 	   9.53939201)
488 
489 (define (expt b n)
490   (if (= n 0)
491       1
492       (* b (expt b (- n 1)))))
493 
494 (define expt-rec
495   (make-machine
496    '(b n product continue)
497    `((= ,=)
498      (* ,*)
499      (- ,-))
500    '((assign continue (label expt-done))
501      expt-rec
502      (test (op =) (reg n) (const 0))
503      (branch (label base-case))
504      (assign n (op -) (reg n) (const 1))
505      (save continue)
506      (assign continue (label after-b-n-1))
507      (goto (label expt-rec))
508      after-b-n-1
509      (restore continue)
510      (assign product (op *) (reg b) (reg product))
511      (goto (reg continue))
512      base-case
513      (assign product (const 1))
514      (goto (reg continue))
515      expt-done)))
516 
517 (set-register-contents! expt-rec 'b 3.2)
518 (set-register-contents! expt-rec 'n 6)
519 (start expt-rec)
520 (test-case (get-register-contents expt-rec 'product)
521 	   1073.74182)
522 
523 (define (expt b n)
524   (define (expt-iter counter product)
525     (if (= counter 0)
526         product
527         (expt-iter (- counter 1) (* b product))))
528   (expt-iter n 1))
529 
530 (define expt-iter
531   (make-machine
532    '(b n counter product)
533    `((= ,=)
534      (* ,*)
535      (- ,-))
536    '((assign counter (reg n))
537      (assign product (const 1))
538      expt-iter
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))
544      expt-iter-done)))
545 (set-register-contents! expt-iter 'b 1.6)
546 (set-register-contents! expt-iter 'n 17)
547 (start expt-iter)
548 (test-case (get-register-contents expt-iter 'product) 
549 	   2951.47905)
550 
551 ;; (define amb-machine
552 ;;   (make-machine
553 ;;    '(a)
554 ;;    '()
555 ;;    '(start
556 ;;      (goto (label here))
557 ;;      here
558 ;;      (assign a (const 3))
559 ;;      (goto (label there))
560 ;;      here
561 ;;      (assign a (const 4))
562 ;;      (goto (label there))
563 ;;      there)))
564 
565 ;; (start amb-machine)
566 ;; (test-case (get-register-contents amb-machine 'a)
567 ;; 	   3)
568 ;; this now raises an error
569 
570 ;; 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
571 
572 ;; (save y)
573 ;; (save x)
574 ;; (restore y)
575 
576 ;; There are several reasonable possibilities for the meaning of restore:
577 
578 ;; 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).
579 
580 ;; (assign n (reg val))
581 ;; (restore val)
582 
583 ;; can now be shortened to
584 
585 ;; (restore n)
586 
587 ;; 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.
588 
589 ;; (define mismatch-machine
590 ;;   (make-machine
591 ;;    '(x y)
592 ;;    '()
593 ;;    '((assign x (const 5))
594 ;;      (assign y (const 4))
595 ;;      (save y)
596 ;;      (save x)
597 ;;      (restore y))))
598 ;; (start mismatch-machine)
599 
600 
601 ;; 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.