SICP Section 5.2 A Register-Machine Simulator

Exercise 5.7. Use the simulator to test the machines you designed in exercise 5.4.

Answer:
1. Recursive Version
(define expt-machine (make-machine '(n b val continue) (list (list '= =) (list '- -) (list '* *)) '(controller (assign continue (label expt-done)) expt-loop (test (op =) (reg n) (const 0)) ;; Test for (= n 0) (branch (label base-case)) ;; We only need to save continue as b is constant throughout ;; and the successive values of n are not used for calculation. (save continue) (assign n (op -) (reg n) (const 1)) (assign continue (label after-expt)) (goto (label expt-loop)) after-expt (restore continue) (assign val (op *) (reg b) (reg val)) (goto (reg continue)) base-case (assign val (const 1)) (goto (reg continue)) expt-done))) (set-register-contents! expt-machine 'n 2) done (set-register-contents! expt-machine 'b 4) done (start expt-machine) done (get-register-contents expt-machine 'val) 16
2. Iterative Version
(define expt-machine (make-machine '(n b counter product) (list (list '= =) (list '- -) (list '* *)) '(controller (assign counter (reg n)) (assign product (const 1)) expt-loop (test (op =) (reg counter) (const 0)) (branch (label expt-done)) ;; We don't have to save any value in the stack. ;; The result of exponentiation will be available in register product at the end of calculation. (assign counter (op -) (reg counter) (const 1)) (assign product (op *) (reg b) (reg product)) (goto (label expt-loop)) expt-done))) (set-register-contents! expt-machine 'n 2) done (set-register-contents! expt-machine 'b 4) done (start expt-machine) done (get-register-contents expt-machine 'product) 16
Exercise 5.8. The following register-machine code is ambiguous, because the label here is defined more than once:
start (goto (label here)) here (assign a (const 3)) (goto (label there)) here (assign a (const 4)) (goto (label there)) there
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.

Answer: Using the current implementation goto will direct control to the first occurrence of the label here in the sequence of instructions. This means that (assign a (const 3)) will get executed before control proceeds to the label there. Therefore register a will contain the value 3 at the end of execution.

This version of extract-labels checks if a given label is already present in the labels processed so far. If so it raises an error.
(define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (begin (if (assoc next-inst labels) (error "Multiple declarations of label -- EXTRACT-LABELS" next-inst)) (receive insts (cons (make-label-entry next-inst insts) labels))) (receive (cons (make-instruction next-inst) insts) labels)))))))
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.

Answer: I have moved the code that generates aprocs for an operation expression to a helper procedure. This procedure will raise and error if any of the operands of the expression is not a register or a constant.
(define (generate-operation-aprocs exp machine labels) (map (lambda (e) (if (or (register-exp? e) (constant-exp? e)) (make-primitive-exp e machine labels) (error "Operations can only be used with registers and constants -- ASSEMBLE" e))) (operation-exp-operands exp))) (define (make-operation-exp exp machine labels operations) (let ((op (lookup-prim (operation-exp-op exp) operations)) (aprocs (generate-operation-aprocs exp machine labels))) (lambda () (apply op (map (lambda (p) (p)) aprocs)))))
Exercise 5.10. Design a new syntax for register-machine instructions and modify the simulator to use your new syntax. Can you implement your new syntax without changing any part of the simulator except the syntax procedures in this section?

Skipping.

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
(save y) (save x) (restore y)
There are several reasonable possibilities for the meaning of restore:

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).

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.

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.

Answer:
a. The first two statements under the label afterfib-n-2 perform the following actions:
1) Transfer the value of val to n. This means copying fib(n - 2) to n.
2) Restore previously saved fib(n - 1) to val.
N and val are subsequently added to yield fib(n).

These two statements can be replaced with a single restore statement. Consider executing (restore n) instead of these two statements. As fib(n - 1) was the last value restored on the stack n will be assigned the value fib(n - 1). Val already contains fib(n - 2). We can proceed to add them together and still get fib(n).

