(wat-aro)

無職から有職者にランクアップしました

SICP 問題 5.12

シミュレータのメッセージパッシングインターフェースを拡張し,以下の情報にアクセスできるようにする.
・命令の型で,格納されたすべての異なる命令のリスト
・エントリポイントの保持に使ったレジスタのリスト
・save, restoreされる異なるレジスタのリスト
・各レジスタに対して,異なる代入元のリスト
 
アセンブラを拡張しろってことなのでextra-labelsの継続渡しの部分で上記4つのリストの雛形を作り,
update-insts!で重複を削除し,ソートしてinstsと一緒に返すようにした.

(define (assemble controller-text machine)
  (extract-labels controller-text
                  (lambda (insts labels type-insts label-regs saved-regs reg-sources)
                    (update-insts! insts labels machine type-insts
                                   label-regs saved-regs reg-sources)
                    )))

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '() '() '() '() '())
      (extract-labels
       (cdr text)
       (lambda (insts labels type-insts label-regs saved-regs reg-sources)
         (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)
                   (receive
                       insts
                       (cons (make-label-entry next-inst insts)
                             labels)
                     type-insts label-regs saved-regs reg-sources))
               (receive
                   (cons (make-instruction next-inst)
                         insts)
                   labels
                 (cons next-inst type-insts)
                 (add-label-reg next-inst label-regs)
                 (add-saved-reg next-inst saved-regs)
                 (add-reg-sources next-inst reg-sources))))))))

(define (add-label-reg next-inst label-regs)
  (if (and (tagged-list? next-inst 'goto)
           (tagged-list? (cadr next-inst) 'reg))
      (cons (cadadr next-inst) label-regs)
      label-regs))

(define (add-saved-reg next-inst saved-regs)
  (if (tagged-list? next-inst 'save)
      (cons (cadr next-inst) saved-regs)
      saved-regs))

(define (add-reg-sources next-inst reg-sources)
  (if (tagged-list? next-inst 'assign)
      (cons (cdr next-inst) reg-sources)
      reg-sources))

(define (tag x) (car x))

;;; 重複は既に排除されている.
(define (sort-reg reg-sources)
  (define (helper first items)
    (cond ((null? items) (list (cons (car first) (list (cdr first)))))
          ((eq? (tag first) (tag (car items)))
           (cons (cons (tag (car items)) (append (cdar items) (list (cdr first))))
                 (cdr items)))
          (else (cons (car items) (helper first (cdr items))))))
  (let recur ((lst reg-sources) (result '()))
    (cond ((null? lst) result)
          ((null? result)
           (recur (cdr lst) (list (cons (caar lst) (list (cdar lst))))))
          (else (recur (cdr lst) (helper (car lst) result))))))

(define (update-insts! insts labels machine type-insts label-regs saved-regs reg-sources)
  (let ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (ops (machine 'operations)))
    (for-each
     (lambda (inst)
       (set-instruction-execution-proc!
        inst
        (make-execution-procedure
         (instruction-text inst) labels machine pc flag ops)))
     insts)
    (list insts
          (sort-reg (delete-duplicates type-insts))
          (delete-duplicates label-regs)
          (delete-duplicates  saved-regs)
          (sort-reg (delete-duplicates reg-sources)))))

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)
    (let ((insts (assemble controller-text machine)))
      ((machine 'install-instruction-sequence) (car insts))
      ((machine 'install-instruction-types) (cadr insts))
      ((machine 'install-label-registers) (caddr insts))
      ((machine 'install-saved-registers) (cadddr insts))
      ((machine 'install-register-sources) (car (cddddr insts)))
      machine)))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (the-instruction-sequence '())
        (the-instruction-types '())
        (the-label-registers '())
        (the-saved-registers '())
        (the-register-sources '()))
    (let ((register-table
           (list (list 'pc pc) (list 'flag flag))))
      (let ((the-ops
             (list (list 'initialize-stack
                         (lambda ()
                           (for-each (lambda (stack) (stack 'initialize))
                                     register-table))))))
        (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)
          (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 'get-register) lookup-register)
                ((eq? message 'install-operations)
                 (lambda (ops) (set! the-ops (append the-ops ops))))
                ((eq? message 'operations) the-ops)
                ((eq? message 'install-instruction-types)
                 (lambda (types) (set! the-instruction-types types)))
                ((eq? message 'install-label-registers)
                 (lambda (regs) (set! the-label-registers regs)))
                ((eq? message 'install-saved-registers)
                 (lambda (saved) (set! the-saved-registers saved)))
                ((eq? message 'install-register-sources)
                 (lambda (sources) (set! the-register-sources sources)))
                ((eq? message 'instruction-types) the-instruction-types)
                ((eq? message 'label-registers) the-label-registers)
                ((eq? message 'saved-registers) the-saved-registers)
                ((eq? message 'register-sources) the-register-sources)
                (else (error "Unknown request -- MACHINE" message))))
        dispatch))))

(define (get-types machine)
  (machine 'instruction-types))

(define (get-label-registers machine)
  (machine 'label-registers))

(define (get-saved-registers machine)
  (machine 'saved-registers))

(define (get-register-sources machine)
  (machine 'register-sources))

test

(define fib-machine
  (make-machine
   '(n val continue)
   (list (list '< <) (list '- -) (list '+ +))
   '(controller
     (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)))

;; 整形した
gosh> (get-types fib-machine)
((assign (continue (label fib-done))
         (continue (label afterfib-n-1))
         (n (op -) (reg n) (const 1))
         (n (op -) (reg n) (const 2))
         (continue (label afterfib-n-2))
         (n (reg val))
         (val (op +) (reg val) (reg n))
         (val (reg n)))
 (test ((op <) (reg n) (const 2)))
 (branch ((label immediate-answer)))
 (save (continue)
       (n)
       (val))
 (goto ((label fib-loop))
       ((reg continue)))
 (restore (n)
          (val)
          (continue)))
gosh> fib-machine
gosh> (get-types fib-machine)
((assign (continue (label fib-done))
         (continue (label afterfib-n-1))
         (n (op -) (reg n) (const 1))
         (n (op -) (reg n) (const 2))
         (continue (label afterfib-n-2))
         (n (reg val))
         (val (op +) (reg val) (reg n))
         (val (reg n)))
 (test ((op <) (reg n) (const 2)))
 (branch ((label immediate-answer)))
 (save (continue)
       (n)
       (val))
 (goto ((label fib-loop))
       ((reg continue)))
 (restore (n)
          (val)
          (continue)))
gosh> (get-label-registers fib-machine)
(continue)
gosh> (get-saved-registers fib-machine)
(continue n val)
gosh> (get-register-sources fib-machine)
((continue ((label fib-done))
           ((label afterfib-n-1))
           ((label afterfib-n-2)))
 (n ((op -) (reg n) (const 1))
    ((op -) (reg n) (const 2))
    ((reg val)))
 (val ((op +) (reg val) (reg n))
      ((reg n))))