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                (receive insts
130                         (cons (make-label-entry next-inst
131                                                 insts)
132                               labels))
133                (receive (cons (make-instruction next-inst)
134                               insts)
135                         labels)))))))
136 (define (update-insts! insts labels machine)
137   (let ((pc (get-register machine 'pc))
138         (flag (get-register machine 'flag))
139         (stack (machine 'stack))
140         (ops (machine 'operations)))
141     (for-each
142      (lambda (inst)
143        (set-instruction-execution-proc! 
144         inst
145         (make-execution-procedure
146          (instruction-text inst) labels machine
147          pc flag stack ops)))
148      insts)))
149 (define (make-instruction text)
150   (cons text '()))
151 (define (instruction-text inst)
152   (car inst))
153 (define (instruction-execution-proc inst)
154   (cdr inst))
155 (define (set-instruction-execution-proc! inst proc)
156   (set-cdr! inst proc))
157 (define (make-label-entry label-name insts)
158   (cons label-name insts))
159 (define (lookup-label labels label-name)
160   (let ((val (assoc label-name labels)))
161     (if val
162         (cdr val)
163         (error "Undefined label -- ASSEMBLE" label-name))))
164 (define (make-execution-procedure inst labels machine
165                                   pc flag stack ops)
166   (cond ((eq? (car inst) 'assign)
167          (make-assign inst machine labels ops pc))
168         ((eq? (car inst) 'test)
169          (make-test inst machine labels ops flag pc))
170         ((eq? (car inst) 'branch)
171          (make-branch inst machine labels flag pc))
172         ((eq? (car inst) 'goto)
173          (make-goto inst machine labels pc))
174         ((eq? (car inst) 'save)
175          (make-save inst machine stack pc))
176         ((eq? (car inst) 'restore)
177          (make-restore inst machine stack pc))
178         ((eq? (car inst) 'perform)
179          (make-perform inst machine labels ops pc))
180         (else (error "Unknown instruction type -- ASSEMBLE"
181                      inst))))
182 (define (make-assign inst machine labels operations pc)
183   (let ((target
184          (get-register machine (assign-reg-name inst)))
185         (value-exp (assign-value-exp inst)))
186     (let ((value-proc
187            (if (operation-exp? value-exp)
188                (make-operation-exp
189                 value-exp machine labels operations)
190                (make-primitive-exp
191                 (car value-exp) machine labels))))
192       (lambda ()                ; execution procedure for assign
193         (set-contents! target (value-proc))
194         (advance-pc pc)))))
195 (define (assign-reg-name assign-instruction)
196   (cadr assign-instruction))
197 (define (assign-value-exp assign-instruction)
198   (cddr assign-instruction))
199 (define (advance-pc pc)
200   (set-contents! pc (cdr (get-contents pc))))
201 (define (make-test inst machine labels operations flag pc)
202   (let ((condition (test-condition inst)))
203     (if (operation-exp? condition)
204         (let ((condition-proc
205                (make-operation-exp
206                 condition machine labels operations)))
207           (lambda ()
208             (set-contents! flag (condition-proc))
209             (advance-pc pc)))
210         (error "Bad TEST instruction -- ASSEMBLE" inst))))
211 (define (test-condition test-instruction)
212   (cdr test-instruction))
213 (define (make-branch inst machine labels flag pc)
214   (let ((dest (branch-dest inst)))
215     (if (label-exp? dest)
216         (let ((insts
217                (lookup-label labels (label-exp-label dest))))
218           (lambda ()
219             (if (get-contents flag)
220                 (set-contents! pc insts)
221                 (advance-pc pc))))
222         (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
223 (define (branch-dest branch-instruction)
224   (cadr branch-instruction))
225 (define (make-goto inst machine labels pc)
226   (let ((dest (goto-dest inst)))
227     (cond ((label-exp? dest)
228            (let ((insts
229                   (lookup-label labels
230                                 (label-exp-label dest))))
231              (lambda () (set-contents! pc insts))))
232           ((register-exp? dest)
233            (let ((reg
234                   (get-register machine
235                                 (register-exp-reg dest))))
236              (lambda ()
237                (set-contents! pc (get-contents reg)))))
238           (else (error "Bad GOTO instruction -- ASSEMBLE"
239                        inst)))))
240 (define (goto-dest goto-instruction)
241   (cadr goto-instruction))
242 (define (make-save inst machine stack pc)
243   (let ((reg (get-register machine
244                            (stack-inst-reg-name inst))))
245     (lambda ()
246       (push stack (get-contents reg))
247       (advance-pc pc))))
248 (define (make-restore inst machine stack pc)
249   (let ((reg (get-register machine
250                            (stack-inst-reg-name inst))))
251     (lambda ()
252       (set-contents! reg (pop stack))    
253       (advance-pc pc))))
254 (define (stack-inst-reg-name stack-instruction)
255   (cadr stack-instruction))
256 (define (make-perform inst machine labels operations pc)
257   (let ((action (perform-action inst)))
258     (if (operation-exp? action)
259         (let ((action-proc
260                (make-operation-exp
261                 action machine labels operations)))
262           (lambda ()
263             (action-proc)
264             (advance-pc pc)))
265         (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
266 (define (perform-action inst) (cdr inst))
267 (define (make-primitive-exp exp machine labels)
268   (cond ((constant-exp? exp)
269          (let ((c (constant-exp-value exp)))
270            (lambda () c)))
271         ((label-exp? exp)
272          (let ((insts
273                 (lookup-label labels
274                               (label-exp-label exp))))
275            (lambda () insts)))
276         ((register-exp? exp)
277          (let ((r (get-register machine
278                                 (register-exp-reg exp))))
279            (lambda () (get-contents r))))
280         (else
281          (error "Unknown expression type -- ASSEMBLE" exp))))
282 (define (tagged-list? exp tag)
283   (and (pair? exp) (eq? (car exp) tag)))
284 (define (register-exp? exp) (tagged-list? exp 'reg))
285 (define (register-exp-reg exp) (cadr exp))
286 (define (constant-exp? exp) (tagged-list? exp 'const))
287 (define (constant-exp-value exp) (cadr exp))
288 (define (label-exp? exp) (tagged-list? exp 'label))
289 (define (label-exp-label exp) (cadr exp))
290 (define (make-operation-exp exp machine labels operations)
291   (let ((op (lookup-prim (operation-exp-op exp) operations))
292         (aprocs
293          (map (lambda (e)
294                 (make-primitive-exp e machine labels))
295               (operation-exp-operands exp))))
296     (lambda ()
297       (apply op (map (lambda (p) (p)) aprocs)))))
298 (define (operation-exp? exp)
299   (and (pair? exp) (tagged-list? (car exp) 'op)))
300 (define (operation-exp-op operation-exp)
301   (cadr (car operation-exp)))
302 (define (operation-exp-operands operation-exp)
303   (cdr operation-exp))
304 (define (lookup-prim symbol operations)
305   (let ((val (assoc symbol operations)))
306     (if val
307         (cadr val)
308         (error "Unknown operation -- ASSEMBLE" symbol))))
309 
310 ;; test suite
311 
312 (define (test-case actual expected)
313   (newline)
314   (display "Actual:   ")
315   (display actual)
316   (newline)
317   (display "Expected: ")
318   (display expected)
319   (newline))
320 
321 (define gcd-machine
322   (make-machine
323    '(a b t)
324    (list (list 'rem remainder) (list '= =))
325    '(test-b
326        (test (op =) (reg b) (const 0))
327        (branch (label gcd-done))
328        (assign t (op rem) (reg a) (reg b))
329        (assign a (reg b))
330        (assign b (reg t))
331        (goto (label test-b))
332      gcd-done)))
333 (set-register-contents! gcd-machine 'a 206)
334 (set-register-contents! gcd-machine 'b 40)
335 (start gcd-machine)
336 (test-case (get-register-contents gcd-machine 'a) 2)
337 
338 (define fib-machine
339   (make-machine 
340    '(n val continue)
341    `((< ,<) (- ,-) (+ ,+))
342    '(controller
343      (assign continue (label fib-done))
344      fib-loop
345      (test (op <) (reg n) (const 2))
346      (branch (label immediate-answer))
347      (save continue)
348      (assign continue (label afterfib-n-1))
349      (save n)
350      (assign n (op -) (reg n) (const 1))
351      (goto (label fib-loop))
352      afterfib-n-1           
353      (restore n)
354      (restore continue)
355      (assign n (op -) (reg n) (const 2))
356      (save continue)
357      (assign continue (label afterfib-n-2))
358      (save val)
359      (goto (label fib-loop))
360      afterfib-n-2
361      (assign n (reg val))
362      (restore val)       
363      (restore continue)
364      (assign val         
365 	     (op +) (reg val) (reg n)) 
366      (goto (reg continue))
367      immediate-answer
368      (assign val (reg n)) 
369      (goto (reg continue))
370      fib-done)))
371 (set-register-contents! fib-machine 'val 0)
372 (set-register-contents! fib-machine 'n 15)
373 (start fib-machine)
374 (test-case (get-register-contents fib-machine 'val) 610)
375 
376 
377 ;; Exercise 5.1.  Design a register machine to compute factorials using the iterative algorithm specified by the following procedure. Draw data-path and controller diagrams for this machine.
378 
379 (define (factorial n)
380   (define (iter product counter)
381     (if (> counter n)
382         product
383         (iter (* counter product)
384               (+ counter 1))))
385   (iter 1 1))
386 
387 (define fact-iter
388   (make-machine
389    '(product counter n)
390    `((> ,>) (* ,*) (+ ,+))
391    '((assign product (const 1))
392      (assign counter (const 1))
393      fact-loop
394      (test (op >) (reg counter) (reg n))
395      (branch (label fact-end))
396      (assign product (op *) (reg counter) (reg product))
397      (assign counter (op +) (reg counter) (const 1))
398      (goto (label fact-loop))
399      fact-end)))
400 (set-register-contents! fact-iter 'n 10)
401 (start fact-iter)
402 (test-case (get-register-contents fact-iter 'product) 3628800)
403 
404