SICP演習問題5.12

もっとスマートにやりたいものです...

assembleが実行されるときに一緒に作られるようにした．
なので，それぞれの命令に追加した.

(define (make-machine register-names operations controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) operations)
    (machine 'init-analyze-seq) ;; add
    ((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 '())
        (analyze-sequence '())) ;; add(analyzeの結果保存用)
        :
        :
      (define (init-analyze-seq) ;;add(初期化)
        (set! analyze-sequence (map (lambda (x) (list x))
                                    (list 'assign 'test 'branch 'goto 'save 'restore 'perform
                                          'goto-regs 'save-regs 'restore-regs 'source)))
        'done)
      (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 'get-analyze-seq) analyze-sequence] ;; add
              [(eq? message 'init-analyze-seq) (init-analyze-seq)] ;; add
              [(eq? message 'install-operations)
               (lambda (operations) (set! the-operations
                                          (append the-operations operations)))]
              [(eq? message 'stack) stack]
              [(eq? message 'operations) the-operations]
              [else
               (error "Unknown request -- MACHINE" message)]))
      dispatch)))

;; 引数でどのtypeかを判別
(define (insert-analyze-seq! exp machine type)
  (let ((record
         (cond [(eq? type 'inst)
                (assoc (car exp) (machine 'get-analyze-seq))]
               [(eq? type 'goto)
                (assoc 'goto-regs (machine 'get-analyze-seq))]
               [(eq? type 'save)
                (assoc 'save-regs (machine 'get-analyze-seq))]
               [(eq? type 'restore)
                (assoc 'restore-regs (machine 'get-analyze-seq))]
               [(eq? type 'source)
                (assoc 'source (machine 'get-analyze-seq))])))
    (if record
        (if (not (member exp (cdr record)))
            (set-cdr! record (cons exp (cdr record))))
        (error "Analyze error " exp))))

;; 実行して値を見るのはこれ
(define (analyze-machine machine)
  (machine 'get-analyze-seq))

;; それぞれのinstにinsert-analyzeを追加
(define (make-assign instruction machine labels operations pc)
  (insert-analyze-seq! instruction machine 'inst) ;; add
  (let ((target
         (get-register machine (assign-reg-name instruction)))
        (value-exp (assign-value-exp instruction)))
    (insert-analyze-seq! value-exp machine 'source) ;; add(source用)
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp
                value-exp machine labels operations)
               (make-primitive-exp
                (car value-exp) machine labels))))
      (lambda () ;; execution procedure for assign
        (set-contents! target (value-proc))
        (advance-pc pc))
      )))

(define (make-test instruction machine labels operations flag pc)
  (insert-analyze-seq! instruction machine 'inst) ;;
  (let ((condition (test-condition instruction)))
    (if (operation-exp? condition)
        (let ((condition-proc
               (make-operation-exp
                condition machine labels operations)))
          (lambda ()
            (set-contents! flag (condition-proc))
            (advance-pc pc)))
        (error "Bad TEST instruction -- ASSEMBLE" instruction))
    ))

(define (make-branch instruction machine labels flag pc)
  (insert-analyze-seq! instruction machine 'inst) ;;
  (let ((destination (branch-destination instruction)))
    (if (label-exp? destination)
        (let ((instructions
               (lookup-label labels (label-exp-label destination))))
          (lambda ()
            (if (get-contents flag)
                (set-contents! pc instructions)
                (advance-pc pc))))
        (error "Bad BRANCH instructions -- ASSEMBLE" instruction))
    ))

(define (make-goto instruction machine labels pc)
  (insert-analyze-seq! instruction machine 'inst) ;;　add
  (let ((destination (goto-destination instruction)))
    (insert-analyze-seq! (cadr destination) machine 'goto)  ;;  add(gotoの行き先ラベル)
    (cond [(label-exp? destination)
           (let ((instructions
                  (lookup-label labels
                                (label-exp-label destination))))
             (lambda () (set-contents! pc instructions)))]
          [(register-exp? destination)
           (let ((reg
                  (get-register machine
                                (register-exp-reg destination))))
             (lambda ()
               (set-contents! pc (get-contents reg))))]
          [else (error "Bad GOTO instruction -- ASSEMBLE" instruction)])
    ))

(define (make-save instruction machine stack pc)
  (insert-analyze-seq! instruction machine 'inst) ;; add
  (insert-analyze-seq! (cadr instruction) machine 'save) ;; add(save先)
  (let ((reg (get-register machine
                           (stack-instruction-reg-name instruction))))
    (lambda ()
      (push reg (get-contents reg))
      (advance-pc pc))
    ))

(define (make-restore instruction machine stack pc)
  (insert-analyze-seq! instruction machine 'inst) ;; add
  (insert-analyze-seq! (cadr instruction) machine 'restore) ;; add(restore先)
  (let ((reg (get-register machine
                           (stack-instruction-reg-name instruction))))
    (lambda ()
      (set-contents! reg (pop reg))
      (advance-pc pc))
    ))

(define (make-perform instruction machine labels operations pc)
  (insert-analyze-seq! instruction machine 'inst) ;; add
  (let ((action (perform-action instruction)))
    (if (operation-exp? action)
        (let ((action-proc
               (make-operation-exp
                action machine labels operations)))
          (lambda ()
            (action-proc)
            (advance-pc pc)))
        (error "Bad PERFORM instruction -- ASSEMBLE" instruction))
    ))

(define fib-machine
  (make-machine
   '(continue val n)
   (list (list '< <) (list '= =) (list '- -) (list '+ +) (list 'print print))
   '(controller
     (assign continue (label fib-done))
    fib-loop
     (test (op <) (reg n) (const 2))
     (branch (label immediate-answer))
     ;; set up to compute Fib(n-1)
     (save continue)
     (assign continue (label afterfib-n-1))
     (save n)
     (assign n (op -) (reg n) (const 1))
     (goto (label fib-loop))
    afterfib-n-1
     (restore n)
     (perform (op print) (reg n))
     ;; set up to compute Fib(n-2)
     (assign n (op -) (reg n) (const 2))
     (assign continue (label afterfib-n-2))
     (save val)
     (goto (label fib-loop))
    afterfib-n-2
     (assign n (reg val))
     (restore val)
     (restore continue)
     (assign val
             (op +) (reg val) (reg n))
     (goto (reg continue))
    immediate-answer
     (assign val (reg n))
     (goto (reg continue))
    fib-done)))
(analyze-machine fib-machine)

結果

  ((assign (assign val . #0=((reg n)))
          (assign val . #1=((op +) (reg val) (reg n)))
          (assign n . #2=((reg val)))
          (assign continue . #3=((label afterfib-n-2)))
          (assign n . #4=((op -) (reg n) (const 2)))
          (assign n . #5=((op -) (reg n) (const 1)))
          (assign continue . #6=((label afterfib-n-1)))
          (assign continue . #7=((label fib-done))))
  (test (test (op <) (reg n) (const 2)))
  (branch (branch (label immediate-answer)))
  (goto (goto (reg continue))
　        (goto (label fib-loop)))
  (save (save val)
   　     (save n)
      　  (save continue))
  (restore (restore continue)
         　  (restore val)
           　(restore n))
  (perform (perform (op print) (reg n))
  (goto-regs continue fib-loop)
  (save-regs val n continue)
  (restore-regs continue val n)
  (source #0# #1# #2# #3# #4# #5# #6# #7#))