b. Save instruction has been changed to pass the register name to the stack along with its value. The stack will maintain a list of register-name/value tuples. Pop has been changed to pass the target register name as a parameter. Stack will raise an error if the target register name is not the same as the name associated with the top value in the stack.
(define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (reg-name (stack-inst-reg-name inst))) (lambda () (push stack reg-name (get-contents reg)) (advance-pc pc)))) (define (push stack reg-name value) ((stack 'push) reg-name value)) (define (make-restore inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (reg-name (stack-inst-reg-name inst))) (lambda () (set-contents! reg (pop stack reg-name)) (advance-pc pc)))) (define (pop stack reg-name) ((stack 'pop) reg-name)) (define (make-stack) (let ((s '())) (define (push reg x) (set! s (cons (list reg x) s))) (define (pop reg) (if (null? s) (error "Empty stack -- POP") (let ((top (car s))) (cond ((eq? (car top) reg) (set! s (cdr s)) (cadr top)) (else (error "Register mismatch -- POP" reg (car top))))))) (define (initialize) (set! s '()) 'done) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) pop) ((eq? message 'initialize) (initialize)) (else (error "Unknown request -- STACK" message)))) dispatch))
c. A new table named stack-table will maintain a list of register names and associated stacks. Allocate-register will create a new entry in this table each time a new register is allocated. Make-save will first get the appropriate stack from the machine before pushing the value in. Similarly make-restore will first retrieve the appropriate stack before popping the value.
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (stack-table '())) (define (initialize-stack-table) (for-each (lambda (stack) (stack 'initialize)) (map cadr stack-table))) (let ((the-ops (list (list 'initialize-stack initialize-stack-table))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (begin (set! register-table (cons (list name (make-register name)) register-table)) (allocate-stack-for-register name))) 'register-allocated) (define (allocate-stack-for-register name) (set! stack-table (cons (list name (make-stack)) stack-table))) (define (get-register-stack name) (let ((record (assoc name stack-table))) (if record (cadr record) (error "No stack found for register" name)))) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'get-register-stack) get-register-stack) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (get-register-stack machine register-name) ((machine 'get-register-stack) register-name)) (define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (stack (get-register-stack machine (stack-inst-reg-name inst)))) (lambda () (push stack (get-contents reg)) (advance-pc pc)))) (define (make-restore inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (stack (get-register-stack machine (stack-inst-reg-name inst)))) (lambda () (set-contents! reg (pop stack)) (advance-pc pc))))
Exercise 5.12. The simulator can be used to help determine the data paths required for implementing a machine with a given controller. Extend the assembler to store the following information in the machine model:

* a list of all instructions, with duplicates removed, sorted by instruction type (assign, goto, and so on);

* a list (without duplicates) of the registers used to hold entry points (these are the registers referenced by goto instructions);

* a list (without duplicates) of the registers that are saved or restored;

* for each register, a list (without duplicates) of the sources from which it is assigned (for example, the sources for register val in the factorial machine of figure 5.11 are (const 1) and ((op *) (reg n) (reg val))).

Extend the message-passing interface to the machine to provide access to this new information. To test your analyzer, define the Fibonacci machine from figure 5.12 and examine the lists you constructed.

