寄存器机器

(data-paths
 (registers
  ((name a)
   (buttons ((name a<-b) (source (register b)))))
  ((name b)
   (buttons ((name b<-t) (source (register t)))))
  ((name t)
   (buttons ((name t<-r) (source (operation rem))))))

 (operations
  ((name rem)
   (inputs (register a) (register b)))
  ((name =)
   (inputs (register b) (constant 0)))))

(controller
 test-b                           ; label
 (test =)                       ; test
 (branch (label gcd-done))      ; conditional branch
 (t<-r)                         ; button push
 (a<-b)                         ; button push
 (b<-t)                         ; button push
 (goto (label test-b))          ; unconditional branch
 gcd-done)                        ; label

(controller
 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)

(perform (op print) (reg a))

(controller
 gcd-loop
 (assign a (op read))
 (assign b (op read))
 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
 (perform (op print) (reg a))
 (goto (label gcd-loop)))

(controller
 (assign continue (label fact-done))     ; 设置最终返回的执行地址
 fact-loop
 (test (op =) (reg n) (const 1))
 (branch (label base-case))
 ;; 为了执行递归，保存 continue 和 n 的值
 (save continue)
 (save n)
 (assign n (op -) (reg n) (const 1))
 (assign continue (label after-fact)) ;; fact-loop 子程序返回后恢复，使计算可以继续执行 after-fact 
 (goto (label fact-loop))
 after-fact
 (restore n)
 (restore continue)
 (assign val (op *) (reg n) (reg val))   ; val now contains n(n - 1)!
 (goto (reg continue))                   ; return to caller 持续调用 after-fact 最后一次调用 fact-done 
 base-case
 (assign val (const 1))                  ; base case: 1! = 1
 (goto (reg continue))                   ; return to caller 递归调用前保存返回的位置 after-fact
 fact-done)

(define (fib n)
  (if (< n 2)
      n
      (+ (fib (- n 1) (fib (- n 2)))))) 

(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)                           ; save old value of n
 (assign n (op -) (reg n) (const 1)); clobber n to n - 1
 (goto (label fib-loop))            ; perform recursive call
 afterfib-n-1                         ; upon return, val contains Fib(n - 1)
 (restore n)
 (restore continue)
 ;; set up to compute Fib(n - 2)
 (assign n (op -) (reg n) (const 2))
 (save continue)
 (assign continue (label afterfib-n-2))
 (save val)                         ; save Fib(n - 1)
 (goto (label fib-loop))
 afterfib-n-2                         ; upon return, val contains Fib(n - 2)
 (assign n (reg val))               ; n now contains Fib(n - 2)
 (restore val)                      ; val now contains Fib(n - 1)
 (restore continue)
 (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
         (op +) (reg val) (reg n)) 
 (goto (reg continue))              ; return to caller, answer is in val
 immediate-answer
 (assign val (reg n))               ; base case:  Fib(n) = n
 (goto (reg continue))
 fib-done)

(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 test-register (make-register 'test))
;; (get-contents test-register) ;; *unassigned*
;; (set-contents! test-register 10)
;; (get-contents test-register) ;; 10

(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 test-stack (make-stack))
;; (pop test-stack) ;;  Empty stack -- POP
;; (push test-stack 1)
;; (pop test-stack) ;;  1
;; (pop test-stack) ;;  Empty stack -- POP
;; (push test-stack 2) ;;
;; (test-stack 'initialize) ;; done
;; (pop test-stack) ;;  Empty stack -- POP

(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))) ;; 获得 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) ;; pc 寄存器指向指令列表
               (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 (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 (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 (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)
  (let ((val (assoc label-name labels)))
    (if val
        (cdr val)
        (error "Undefined label -- ASSEMBLE" label-name))))

;; 逐项检查指令表内容，提取其中的标号
;; text: 控制器代码
;; receive: 函数参数 
(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      ;; 递归处理控制器正文序列的 cdr
      (extract-labels (cdr text)
                      (lambda (insts labels)
                        (let ((next-inst (car text))) 
                          (if (symbol? next-inst) ;; 检查 car 是否是标号
                              (receive insts ;; 如果是标号，加入标号项
                                  (cons (make-label-entry next-inst
                                                          insts)
                                        labels))
                              (receive (cons (make-instruction next-inst)
                                             insts)  ;; 反之加入指令表项
                                  labels)))))))

;;; 原来每个位置只有指令正文，执行过程用空表占位，现在加入实际的执行过程
;;; insts: 指令表
;;; labels: 标号关联表
;;; machine: 机器模型
(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)))

;;; 生成一条指令的执行过程
;;; inst: 指令
;;; labels: 标号表
;;; machine: 机器模型
;;; pc: 指令寄存器
;;; flag: 标志寄存器
;;; stack: 栈
;;; ops: 操作表
(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 instruction type -- ASSEMBLE"
                     inst))))

(list (list 'initialize-stack
            (lambda () (stack 'initialize)))
      ;; 增加一个新的打印栈统计信息的操作
      (list 'print-stack-statistics
            (lambda () (stack 'print-statistics))))

(define (make-stack)
  (let ((s '())
        ;; 添加统计信息
        (number-pushes 0)
        (max-depth 0)
        (current-depth 0))
    (define (push x)
      (set! s (cons x s))
      (set! number-pushes (+ 1 number-pushes))
      (set! current-depth (+ 1 current-depth))
      (set! max-depth (max current-depth max-depth)))
    (define (pop)
      (if (null? s)
          (error "Empty stack -- POP")
          (let ((top (car s)))
            (set! s (cdr s))
            (set! current-depth (- current-depth 1))
            top)))    
    (define (initialize)
      (set! s '())
      (set! number-pushes 0)
      (set! max-depth 0)
      (set! current-depth 0)
      'done)
    ;; 打印统计信息
    (define (print-statistics)
      (newline)
      (display (list 'total-pushes  '= number-pushes
                     'maximum-depth '= max-depth)))
    (define (dispatch message)
      (cond ((eq? message 'push) push)
            ((eq? message 'pop) (pop))
            ((eq? message 'initialize) (initialize))
            ((eq? message 'print-statistics)
             (print-statistics))
            (else
             (error "Unknown request -- STACK" message))))
    dispatch))