さかもとのブログ

つらつらと

SICP演習問題5.13

SICP

とりゃっとちょっと言ってみた．

今回の問題は簡単?だった．
変更点

  1. make-machine
  2. make-assign
  3. make-save
  4. make-primitive-procedure

方針としては

  1. make-machine変数の数を減らす
  2. {make-assign, make-save, make-primitive}を実行するときにそのレジスタが作られているかチェックし，なければ作成してから実行する

これをやれば，他の命令では，レジスタが存在しないはずはないので，この3つの関数にチェックする部分を追加する．追加するものはまったく同じ．

(define (make-machine ops controller-text)
  (let ((machine (make-new-machine)))
    ((machine 'install-operations) ops)
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

(define (make-assign instruction machine labels operations pc)
  (let* ((reg-name (assign-reg-name instruction))
         (target (get-register machine reg-name))
         (value-exp (assign-value-exp instruction)))
    (if (not target)
        (begin
          ((machine 'allocate-register) reg-name)
          (set! target (get-register machine reg-name))))
    (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-save instruction machine stack pc)
  (let* ((reg-name (stack-instruction-reg-name instruction))
         (reg (get-register machine reg-name)))
    (if (not reg)
        (begin
          ((machine 'allocate-register) reg-name)
          (set! reg (get-register machine reg-name))))
    (lambda ()
      (push stack (get-contents reg))
      (advance-pc pc))
    ))

(define (make-primitive-exp exp machine labels)
  (cond [(constant-exp? exp)
         (let ((constant-value (constant-exp-value exp)))
           (lambda () constant-value))]
         [(label-exp? exp)
          (let ((instructions
                 (lookup-label labels
                               (label-exp-label exp))))
            (lambda () instructions))]
         [(register-exp? exp)
          (let* ((reg-name (register-exp-reg exp))
                 (reg (get-register machine reg-name)))
            (if (not reg)
                (begin
                  ((machine 'allocate-register) reg-name)
                  (set! reg (get-register machine reg-name))))
            (lambda () (get-contents reg)))]
         [else
          (error "Unknown expression type -- ASSEMBLE" exp)])
  )

fibを実行する

(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 n)
     (restore continue)
     (assign val
             (op +) (reg val) (reg n))
     (goto (reg continue))
    immediate-answer
     (assign val (reg n))
     (goto (reg continue))
    fib-done)))
(set-register-contents! fib-machine 'n 3)
(start fib-machine)
(get-register-contents fib-machine 'val)

gosh> (set-register-contents! fib-machine 'n 10)
done
gosh> (start fib-machine)
done
gosh> (get-register-contents fib-machine 'val)
55

追記

では，

;;; make-new-machine の内部定義手続き lookup-register を register
;;; が見つからなかったら作るよう変更する。
(define (lookup-register name)
  (let ((val (assoc name register-table)))
    (if val
        (cadr val)
        (begin (allocate-register name)
               (lookup-register name)))))

確かに....これならいろいろなところに追加しなくていいから簡単です．