Answer: I am not quite satisfied with the way I have answered this question. The solution looks flaky and involved too many set! operations in my opinion. If you have any suggestions about how to improve the answer let me know.
(define (contains? x items) (if (null? items) false (if (equal? x (car items)) true (contains? x (cdr items))))) ;; Machine will store ;; 1. A list of instructions sorted by type. ;; 2. A list of registers used to hold entry points. ;; 3. A list of registers that are saved or restored. (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (all-instructions '()) (entry-points '()) (saved-or-restored '()) (register-sources '())) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'get-all-instructions) (for-each (lambda (record) (printf "~a\n" (car record)) (for-each (lambda (item) (printf "\t~a\n" item)) (cdr record))) all-instructions)) ((eq? message 'store-all-instructions) (lambda (instructions) (set! all-instructions instructions))) ((eq? message 'get-entry-points) (printf "Entry point registers:\n") (for-each (lambda (e) (printf "\t~a\n" e)) entry-points)) ((eq? message 'store-entry-points) (lambda (items) (set! entry-points items))) ((eq? message 'get-saved-or-restored-registers) (printf "Saved or restored registers:\n") (for-each (lambda (r) (printf "\t~a\n" r)) saved-or-restored)) ((eq? message 'store-saved-or-restored-registers) (lambda (items) (set! saved-or-restored items))) ((eq? message 'get-register-sources) (for-each (lambda (record) (printf "Register: ~a\n" (car record)) (for-each (lambda (item) (printf "\t~a\n" item)) (cdr record))) register-sources)) ((eq? message 'store-register-sources) (lambda (sources) (set! register-sources sources))) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (store-unique-instructions machine insts) ((machine 'store-all-instructions) insts)) (define (get-unique-instructions machine) (machine 'get-all-instructions)) (define (store-entry-points machine items) ((machine 'store-entry-points) items)) (define (get-entry-points machine) (machine 'get-entry-points)) (define (store-saved-or-restored-registers machine items) ((machine 'store-saved-or-restored-registers) items)) (define (get-saved-or-restored-registers machine) (machine 'get-saved-or-restored-registers)) (define (store-register-sources machine items) ((machine 'store-register-sources) items)) (define (get-register-sources machine) (machine 'get-register-sources)) ;; Assemble will call a procedure to return a unique set of instructions sorted by type. (define (assemble controller-text machine) (extract-labels controller-text (lambda (insts labels) (update-insts! insts labels machine) (store-useful-information machine insts) insts))) (define (store-useful-information machine insts) (let ((unique-instructions '((assign) (branch) (goto) (perform) (restore) (save) (test))) (entry-points '()) (saved-or-restored-registers '()) (register-sources '()) (inst-text (map instruction-text insts))) (define (gather-unique-instructions inst) (let ((record (assoc (car inst) unique-instructions))) (let ((items (cdr record))) (cond ((not (contains? inst items)) (set-cdr! record (cons inst items))))))) (define (gather-entry-points inst) (let ((inst-type (car inst)) (inst-target (cadr inst))) (if (and (eq? inst-type 'goto) ; GOTO instruction. (register-exp? inst-target) ; Target is a register. (not (memq (register-exp-reg inst-target) entry-points))) (set! entry-points (cons (register-exp-reg inst-target) entry-points))))) (define (gather-saved-or-restored-registers inst) (let ((inst-type (car inst)) (inst-target (cadr inst))) (if (and (or (eq? inst-type 'save) ; Save or Restore instruction. (eq? inst-type 'restore)) (not (memq inst-target saved-or-restored-registers))) (set! saved-or-restored-registers (cons inst-target saved-or-restored-registers))))) (define (gather-regigster-sources inst) (if (eq? (car inst) 'assign) ; Assign instruction. (let ((register (assign-reg-name inst)) (source (assign-value-exp inst))) (let ((record (assoc register register-sources))) (if (and record (not (contains? source (cdr record)))) (let ((items (cdr record))) (set-cdr! record (cons source items))) (set! register-sources (cons (list register source) register-sources))))))) (for-each (lambda (inst) (gather-unique-instructions inst) (gather-entry-points inst) (gather-saved-or-restored-registers inst) (gather-regigster-sources inst)) inst-text) (store-unique-instructions machine unique-instructions) (store-entry-points machine entry-points) (store-saved-or-restored-registers machine saved-or-restored-registers) (store-register-sources machine register-sources)))
Exercise 5.13. Modify the simulator so that it uses the controller sequence to determine what registers the machine has rather than requiring a list of registers as an argument to make-machine. Instead of pre-allocating the registers in make-machine, you can allocate them one at a time when they are first seen during assembly of the instructions.

Answer:Make-machine does not require the list of registers to be explicitly passed.
(define (make-machine ops controller-text) (let ((machine (make-new-machine))) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine)) machine))
Update-insts will scan each instruction to find the registers used by that instruction. If that register has not already been installed update-insts will install it. Registers have to be allocated *before* installing the instruction execution procedures.
(define (update-insts! insts labels machine) (let ((pc (get-register machine 'pc)) (flag (get-register machine 'flag)) (stack (machine 'stack)) (ops (machine 'operations)) (installed-registers '())) (for-each (lambda (inst) (for-each (lambda (register) (if (not (memq register installed-registers)) (begin ((machine 'allocate-register) register) (set! installed-registers (cons register installed-registers))))) (find-registers-used (instruction-text inst))) (set-instruction-execution-proc! inst (make-execution-procedure (instruction-text inst) labels machine pc flag stack ops))) insts)))
Find-registers-used will scan the given instruction to find the registers used.
(define (find-registers-used inst) (define (iter inst-text registers) (if (null? inst-text) registers (let ((first (car inst-text)) (rest (cdr inst-text))) (if (and (register-exp? first) (not (memq (register-exp-reg first) registers))) (iter rest (cons (register-exp-reg first) registers)) (iter rest registers))))) (cond ((eq? (car inst) 'assign) (iter (cdr inst) (list (assign-reg-name inst)))) ((or (eq? (car inst) 'save) (eq? (car inst) 'restore)) (list (stack-inst-reg-name inst))) (else (iter (cdr inst) '()))))
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.

