简单的scheme寄存器机器模拟器的分析

本文代码来自SICP。。。

使用模拟器来模拟寄存器机器如gcd机器和fibnacci机器，模拟器为机器构造出指定的机器指令。这个模拟器只完成对寄存器的模拟。

模拟器试图模拟真实机器下寄存器的工作。下面是模拟器代码

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;other
(define (tagged-list? exp tag)
    (if (pair? exp)
        (eq? (car exp) tag)
        false))


(define (for-each proc  List)
     (map proc List)
     'done)
     
(define (equal? s1 s2)
     (cond  ((and (null? s1) (null? s2)) true)
              ((and (not (pair? s1))  (not (pair? s2))) (eq?  s1 s2))
              ((and (pair? s1) (pair? s2) (eq? (car s1)  (car s2))) (equal? (cdr s1) (cdr s2)))
              (else false)))
     
(define (assoc key records)
     (cond   ((null? records) false)
               ((equal? key (caar records)) (car records))
               (else (assoc key (cdr records)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;机器模型
(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)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;寄存器
(define (make-register name)
     (let ((contents '*unassigned*))
      (define (dispatch message)
           (cond ((eq? message 'get) contents)
                    ((eq? message 'set)
                      (lambda (value) (set! contents value)))
                     (else
                     (error "Unknown request --REGISTER" message))))
          dispatch))
(define (get-contents register)
   (register 'get))
(define (set-contents! register value)
   ((register 'set) value))
;;;;;;;;;;;;;;;;;;;;;;堆栈
(define (make-stack)
   (let ((s ()))
        (define (push x)
        (set! s (cons x s)))
        (define (pop)
           (if (null? s)
               (error "Empty stack --POP")
               (let ((top (car s)))
                   (set! s (cdr s))
                   top)))
         (define (initialize)
              (set! s ())
              'done)
         (define (dispatch message)
          (cond ((eq? message 'push) push)
                  ((eq? message 'pop) (pop))
                  ((eq? message 'initialize) (initialize))
                  (else (error "Unknown request -- STACK"
                                   message))))
         dispatch))
         
(define (pop stack)
(stack 'pop))
(define (push stack value)
((stack 'push) value))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                    基本机器
(define (start machine)
   (machine 'start))
(define (get-register-contents machine register-name)
(get-contents (get-register machine register-name)))
(define (set-register-contents! machine register-name value)
(set-contents! (get-register machine register-name) value)
'done)


(define (make-new-machine)
(let ((pc (make-register 'pc))
       (flag (make-register 'flag))
       (stack (make-stack))
       (the-instruction-sequence ()))
   (let ((the-ops
    (list (list 'initialize-stack
     (lambda () (stack 'initialize)))))
    (register-table
    (list (list 'pc pc) (list 'flag flag))))
(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 (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 'stack) stack)
    ((eq? message 'operations) the-ops)
    (else (error "unknown request--MACHINE" message))))
dispatch)))
(define (get-register machine reg-name)
     ((machine 'get-register) reg-name))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;汇编程序
(define (assemble controller-text machine)
(extract-labels controller-text
(lambda (insts labels)
  (update-insts! insts labels machine)
  insts)))
(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)
                      (receive insts
                        (cons (make-label-entry next-inst
                         insts)
                               labels))
                      (receive (cons (make-instruction next-inst)
                      insts)
                             labels)))))))
(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 stack ops)))
  insts)))
 
(define (make-instruction text)
(cons text ()))
(define (instruction-text inst)
(car inst))
(define (instruction-execution-proc inst)
(cdr inst))
(define (set-instruction-execution-proc! inst proc)
    (set-cdr! inst proc))
(define (make-label-entry label-name insts)
(cons label-name insts))
;;;;;;查找
(define (lookup-label labels label-name)
  ;;;;;;;;;  (display " lookup-label was called")
(let ((val (assoc label-name labels)))
(if val
(cdr val)
(error "Undefined label -- ASSEMBLE" label-name))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;为指令生成执行过程
(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))
 (else (error "Unknown instrucition type -- ASSEMBLE"
  inst))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;assign
(define (make-assign inst machine labels operations pc)
(let ((target
     (get-register machine (assign-reg-name inst)))
       (value-exp (assign-value-exp inst)))
     (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 ()
           (set-contents! target (value-proc))
           (advance-pc pc)))))
(define (assign-reg-name assign-instruction)
(cadr assign-instruction))
(define (assign-value-exp assign-instruction)
    (cddr assign-instruction))
    
(define (advance-pc pc)
     (set-contents! pc (cdr (get-contents pc))))    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;test,branch,goto
(define (make-test inst machine labels operations flag pc)
(let ((condition (test-condition inst)))
(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" inst))))
(define (test-condition test-instruction)
(cdr test-instruction))

(define (make-branch inst machine labels flag pc)
(let ((dest (branch-dest inst)))
(if (label-exp? dest)
(let ((insts 
(lookup-label labels (label-exp-label dest))))
   (lambda ()
    (if (get-contents flag)
     (set-contents! pc insts)
     (advance-pc pc))))
(error "Bad BRANCH instruction -- ASSEMBLE" inst))))
(define (branch-dest branch-instruction)
(cadr branch-instruction))

(define (make-goto inst machine labels pc)
 (let ((dest (goto-dest inst)))
   (cond ((label-exp? dest) 
   (let ((insts  (lookup-label labels 
   (label-exp-label dest))))
         (lambda () (set-contents! pc insts))))
   ((register-exp? dest)
   (let ((reg (get-register machine 
    (register-exp-reg dest))))
   (lambda ()
   (set-contents! pc (get-contents reg)))))
   (else (error "Bad GOTO instruction --  ASSERMBLE"
                   inst)))))
(define (goto-dest goto-instruction)
(cadr goto-instruction))         
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;其他指令
(define  (make-save inst machine stack pc)
(let ((reg (get-register machine 
   (stack-inst-reg-name inst))))
(lambda ()
(push stack (get-contents reg))
(advance-pc pc))))


(define (make-restore inst machine stack pc)
(let ((reg (get-register machine
    (stack-inst-reg-name inst))))
       (lambda ()
            (set-contents! reg (pop stack))
            (advance-pc pc))))
(define (stack-inst-reg-name stack-instruction)
(cadr stack-instruction))


(define (make-perform inst machine labels operations pc)
(let ((action (perform-action inst)))
   (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" inst))))
(define (perform-action inst) (cdr inst))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;子表达式的执行过程
(define (make-primitive-exp exp machine labels)
(cond ((constant-exp? exp)
(let ((c (constant-exp-value exp)))
   (lambda () c)))
 ((label-exp? exp)
  (let ((insts 
  (lookup-label labels
                     (label-exp-label exp))))
     (lambda () insts )))
 ((register-exp? exp)
  (let ((r (get-register machine
  (register-exp-reg exp))))
       (lambda () (get-contents r))))
 (else
  (error "Unknown expression type --- ASSEMBLE" exp))))


(define (register-exp? exp) (tagged-list? exp 'reg))
(define (register-exp-reg exp) (cadr exp))
(define (constant-exp? exp) (tagged-list? exp 'const))
(define (constant-exp-value exp) (cadr exp))
(define (label-exp? exp) (tagged-list? exp 'label))
(define (label-exp-label exp) (cadr exp))


(define (make-operation-exp exp machine labels operations)
(let ((op (lookup-prim (operation-exp-op exp) operations))
       (aprocs
        (map  (lambda (e)
                     (make-primitive-exp e machine labels))
                 (operation-exp-operands exp))))
   (lambda ()
       (apply op (map (lambda (p) (p)) aprocs)))))


(define (operation-exp? exp)
(and (pair? exp) (tagged-list? (car exp) 'op)))
(define (operation-exp-op operation-exp)
    (cadr (car operation-exp)))
(define (operation-exp-operands operation-exp)
    (cdr operation-exp))       

(define (lookup-prim symbol operations)
     (let ((val (assoc symbol operations)))
        (if val
        (cadr val)
        (error "Unknown operatin -- ASSEMBLE" symbol))))

;;;;;;;;;;;;;;;;;;test
(define gcd-machine
(make-machine
'(a b t)
(list (list 'rem remainder) (list '= =))
'(test-b
(test (op =) (reg b) (const 0))
(branch (label gcd-done))
(assign t (op rem) (reg a) (reg b))
(assign a (reg b))
(assign b (reg t))
(goto (label test-b))
        gcd-done)))
 
(set-register-contents! gcd-machine 'a 206)  
(set-register-contents! gcd-machine 'b 40)
(start gcd-machine)
(get-register-contents gcd-machine 'a)  


(define fib-machine
(make-machine
   '(continue n val)
   (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)
         (restore continue)
         (assign n (op -) (reg n) (const 2))
         (save continue)
         (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)))
(set-register-contents! fib-machine 'n 6)
(start fib-machine)
(get-register-contents fib-machine 'val)

这个寄存器模拟器实现了Fibonacci机器和gcd机器的模拟。并为机器构造机器指令，这些指令像是汇编语言一样，而scheme则是机器语言，它实际执行assign，（op +） 等工作。

  下面是模拟器运行原理。。

模拟器的核心是make-machine过程，它以三个参数，一个寄存器表列，所用到的过程表列，和机器控制器内容为参数。返回一个特定的机器。

另外还有set-register-contents!和get-register-contents！对寄存器的值进行读写。最后有start-machine过程开始运行设定的值。。

先看寄存器的实现。。对寄存器的操作只有两个。这里不论是寄存器还是机器的实现都使用了将数据实现为过程的技术。消息机制。。。知道这点，寄存器的实现就不详细说了。不过这一将数据实现为过程的技术是非常方便的。我们并不在set-contents和get-content上下功夫。而是使用一个构造过程。构造出一个数据，当数据的使用像是过程的使用一般。这么做的好处在于，与数据有关的操作全被数据随身携带着，这样就像真实的机器一样。机器是个实体，通知它改变某一值的操作是由机器自己完成，而不是set-contents完成的，这一procedure所做的工作只是通知机器改变某值。这种方法更接近于真实机器。

下面是堆栈的实现，方法类似。。。。。。。

最后只剩下make-machine的实现了，这一过程本质上也采用了与上面相同的技术。实现这一过程只有make-new-machine和一个汇编程序。

make-new-machine的实现包含和一些寄存器机器的理论，如程序计数器。这些是CSA的内容，我也不太懂（最近也在看一本相关的书但没看完，专业单词太多了，字典都翻不着，又或者是我坚持不下去了吧，借口什么的还是算了）。现在写这些博客都坚持不下去，明明代码都测试好的，基本功能都能实现，还得写博客，不爱动弹啊。这本破书我读看了第四遍了。每次看都感觉进步良多。再写博客的时候自己也能更深一步明白内容，，，，

make-new-machine实现了所有（这个所有实在难说，可编程可修改的机器不可能也只有电脑）寄存器机器的基本构造pc，flag寄存器分别用于指示下一个操作指令，和储存判断结果。这是通用的，因为语言中有判断语句，就需要这么干。。。（） 然后就是一些操作的定义。没什么好说的。

程序中值得一看的是汇编程序的实现。汇编程序的作用是将控制器表达式翻译为机器指令表。与之前的求值器不同，汇编程序并不会求值表达式，只是生成一个对机器来说可执行的指令，由于这里的机器是模拟在scheme基础上的。所以这些表达式事实上被构造为scheme过程，在这里实现为lambda表达式的形式。

汇编程序中对pc和flag的操作和insts以及labels这两个汇编程序的内部数据结构是我重点理解的。

汇编程序先对表达式处理，将之变为insts和labels两个数据中储存。在对每条指令make-execution-procedure 

pc的作用是指出下一个指令的执行。这里pc储存的值并不像真实的寄存器一般，固定的储存量。它储存着所有的接下来的指令。在这里与真实的机器不同的是，真实的机器在开始执行指令之前，会先取出由pc寄存器所指向的地址取出指令，这里的pc略有不同。

flag储存着判断的结果。

make-execution-procedure过程对一条指令产生可执行的表达式，事实上它的实现比我所料想的要简单的多（程序总是会这样），判断出指令的类型，然后再分类处理，该怎么做就怎么做，最后再advance-pc 或者是改变pc，但是 每执行一条指令都要更新pc寄存器。

基本上也就这么多了。。。。