SICP 問題 5.17

トレースログにラベルネームをつける．
　
extract-labelsでlabelを見つけた時に('label labe-name)の形でinsts, labels両方に登録する．
make-new-machineでtracing-labelを作り，そこに現在のラベルを登録する．
*1の実行形式はそのまま(advanced-pc pc)でpcをすすめるだけ．
後はexecuteを調整する

(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)
               (if (assoc next-inst labels)
                   (error
                    "The same label name is used to indicate two different location "
                    label-name)
                   ;; ここでlabelは('label . next-inst)の形でinstsに登録
                   (let ((insts (cons (list (list 'label next-inst)) insts)))
                     (receive insts
                         (cons (make-label-entry next-inst insts)
                               labels))))
               (receive (cons (make-instruction next-inst)
                              insts)
                   labels)))))))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (the-instruction-counter 0)
        (tracing-flag (lambda (inst) #f))
        (tracing-label 'global))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined rgister: " 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 trace)
        (let ((insts (get-contents pc)))
          (cond ((null? insts) 'done)
                (else
                 ((instruction-execution-proc (car insts)))
                 (cond ((label-exp? (caar insts))
                        (set! tracing-label (cdaar insts)))
                       (else (set! the-instruction-counter (+ 1 the-instruction-counter))
                             (trace (caar insts))))
                 (execute trace)))))
      (define (trace-on)
        (set! tracing-flag (lambda (inst)
                             (display tracing-label)
                             (display " : ")
                             (display inst) (newline)))
        'trace-on)
      (define (trace-off)
        (set! tracing-flag (lambda (inst) #f))
        'trace-off)
      (define (initialize-counter)
        (set! instruction-counter 0))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute tracing-flag))
              ((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-counter) the-instruction-counter)
              ((eq? message 'initilize-counter) (initilize-counter))
              ((eq? message 'trace-on) (trace-on))
              ((eq? message 'trace-off) (trace-off))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(define (make-execution-procedure inst labels machine
                                  pc flag stack 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 stack pc))
        ((eq? (car inst) 'restore)
         (make-restore inst machine stack pc))
        ((eq? (car inst) 'perform)
         (make-perform inst machine labels ops pc))
        ((eq? (car inst) 'label)
         (lambda () (advance-pc pc)))
        (else (error "Unknown instruction type -- ASSEMBLE" inst))))

test

(define fib-machine
  (make-machine
   '(n val continue)
   (list (list '< <) (list '- -) (list '+ +))
   '(start
     (assign continue (label fib-done))
     fib-loop
     (test (op <) (reg n) (const 2))
     (branch (label immediate-answer))
     (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)
     (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
     (assign n (op print-stack-statistics)))))

gosh> (set-register-contents! fib-machine 'n 3)
done
gosh> (fib-machine 'trace-on)
trace-on
gosh> (start fib-machine)
(start) : (assign continue (label fib-done))
(fib-loop) : (test (op <) (reg n) (const 2))
(fib-loop) : (branch (label immediate-answer))
(fib-loop) : (save continue)
(fib-loop) : (assign continue (label afterfib-n-1))
(fib-loop) : (save n)
(fib-loop) : (assign n (op -) (reg n) (const 1))
(fib-loop) : (goto (label fib-loop))
(fib-loop) : (test (op <) (reg n) (const 2))
(fib-loop) : (branch (label immediate-answer))
(fib-loop) : (save continue)
(fib-loop) : (assign continue (label afterfib-n-1))
(fib-loop) : (save n)
(fib-loop) : (assign n (op -) (reg n) (const 1))
(fib-loop) : (goto (label fib-loop))
(fib-loop) : (test (op <) (reg n) (const 2))
(fib-loop) : (branch (label immediate-answer))
(immediate-answer) : (assign val (reg n))
(immediate-answer) : (goto (reg continue))
(afterfib-n-1) : (restore n)
(afterfib-n-1) : (assign n (op -) (reg n) (const 2))
(afterfib-n-1) : (assign continue (label afterfib-n-2))
(afterfib-n-1) : (save val)
(afterfib-n-1) : (goto (label fib-loop))
(fib-loop) : (test (op <) (reg n) (const 2))
(fib-loop) : (branch (label immediate-answer))
(immediate-answer) : (assign val (reg n))
(immediate-answer) : (goto (reg continue))
(afterfib-n-2) : (assign n (reg val))
(afterfib-n-2) : (restore val)
(afterfib-n-2) : (restore continue)
(afterfib-n-2) : (assign val (op +) (reg val) (reg n))
(afterfib-n-2) : (goto (reg continue))
(afterfib-n-1) : (restore n)
(afterfib-n-1) : (assign n (op -) (reg n) (const 2))
(afterfib-n-1) : (assign continue (label afterfib-n-2))
(afterfib-n-1) : (save val)
(afterfib-n-1) : (goto (label fib-loop))
(fib-loop) : (test (op <) (reg n) (const 2))
(fib-loop) : (branch (label immediate-answer))
(immediate-answer) : (assign val (reg n))
(immediate-answer) : (goto (reg continue))
(afterfib-n-2) : (assign n (reg val))
(afterfib-n-2) : (restore val)
(afterfib-n-2) : (restore continue)
(afterfib-n-2) : (assign val (op +) (reg val) (reg n))
(afterfib-n-2) : (goto (reg continue))

(total-pushes = 6 maximum-depth = 4)(fib-done) : (assign n (op print-stack-statistics))
done