Answer:
;; Test setup (define fact-machine (make-machine '(n val continue) (list (list 'read read) (list '- -) (list '* *) (list '= =) (list 'print printf)) '(controller init (assign continue (label fact-done)) ; set up final return address (assign n (op read)) fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) ;; Set up for the recursive call by saving n and continue. ;; Set up continue so that the computation will continue ;; at after-fact when the subroutine returns. (save continue) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)! (goto (reg continue)) ; return to caller base-case (assign val (const 1)) ; base case: 1! = 1 (goto (reg continue)) ; return to caller fact-done (perform (op print) (const "Factorial:~a\n") (reg val)) (perform (op print-stack-statistics)) (perform (op initialize-stack)) (goto (label init))))) (start fact-machine) ;; Results ;; n - total pushes - max depth ;; 2 - 2 - 2 ;; 3 - 4 - 4 ;; 4 - 6 - 6 ;; 5 - 8 - 8 ;; 6 - 10 - 10 ;; 7 - 12 - 12 ;; 8 - 14 - 14 ;; 9 - 16 - 16 ;; 10 - 18 - 18
The total number of pushes and max depth of the stack for calculating n! is given by the formula 2(n - 1).

Exercise 5.15. Add instruction counting to the register machine simulation. That is, have the machine model keep track of the number of instructions executed. Extend the machine model's interface to accept a new message that prints the value of the instruction count and resets the count to zero.

Answer:
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (set! instruction-count (+ instruction-count 1)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (get-instruction-count machine) (machine 'instruction-count)) (define (reset-instruction-count machine) (machine 'reset-instruction-count))
Exercise 5.16. Augment the simulator to provide for instruction tracing. That is, before each instruction is executed, the simulator should print the text of the instruction. Make the machine model accept trace-on and trace-off messages to turn tracing on and off.

Answer:
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (begin (display (instruction-text inst)) (newline))) (set! instruction-count (+ instruction-count 1)) ((instruction-execution-proc inst)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (set-trace-on machine) (machine 'trace-on)) (define (set-trace-off machine) (machine 'trace-off))
Exercise 5.17. Extend the instruction tracing of exercise 5.16 so that before printing an instruction, the simulator prints any labels that immediately precede that instruction in the controller sequence. Be careful to do this in a way that does not interfere with instruction counting (exercise 5.15). You will have to make the simulator retain the necessary label information.

