sicp-ex-5.11

  
  
 (a)  
 (assign n (reg val)) 
 (restore val) 
 we can use (restore n) replace these two instructions. Because val contain Fib(n-2), (restore n) make n containing Fib(n-1), then (assign val (op +) (reg val) (reg n)) works still. 
  
 (b) 
 ;; in make-save, push the register name and contents on the stack. 
 (define (make-save inst machine stack pc) 
   (let ((reg (get-register machine 
                            (stack-inst-reg-name inst)))) 
     (lambda () 
       (push stack (cons (stack-inst-reg-name inst) (get-contents reg))) 
       (advance-pc pc)))) 
  
 ;; when pop stack, check if the register name on the stack is equal to 
 ;;  reg-name in (restore reg-name) 
 (define (make-restore inst machine stack pc) 
   (let* ((reg-name (stack-inst-reg-name inst)) 
                  (reg (get-register machine reg-name))) 
     (lambda () 
          (let ((pop-reg (pop stack)))  
           (if (eq? (car pop-reg) reg-name) 
           (begin 
                    (set-contents! reg (cdr pop-reg))     
            (advance-pc pc)) 
                   (error "the value is not from register:" reg-name)))))) 
  
 (c) 
 ;; first modify make-stack making it including the name of register.  
 ;; all the named-register are in s, we can use assoc to find it. 
 ;; add interface add-reg-stack to add register to stack.  
 (define (make-stack) 
   (let ((s '())) 
     (define (push reg-name value) 
          (let ((reg (assoc reg-name s))) 
           (if reg 
               (set-cdr! reg (cons value (cdr reg))) 
                   (error "the register is not in the stack -- PUSH" reg-name)))) 
     (define (pop reg-name) 
          (let ((reg (assoc reg-name s))) 
           (if reg 
               (if (null? (cdr reg)) 
                       (error "Empty stack for register -- POP " reg-name) 
                           (let ((top (cadr reg))) 
                            (set-cdr! reg (cddr reg)) 
                            top)) 
                   (error "the register is not in the stack -- POP" reg-name)))) 
         (define (add-reg-stack reg-name) 
          (if (assoc reg-name s) 
              (error "this register is already in the stack -- ADD-REG-STACK" reg-name) 
                  (set! s (cons (list reg-name) s)))) 
     (define (initialize) 
          (for-each 
           (lambda (stack) 
            (set-cdr! stack '())) 
           s) 
       'done) 
     (define (dispatch message) 
       (cond ((eq? message 'push) push) 
             ((eq? message 'pop) pop) 
                         ((eq? message 'add-reg-stack) add-reg-stack) 
             ((eq? message 'initialize) (initialize)) 
             (else (error "Unknown request -- STACK" message)))) 
     dispatch)) 
  
 (define (add-reg-stack stack reg-name) 
  ((stack 'add-reg-stack) reg-name)) 
  
 ;; change make-store and make-restore. because their parameters had change. 
 (define (make-save inst machine stack pc) 
   (let ((reg (get-register machine 
                            (stack-inst-reg-name inst)))) 
     (lambda () 
       (push stack (stack-inst-reg-name inst) (get-contents reg)) 
       (advance-pc pc)))) 
  
 (define (make-restore inst machine stack pc) 
   (let* ((reg-name (stack-inst-reg-name inst)) 
                  (reg (get-register machine reg-name))) 
     (lambda () 
          (let ((value (pop stack reg-name)))  
           (set-contents! reg value)     
       (advance-pc pc))))) 
  
 ;; modify allocate-register in make-new-machine, when allocate a register, 
 ;; add it to stack. 
   (define (allocate-register name) 
         (if (assoc name register-table) 
           (error "Multiply defined register: " name) 
                   (begin 
                    (add-reg-stack stack name) 
            (set! register-table  
                  (cons (list name (make-register name)) 
                        register-table)))) 
         'register-allocated) 

  
 ;;; I chose a different path than shown above. I removed the machine's stack and instead made every register have a stack. 
  
 (define (make-register name) 
   (let ((contents '*unassigned*) 
         (stack (make-stack))) 
     (define (dispatch message) 
       (cond ((eq? message 'get) contents) 
             ((eq? message 'set) 
              (lambda (value) (set! contents value))) 
             ((eq? message 'push)  
              ((stack 'push) contents)) 
             ((eq? message 'restore)  
              (set! contents (stack 'pop))) 
             (else 
              (error "Unknown request -- REGISTER" message)))) 
     dispatch)) 
  
 (define (make-save inst machine stack pc) 
   (let ((reg (get-register machine 
                            (stack-inst-reg-name inst)))) 
     (lambda () 
       (reg 'push) 
       (advance-pc pc)))) 
  
 (define (make-restore inst machine stack pc) 
   (let ((reg (get-register machine 
                            (stack-inst-reg-name inst)))) 
     (lambda () 
       (reg 'restore) 
       (advance-pc pc)))) 
  
 ;; 1. remove the stack parameter being passed around everywhere 
 ;; 2. don't create a stack in the machine 
 ;; 3. snippet of make-new-machine that needs to change 
 (let ((register-table 
        (list (list 'pc pc) (list 'flag flag)))) 
   (let ((the-ops 
          (list (list 'initialize-stack 
                      (lambda ()  
                        (map (lambda (s) (stack 'initialize)) 
                             register-table))))) 
         ...))) 

I took a different path than everyone else... I ended up creating a stack-table similar to the register table.

 ;; Allocate a stack 
 (define (allocate-stack name) 
         (if (assoc name stack-table) 
             (error "Multiply defined stacks: " name) 
             (set! stack-table 
                   (cons 
                     (list name 
                           (make-stack)) 
                     stack-table))) 
         'stack-allocated) 
  
 ;; Then when initializing machine in (make-machine ...) 
  
 (for-each (lambda (reg-name) ;; New stack for each register 
                 ((machine 'allocate-stack) 
                  reg-name)) 
               register-names) 
  
 ;; Initializing all stacks becomes this: 
 (the-ops 
    (list (list 'initialize-stack 
                (lambda () 
                       (for-each (lambda (stack) 
                                   (stack 'initialize)) 
                                 (map cadr stack-table)))))) 

 ;; c. alt.1 
  
 (define (make-save inst machine stack pc) 
   (let ((reg (get-register machine 
                            (stack-inst-reg-name inst)))) 
     (lambda () 
       (push stack (cons reg (get-contents reg))) ;** 
       (advance-pc pc)))) 
  
 (define (pop stack reg) 
   (let loop ((items '()) 
              (top (stack 'pop))) 
     (if (eq? (car top) reg) 
         (begin (for-each (lambda (e) (push stack e)) (reverse items)) top) 
         (loop (cons top items) (stack 'pop))))) 
  
 (define (make-restore inst machine stack pc) 
   (let ((reg (get-register machine 
                            (stack-inst-reg-name inst)))) 
     (lambda () 
       (set-contents! reg (pop stack reg))     ;** 
       (advance-pc pc)))) 
  
 ;;; c. alt.2 
  
 (define (make-machine register-names ops controller-text) 
   (let ((machine (make-new-machine))) 
     (for-each (lambda (register-name) 
                 ((machine 'allocate-register) register-name) 
                 ((machine 'allocate-stack) register-name)) ;++ 
               register-names) 
     ((machine 'install-operations) ops)     
     ((machine 'install-instruction-sequence) 
      (assemble controller-text machine)) 
     machine)) 
  
 (define (make-new-machine) 
   (let ((pc (make-register 'pc)) 
         (flag (make-register 'flag)) 
         ;; (stack (make-stack)) 
         (the-instruction-sequence '())) 
     (let ((the-ops 
            '()) 
           (register-table 
            (list (list 'pc pc) (list 'flag flag))) 
           (stack-table 
            '())) 
       (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 (allocate-stack name)     ;++ 
         (if (assoc name stack-table) 
             (error "Multiply defined register: " name) 
             (set! stack-table 
                   (cons (list name (make-stack)) 
                         stack-table))) 
         'stack-allocated) 
              
       (define (lookup-register name) 
         (let ((val (assoc name register-table))) 
           (if val 
               (cadr val) 
               (error "Unknown register:" name)))) 
  
       (define (lookup-stack name)       ;** 
         (let ((val (assoc name stack-table))) 
           (if val 
               (cadr val) 
               (error "Unknown stack:" 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 'allocate-stack) allocate-stack) ;** 
               ((eq? message 'get-register) lookup-register) 
               ((eq? message 'get-stack) lookup-stack) ;** 
               ((eq? message 'install-operations) 
                (lambda (ops) (set! the-ops (append the-ops ops)))) 
               ((eq? message 'stack) stack) 
               ((eq? message 'operations) the-ops) 
               (else (error "Unknown request -- MACHINE" message)))) 
       dispatch))) 
  
 (define (update-insts! insts labels machine) 
   (let ((pc (get-register machine 'pc)) 
         (flag (get-register machine 'flag)) 
         ;; (stack (machine 'stack)) 
         (ops (machine 'operations))) 
     (for-each 
      (lambda (inst) 
        (set-instruction-execution-proc!  
         inst 
         (make-execution-procedure 
          (instruction-text inst) labels machine 
          pc flag ops)))                 ;** 
      insts))) 
  
 (define (make-execution-procedure inst labels machine 
                                   pc flag 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 pc))   ;** 
         ((eq? (car inst) 'restore) 
          (make-restore inst machine pc)) ;** 
         ((eq? (car inst) 'perform) 
          (make-perform inst machine labels ops pc)) 
         (else (error "Unknown instruction type -- ASSEMBLE" 
                      inst)))) 
  
 (define (get-stack machine reg-name) 
   ((machine 'get-stack) reg-name)) 
  
 (define (make-save inst machine pc) 
   (let* ((reg-name (stack-inst-reg-name inst)) 
          (reg (get-register machine reg-name)) 
          (stack (get-stack machine reg-name))) 
     (lambda () 
       (push stack (get-contents reg)) 
       (advance-pc pc)))) 
  
 (define (make-restore inst machine stack pc) 
   (let* ((reg-name (stack-inst-reg-name inst)) 
          (reg (get-register machine reg-name)) 
          (stack (get-stack machine reg-name))) 
     (lambda () 
       (set-contents! reg (pop stack))     
       (advance-pc pc))))