完成 5.2.1 机器模型

2016-05/2015-05-12_subroutes.md

@@ -0,0 +1,29 @@
+## 子程序
+
+![](img/two_gcd.png)
+
+```
+gcd
+  (test (op =) (reg b) (cons 0))
+  (branch (label gcd-done))
+  (assign t (op rem) (reg a) (reg b))
+  (assign a (reg b))
+  (assign b (reg t))
+  (goto (label gcd))
+gcd-done
+  (goto (reg continue))
+  ...
+
+;; Before calling gcd, we assign to continue
+;; the label to which gcd should return.
+  (assgin continue (label after-gcd-1))
+  (goto (label gcd))
+after-gcd-1
+  ....
+
+ ;;  Here is the second call to gcd, with a different contiuation
+   (assign contiue (label after-gcd-2))
+   (goto (label gcd))
+after-gcd-2   
+
+```

2016-05/2016-05-09.md

@@ -40,3 +40,25 @@
     (goto (label test-b))
   gcd-done)
 ```
+
+## 动作（Action）
+
+- 一部读输入并打印结果的GCD机器
+```
+(controller
+  gcd-loop
+    (assign a (op read))
+    (assign b (op read))
+  test-b
+    (test (op =) (reg b) (const 0))
+    (branch (label gcd-loop))
+    (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)))
+```
+
+![](img/gcd.png)

2016-05/2016-05-16_recursion_stack.md

@@ -0,0 +1,45 @@
+```
+(define (factorial n)
+  (if (= n 1)
+    1
+    (* n (factorial (- n 1)))))
+
+(define (gcd a b)
+  (if (= b 0)
+    a
+    (gcd b (remainder a b))))    
+```
+- 这里的`factorial`过程与之前的`gcd`有一点重要的不同，`gcd`过程将原来的计算简化为一个新的GCD计算，而`factorial`则要求计算出另一个阶乘作为子问题。在`gcd`过程里，对于新的GCD计算的回答也就是原来问题的回答。为了计算下一个GCD，我们只需简单地将新的参数放进GCD机器的输入寄存器里，并通过执行同一个控制器序列，重新使用这个机器的数据通路。在机器完成了最后一个GCD问题的求解时，整个计算也就完成了。
+- 但是，在阶乘（以及其他任何递归的计算过程）的情况里，对于新的阶乘子问题的回答并不是对于愿问题的回答。
+- 每部阶乘机器里都需要包含另一部阶乘机器，完整的机器中要包含无穷嵌套的类似机器，这是不可能从固定的有限个部件构造起来的。
+- 然而，我们还是有可能将这一阶乘计算过程实现为一部寄存器机器，只要我们能够做出一种安排，设法使每个嵌套的机器实例都使用同样的一组部件。也就是说，计算`n!`的机器应该用同样部件去完成计算针对`(n-1)!`的子问题，并如此下去。这是可能的，因为虽然阶乘计算过程在执行中要求同一机器的无穷多个副本，但是在任何给定时刻，它所实际使用的知识这些副本中的一个。
+
+![](img/factorial.png)
+
+```
+(controller
+  (assign continue (label fact-done))
+fact-loop
+  (test (op =) (reg n) (const 1))
+  (branch (label base-case))
+  ;; Set up for the recursive call by saving n and continue.
+  ;; Set up continue so that the computation will continue at after-fact when the subroutine returns
+  (save continue)
+  (save n)
+  (assign n (op -) (reg n) (const 1))
+  (assign continue (label 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
+base-case
+  (assign val (const 1))                 ; base case: 1! = 1
+  (goto (reg continue))                  ; return to caller
+fact-done)
+```
+
+- 阶乘的这一具体实现展示了实现递归算法的通用策略：
+
+    > 采用一部常规的寄存器机器，再增加一个堆栈。在遇到递归子程序时，只要某些寄存器的值在子问题求解完成后还需要用，就把它们的当前值存入堆栈。而后去求解递归的子问题，再恢复保存起来的寄存器值，并继续执行原来的主程序。

exercises/05/5.4.scm

@@ -0,0 +1,45 @@
+; a)
+(define (expt b n)
+  (if (= n 0)
+    1
+    (* b (expt b (- n 1)))))
+
+(controller
+  (assign continue (label expt-done))
+expt-loop
+  (test (op =) (reg n) (const 0))
+  (branch base-case)
+  (save continue)
+  (save n)
+  (assign n (op -) (reg n) (const 1))
+  (assign continue (label after-expt))
+  (goto (label expt-loop))
+after-expt
+  (restore n)
+  (restore continue)
+  (assign val (op *) (reg n) (reg val))
+  (goto (reg continue))
+base-case
+  (assign val (const 1))
+  (goto (reg continue))
+expt-done)
+
+; b)
+
+(define (expt b n)
+  (define (expt-iter counter product)
+    (if (= counter 0)
+      product
+      (expt-iter (- counter 1) (* b counter))))
+  (expt-iter n 1))
+
+(controller
+  (assign continue (label expt-done))
+expt-loop
+  (test (op =) (reg counter) (const 0))
+  (branch expt-done)
+  (assign product (op *) (reg product) (reg counter))
+  (assign counter (op -) (reg counter) (const 1))
+  (goto (label expt-loop))
+expt-done
+  (assign val (reg product)))

exercises/05/lib/machine.scm

@@ -0,0 +1,112 @@
+(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 machine register-name)
+  ((machine 'get-register) register-name))
+
+(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 'operation) the-ops)
+          (else (error "Unknown request -- MACHINE" message))))
+      dispatch)))