Answer: Extract-labels will include labels as part of instructions.
(define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (let ((new-insts (cons (cons next-inst '()) insts))) (receive new-insts (cons (make-label-entry next-inst new-insts) labels))) (receive (cons (make-instruction next-inst) insts) labels)))))))
Make-execution-procedure will create a special execution procedure for labels. These procedures will advance the program counter (pc) and return the name of the label.
(define (make-execution-procedure inst labels machine pc flag stack ops) (cond ((not (pair? inst)) (make-label-exec-proc inst pc)) ((eq? (car inst) 'assign) (make-assign inst machine labels ops pc)) ((eq? (car inst) 'test) (make-test inst machine labels ops flag pc)) ((eq? (car inst) 'branch) (make-branch inst machine labels flag pc)) ((eq? (car inst) 'goto) (make-goto inst machine labels pc)) ((eq? (car inst) 'save) (make-save inst machine stack pc)) ((eq? (car inst) 'restore) (make-restore inst machine stack pc)) ((eq? (car inst) 'perform) (make-perform inst machine labels ops pc)) (else (error "Unknown instruction type -- ASSEMBLE" inst)))) (define (make-label-exec-proc inst pc) (lambda () (advance-pc pc) inst))
Machine with tracing and counting. Count is not incremented if the instruction being executed is a label.
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (begin (display (instruction-text inst)) (newline))) (if (pair? (car inst)) ;; Not a label. (set! instruction-count (+ instruction-count 1))) ((instruction-execution-proc inst)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (get-instruction-count machine) (machine 'instruction-count)) (define (reset-instruction-count machine) (machine 'reset-instruction-count)) (define (set-trace-on machine) (machine 'trace-on)) (define (set-trace-off machine) (machine 'trace-off))
Exercise 5.18. Modify the make-register procedure of section 5.2.1 so that registers can be traced. Registers should accept messages that turn tracing on and off. When a register is traced, assigning a value to the register should print the name of the register, the old contents of the register, and the new contents being assigned. Extend the interface to the machine model to permit you to turn tracing on and off for designated machine registers.

Answer:
(define (make-register name) (let ((contents '*unassigned*) (tracing false)) (define (set value) (if tracing (printf "~a ~a ~a\n" name contents value)) (set! contents value)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) set) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) (else (error "Unknown request -- REGISTER" message)))) dispatch)) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (begin (display (instruction-text inst)) (newline))) (if (pair? (car inst)) ;; Not a label. (set! instruction-count (+ instruction-count 1))) ((instruction-execution-proc inst)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) ((eq? message 'reg-trace-on) (lambda (reg-name) ((lookup-register reg-name) 'trace-on))) ((eq? message 'reg-trace-off) (lambda (reg-name) ((lookup-register reg-name) 'trace-off))) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (set-reg-trace-on machine reg-name) ((machine 'reg-trace-on) reg-name)) (define (set-reg-trace-off machine reg-name) ((machine 'reg-trace-off) reg-name))
Exercise 5.19. Alyssa P. Hacker wants a breakpoint feature in the simulator to help her debug her machine designs. You have been hired to install this feature for her. She wants to be able to specify a place in the controller sequence where the simulator will stop and allow her to examine the state of the machine. You are to implement a procedure
(set-breakpoint <machine> <label> <n>)
that sets a breakpoint just before the nth instruction after the given label. For example,
(set-breakpoint gcd-machine 'test-b 4)
installs a breakpoint in gcd-machine just before the assignment to register a. When the simulator reaches the breakpoint it should print the label and the offset of the breakpoint and stop executing instructions. Alyssa can then use get-register-contents and set-register-contents! to manipulate the state of the simulated machine. She should then be able to continue execution by saying
(proceed-machine <machine>)
She should also be able to remove a specific breakpoint by means of
(cancel-breakpoint <machine> <label> <n>)
or to remove all breakpoints by means of
(cancel-all-breakpoints <machine>)

Answer: I had a LOT of fun doing this exercise. Sure it took time and I messed up in between. But in the end it was worth the time and energy spent. I present, my first "debugger" :)
(define (remove-from-list element items) (filter (lambda (x) (not (eq? x element))) items)) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false) (breakpoints '()) (current-label '*unassigned*) (line-number 0)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (printf "~a\n" (instruction-text inst))) (cond ((pair? (car inst)) ; Not a label inst. (set! line-number (+ line-number 1))) ; Increment line number (else ; Is a label inst. (set! current-label (car inst)) ; Store the current label name (set! line-number 0))) ; Reset the line number ; Check if there is a breakpoint matching the current label name and line number. (let ((bp (assoc current-label breakpoints))) (cond ((and bp (memq line-number (cdr bp))) (printf "Breakpoint reached ~a ~a About to execute: ~a\n" current-label line-number (instruction-text inst))) (else (if (pair? (car inst)) (set! instruction-count (+ instruction-count 1))) ((instruction-execution-proc inst)) (execute)))))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) ((eq? message 'reg-trace-on) (lambda (reg-name) ((lookup-register reg-name) 'trace-on))) ((eq? message 'reg-trace-off) (lambda (reg-name) ((lookup-register reg-name) 'trace-off))) ((eq? message 'set-breakpoint) (lambda (label n) (let ((bp (assoc label breakpoints))) (cond (bp ; Label is already present in breakpoints. Add line number to list. (let ((line-numbers (cdr bp))) (if (memq n line-numbers) (error "Breakpoint exists -- MACHINE" label n) (set-cdr! bp (cons n line-numbers))))) (else (set! breakpoints (cons (list label n) breakpoints))))))) ((eq? message 'cancel-breakpoint) (lambda (label n) (let ((bp (assoc label breakpoints))) (cond (bp (let ((line-numbers (cdr bp))) (if (memq n line-numbers) (set-cdr! bp (remove-from-list n line-numbers)) (error "Missing breakpoint -- MACHINE" label n)))) (else (error "Missing breakpoint -- MACHINE" label n)))))) ((eq? message 'cancel-all-breakpoints) (set! breakpoints '())) ((eq? message 'proceed-machine) (execute)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (set-breakpoint machine label n) ((machine 'set-breakpoint) label n)) (define (cancel-breakpoint machine label n) ((machine 'cancel-breakpoint) label n)) (define (cancel-all-breakpoints machine) (machine 'cancel-all-breakpoints)) (define (proceed-machine machine) (machine 'proceed-machine))