5.11 Exercise 5.11

There are (apparently) three different meanings of restore. Paraphrasing the book:

• It puts the last value on the stack into the provided register, regardless of what register it came from.

• It puts the last value on the stack into the provided register, failing if that value wasn’t saved from that register originally.

• It puts the last value saved onto the stack from the provided register back into it (essentially maintaining one stack per register).

Full disclosure: I believe that the first meaning, which is currently implemented in the interpreter, is by far the most reasonable one. But that might be because I’m used to it.

Consider the following instructions from the Fibonacci machine:

afterfib-n-2

(assign n (reg val))

(restore val)

(restore continue)

(assign val (op +) (reg val) (reg n))

(goto (reg continue))

The + operation will continue to work as long as val and n each contain one of the two values we need – after all, addition is commutative. Observe how we move the value from the val register into n and pop the latest stack value into val right after. What would have happened if we had run (restore n) instead? The value that had been in val at the start would have stayed there, and the value that was restored into val would instead be in n. We would add the same values and place the result into val, so the program would continue to work as it should.

However, we could modify the interpreter to support the other meanings of restore. The second, which verifies that you restore into the same register from which a value was saved, can be done relatively easily. All that needs to happen is for the register from which a value originated to be saved on the stack alongside the value. If restore is called and the registers don’t match, the interpreter should throw an error. The changes can almost entirely be confined to make-save and make-restore:

(define (make-save inst machine stack pc)

(let* ((register-name (stack-inst-reg-name inst))

(reg (get-register machine register-name)))

(lambda ()

(push stack (cons register-name (get-contents reg)))

(advance-pc pc))))

(define (make-restore inst machine stack pc)

(let* ((to-register (stack-inst-reg-name inst))

(reg (get-register machine to-register)))

(lambda ()

(let* ((stack-entry (pop stack))

(from-register (car stack-entry))

(stack-value (cdr stack-entry)))

(if (eq? from-register to-register)

(begin

(set-contents! reg stack-value)

(advance-pc pc))

(error (string-append "Tried to restore from register "

(symbol->string from-register)

" into register "

(symbol->string to-register)

" -- ASSEMBLE")))))))

To support this, I’ve added a new operation on registers to retrieve the name:

(define (make-register name)

(let ((contents '*unassigned*))

(define (dispatch message)

(cond ((eq? message 'get) contents)

((eq? message 'set)

(lambda (value) (set! contents value)))

((eq? message 'name) name)

(else

(error "Unknown request -- REGISTER" message))))

dispatch))

(define (get-register-name register)

(register 'name))

We can verify that this works with the following test program:

(define test-restore-machine

(make-machine

'(a b)

'()

'(start-machine

(assign a (const 1))

(save a)

(restore b))))

To support the third meaning, where each register has an independent stack, we will need to make larger changes to the interpreter. For one, make-stack is now going to be a bit of a misnomer – instead, this should create stacks for each of the registers to use. However, for clarity’s sake, I’ll be leaving the name of this function alone.

We are told that initialize-stack should initialize all of the register stacks. This is a little bit interesting – initialize-stack is technically unused as of yet in the interpreter – but it does suggest something about how the design should work. As of now, the machine doesn’t have a dedicated list of all of its registers available when the stack is created, because the user-specified register list is only used after this happens. However, the function that calls make-new-machine does know about these. This implies that we need to move our initialization steps around a bit.

The essential change that I’ll make is to pass the register names in directly to make-new-machine, and to make this function responsible for initializing the registers as well as the stacks. Then I’ll create an list of pairs of register names combined with their stacks. To save from or restore into a given register, I’ll find the stack by name and then perform the normal stack operations on that.

All of the modified functions are below. Note that the operation for creating registers is now fully private.

(define (make-machine register-names ops controller-text)

(let ((machine (make-new-machine register-names)))

((machine 'install-operations) ops)

((machine 'install-instruction-sequence)

(assemble controller-text machine))

machine))

(define (make-new-machine register-names)

(let* ((pc (make-register 'pc))

(flag (make-register 'flag))

(all-register-names (cons 'pc (cons 'flag register-names)))

(stacks (map (lambda (register-name) (cons register-name (make-stack)))

all-register-names))

(the-instruction-sequence '()))

(let ((the-ops

(list (list 'initialize-stack (lambda () (map (lambda (stack) (stack 'initialize))

stacks)))))

(register-table

(list (list 'pc pc) (list 'flag flag))))

(for-each (lambda (name)

(if (assoc name register-table)

(error "Multiply defined register: " name)

(set! register-table

(cons (list name (make-register name))

register-table))))

register-names)

(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 'get-register) lookup-register)

((eq? message 'install-operations)

(lambda (ops) (set! the-ops (append the-ops ops))))

((eq? message 'stacks) stacks)

((eq? message 'operations) the-ops)

(else (error "Unknown request -- MACHINE" message))))

dispatch)))

(define (make-save inst machine stacks pc)

(let* ((register-name (stack-inst-reg-name inst))

(stack (cdr (assoc register-name stacks)))

(reg (get-register machine register-name)))

(lambda ()

(push stack (get-contents reg))

(advance-pc pc))))

(define (make-restore inst machine stacks pc)

(let* ((register-name (stack-inst-reg-name inst))

(reg (get-register machine register-name)))

(lambda ()

(let ((stack (cdr (assoc register-name stacks))))

(set-contents! reg (pop stack))

(advance-pc pc)))))

There were also a couple of places where I renamed a stack variable or operation to stacks, to be more suggestive of its new value. Otherwise, these functions are identical.

(define (update-insts! insts labels machine)

(let ((pc (get-register machine 'pc))

(flag (get-register machine 'flag))

(stacks (machine 'stacks))

(ops (machine 'operations)))

(for-each

(lambda (inst)

(set-instruction-execution-proc!

inst

(make-execution-procedure

(instruction-text inst) labels machine

pc flag stacks ops)))

insts)))

(define (make-execution-procedure inst labels machine pc flag stacks ops)

(cond ((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 stacks pc))

((eq? (car inst) 'restore)

(make-restore inst machine stacks pc))

((eq? (car inst) 'perform)

(make-perform inst machine labels ops pc))

(else (error "Unknown instruction type -- ASSEMBLE" inst))))

Now we can run a modified version of the program given above and see that the stacks are independent:

(define test-restore-machine

(make-machine

'(a b)

'()

'(start-machine

(assign a (const 1))

(assign b (const 2))

(save a)

(save b)

(restore b)

(restore a))))