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 ;; (if (label-exp? e)
302 ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
304 (make-primitive-exp e machine labels))
305 (operation-exp-operands exp))))
307 (apply op (map (lambda (p) (p)) aprocs)))))
308 (define (operation-exp? exp)
309 (and (pair? exp) (tagged-list? (car exp) 'op)))
310 (define (operation-exp-op operation-exp)
311 (cadr (car operation-exp)))
312 (define (operation-exp-operands operation-exp)
314 (define (lookup-prim symbol operations)
315 (let ((val (assoc symbol operations)))
318 (error "Unknown operation -- ASSEMBLE" symbol))))
322 (define (test-case actual expected)
327 (display "Expected: ")
334 (list (list 'rem remainder) (list '= =))
336 (test (op =) (reg b) (const 0))
337 (branch (label gcd-done))
338 (assign t (op rem) (reg a) (reg b))
341 (goto (label test-b))
343 (set-register-contents! gcd-machine 'a 206)
344 (set-register-contents! gcd-machine 'b 40)
346 (test-case (get-register-contents gcd-machine 'a) 2)
351 `((< ,<) (- ,-) (+ ,+))
353 (assign continue (label fib-done))
355 (test (op <) (reg n) (const 2))
356 (branch (label immediate-answer))
358 (assign continue (label afterfib-n-1))
360 (assign n (op -) (reg n) (const 1))
361 (goto (label fib-loop))
365 (assign n (op -) (reg n) (const 2))
367 (assign continue (label afterfib-n-2))
369 (goto (label fib-loop))
375 (op +) (reg val) (reg n))
376 (goto (reg continue))
379 (goto (reg continue))
381 (set-register-contents! fib-machine 'val 0)
382 (set-register-contents! fib-machine 'n 15)
384 (test-case (get-register-contents fib-machine 'val) 610)
389 `((> ,>) (* ,*) (+ ,+))
390 '((assign product (const 1))
391 (assign counter (const 1))
393 (test (op >) (reg counter) (reg n))
394 (branch (label fact-end))
395 (assign product (op *) (reg counter) (reg product))
396 (assign counter (op +) (reg counter) (const 1))
397 (goto (label fact-loop))
399 (set-register-contents! fact-iter 'n 10)
401 (test-case (get-register-contents fact-iter 'product) 3628800)
404 (define (good-enough? guess)
405 (< (abs (- (square guess) x)) 0.001))
406 (define (improve guess)
407 (average guess (/ x guess)))
408 (define (sqrt-iter guess)
409 (if (good-enough? guess)
411 (sqrt-iter (improve guess))))
414 (define (good-enough? guess x)
415 (< (abs (- (square guess) x)) 0.001))
416 (define (improve guess x)
417 (average guess (/ x guess)))
418 (define (average x y)
420 (define sqrt-iter-ops
423 `((good-enough? ,good-enough?)
431 '((assign guess (const 1.0))
433 (test (op good-enough?) (reg guess) (reg x))
434 (branch (label sqrt-done))
435 (assign guess (op improve) (reg guess) (reg x))
436 (goto (label sqrt-iter))
439 (set-register-contents! sqrt-iter-ops 'x 27)
440 (start sqrt-iter-ops)
441 (test-case (get-register-contents sqrt-iter-ops 'guess)
444 (define (good-enough? guess x)
445 (< (abs (- (square guess) x)) 0.001))
446 (define (improve guess x)
447 (average guess (/ x guess)))
448 (define (average x y)
459 '((assign guess (const 1.0))
461 ;; (test (op good-enough?) (reg guess) (reg x))
462 (assign temp (op square) (reg guess))
463 (assign temp (op -) (reg temp) (reg x))
464 (assign temp (op abs) (reg temp))
465 (test (op <) (reg temp) (const 0.001))
466 (branch (label sqrt-done))
467 ;; (assign guess (op improve) (reg guess) (reg x))
468 (assign temp (op /) (reg x) (reg guess))
469 (assign guess (op average) (reg guess) (reg temp))
470 (goto (label sqrt-iter))
472 (set-register-contents! sqrt-iter-ops 'x 91)
473 (start sqrt-iter-ops)
474 (test-case (get-register-contents sqrt-iter-ops 'guess)
480 (* b (expt b (- n 1)))))
484 '(b n product continue)
488 '((assign continue (label expt-done))
490 (test (op =) (reg n) (const 0))
491 (branch (label base-case))
492 (assign n (op -) (reg n) (const 1))
494 (assign continue (label after-b-n-1))
495 (goto (label expt-rec))
498 (assign product (op *) (reg b) (reg product))
499 (goto (reg continue))
501 (assign product (const 1))
502 (goto (reg continue))
505 (set-register-contents! expt-rec 'b 3.2)
506 (set-register-contents! expt-rec 'n 6)
508 (test-case (get-register-contents expt-rec 'product)
512 (define (expt-iter counter product)
515 (expt-iter (- counter 1) (* b product))))
520 '(b n counter product)
524 '((assign counter (reg n))
525 (assign product (const 1))
527 (test (op =) (reg counter) (const 0))
528 (branch (label expt-iter-done))
529 (assign counter (op -) (reg counter) (const 1))
530 (assign product (op *) (reg b) (reg product))
531 (goto (label expt-iter))
533 (set-register-contents! expt-iter 'b 1.6)
534 (set-register-contents! expt-iter 'n 17)
536 (test-case (get-register-contents expt-iter 'product)
539 ;; (define amb-machine
544 ;; (goto (label here))
546 ;; (assign a (const 3))
547 ;; (goto (label there))
549 ;; (assign a (const 4))
550 ;; (goto (label there))
553 ;; (start amb-machine)
554 ;; (test-case (get-register-contents amb-machine 'a)
556 ;; this now raises an error