SICP 106 - 寄存器机器里的计算
本章是 SICP 的最后一章，包含了必要的习题解答。首先使用 Scheme 实现了一个寄存器模拟器，然后手动把一些 Scheme 代码翻译成了汇编代码执行，之后用汇编代码写了一个直接控制的解释器，探讨了这个寄存器机器存储分配的方法并使用汇编代码实现了 LISP 经典的分半垃圾回收机制，最后我们使用 Scheme 代码写了一个编译器，使其可以自动将 Scheme 代码翻译为汇编代码。作为最终的结果，Scheme 代码可以编译执行（比如过程定义），也可以在解释器中解释执行（比如过程调用），这种方式充分利用了编译的性能和解释的开发调试灵活性。
我的目的是想说明，这一天空机器并不是一种天赐造物或者生命体，它只不过是钟表一类的机械装饰，在很大程度上，这里多种多样的运动都是由最简单的物质力量产生的，就像钟表里所有活动都是由一个发条产生的一样。—— 开普勒 1605。
对于魔法般的解释器而言，其落到实处也不过是寄存器机器里的数字逻辑计算（通过操纵一组固定称为寄存器的存储单元的内容，顺序执行指令完成计算，比如某条典型指令将一种基本操作（加法）应用于某几个寄存器并将结果赋值给另一个寄存器）。在这一章将探讨在上一章实现元解释器时遗留的问题，即 Lisp 系统的控制机制：子表达式的求值如何返回一个值给使用这个值的父表达式？为什么有些递归可产生递归型或迭代型计算？
寄存器机器的设计
一个寄存器机器的执行需要分别定义其数据通路 Data-Path（寄存器和其操作）和控制器 Controller（实现操作的顺序）。比如对于 GCD 而言，其数据通路和控制器如下所示：
GCD 程序的数据通路，其中矩形表示寄存器，圆形表示判断，三角形表示常量，梯形表示通过寄存器值执行的某种计算（抽象黑盒），m<-n 表示数据的流向操作，比如 a<-b 表示将 b 寄存器的值写入 a。为了将这些寄存器的操作组织起来，需要定义一定的顺序，这里从 = 判断开始，如果不满足依次执行将 a 和 b 寄存器值求 rem 并写入寄存器 t 的操作，将 b 寄存器值写入 a 的操作，将寄存器 t 的值写入 b 的操作，以及重复进行 = 判断的工作。
这些图示在表示像解释器这样的程序时并不方便，因此考虑使用一门语言记法，左图所示是这门语言对于 GCD 程序的描述，这里的数据通路包含寄存器名称及其动作的定义，控制器包含一串顺序的执行序列，其可以是 test 测试、条件分支跳转 branch，寄存器动作执行，无条件分支跳转 goto。这种描述语言类似于二进制表示，也不容易读，因此我们可以将数据通路整合到控制器中，通过一种类似汇编的语言来描述。 这门“汇编语言”将数据通路整合到了控制器中，不过省略了 op 名和 buttons 名的中转，buttons 动作直接表述（匿名λ），op 动作也直接表述（具名λ）。这种描述更加精炼，方便阅读，但是对于大型机器而言，这种描述太过于啰嗦，比如 test = 如果出现多次这里的 op = 定义就需要多次，此外这种方式也不利于看清到底有多少寄存器以及寄存器之间的连接关系。
(data-paths
(registers
((name n))
((name product)
(buttons ((name p<-t1 (source t1)))))
((name controller)
(buttons ((name c<-t2 (source t2)))))
((name t1)
(buttons ((name t1<-m (source (operation multiple))))))
((name t2)
(buttons ((name t2<-a (source (operation add)))))))
(operations
((name multiple)
(input (register product) (register controller)))
((name add)
(input (register controller) (constant 1)))
((name >)
(input (register controller) (register n)))))
(controller
test-controller
(test >)
(branch (label factorial-done))
(t1<-m)
(p<-t1)
(t1<-a)
(c<-t2)
(goto (label test-controller)
factorial-done))
(controller
test-controller
(test (op >) (reg controller) (reg n)))
(branch (label factorial-done))
(assign t1 (op multiple) (reg product) (reg controller))
(assign product (reg t1))
(assign t2 (op add) (reg controller) (const 1))
(assign controller (reg t2))
(goto (label test-controller))
factorial-done)
最后，图灵机是一种给定输入有输出的机器，因此这里我们为自定的寄存器机器语言提供一种叫做动作的指令，(perform (op print) (reg a)) 其将来自寄存器或常量的值打印出来。动作用梯形表示，代表一种黑盒抽象，动作的结果可以作为“按钮”写入到寄存器。因此一个完整的支持输入和打印的 GCD 的 REPL 机器如下所示（左图为将 rem 当做基本动作的寄存器机器表示，右图为将 rem 细化后的寄存器机器表示）：
下面是牛顿法计算平方根的数据通路和控制器语言描述：
(controller
(assign guess (const 1.0))
start
(assign t (op square) (reg guess))
(assign t (op -) (reg x) (reg t))
(assign t (op abs) (reg t))
(test (op <) (reg t) (const 0.001))
(branch (label end))
(assign t2 (op /) (reg x) (reg guess))
(assign guess (op average) (reg guess) (reg t2))
(goto (label start))
end)
目前为止，我们仅仅讨论了单个程序，如果某一个过程需要迭代，但是每次迭代都稍微有出入（大部分过程是复用的），比如 gcd-1 和 after-gcd-1 与 gcd-2 和 after-gcd-2，那么一种方式是为不同过程分配不同的寄存器计算，这显然不太现实，另一种方式是顺序复用同一组寄存器，如左下图所示，但考虑到这两组过程大部分指令都一样，因此我们可以将其相同的指令合并，为了进行区分，使用一个叫做 continue 的寄存器，让其存储指令序号（label 标签）然后在不同过程（gcd）后跳转到不同的位置：after-gcd-1/2 以执行不同的指令。这种方式其实就是寄存器机器用来支持函数的机制，每次跳转到代码区执行后通过 pointer 寄存器跳转回来，跳转到下一个函数前重新设置 pointer 寄存器到下一行，然后代码区执行完毕后就跳到 pointer 寄存器指向的下一个函数开头。
对于 gcd 这种每次迭代都一样的过程，上述机制可以满足需求（如果返回 a 则设置 continue 到 end-label，否则则设置 continue 为 gcd-loop，然后 goto (label continue)），但是像 factorial 之类的过程，其每次迭代的都是不同的子表达式，且这里的 n 每次迭代都不同，因此如果使用这里的技术，将丢失 n 的中间值。
为支持 factorial 的计算，我们需要为每一步迭代的 n 都进行保存，然后完成子过程计算后再进行恢复。这需要我们使用堆栈（后进先出）数据结构，这里我们使用 save 和 restore 指令来完成对于 n 的处理。这里仅仅对于 n 进行保存和恢复还不够，因为恢复后还需要完成 * n 的计算（fact-done），计算完毕后要弹回上一级继续弹出 n 依次类推直到保存 n 的堆栈为空，为了支持这种机制，还需要一个堆栈保存 continue 寄存器内容，以便每次弹回到上一层计算完 factorial 但还没 * n 的位置（after-fact）。
对于树形递归而言，这里的过程要更复杂一些，进入 fib 后在进入 fib (- n 1) 前要保存 n 和 continue，然后更改 continue 目标为 afterfib-n-1（以便下一次进入 fib (- n 1) 后能跳转回正确的父环境位置），然后 goto (label fib-loop) 后，一直递归到 if (< n 2) 返回 n 为止，此时再 goto (label fib-loop) 后，满足条件所以跳转到 immediate-answer 此时跳转到父环境 afterfib-n-1 位置，保存当前的 n 和 continue，设置下一次 fib-loop -> immediate-answer 跳转回的目标为 afterfib-n-2，即 fib (- n 2) 执行完毕，现在恢复 fib (- n 1) 的值，执行加法后，弹出 continue 的值，并去往此父环境（afterfib-n-1）位置，之后依次遍历 fib (- n 2) 以实现 fib (- n 1) 向上弹一次，直到 fib (- n 1) 返回到最上层的环境和框架得到结果为止。假如我们计算 fib 2，那么其经过的标签依次是：fib-loop[stack:(fib-done,2),continue:fib-1,n:1] -> fib-loop -> immediate-answer[val:1] -> fib-1[n:2,continue:fib-done,n:0,stack:(fib-done,1),continue:fib-2] -> fib-loop -> immediate-answer[val:0] -> fib-2[n:0,continue:fib-done,val:1,stack:(null,null)] -> fib-done(注意，afterfib-n-1 的 restore continue 和 save continue 指令是不必要的，可以删掉)。
总的来说，对于递归形式的过程，都是一样的步骤，比如纯 gcd 递归：开始设置 continue 为 end-label，之后每次将 continue 的值 save 到 stack 中，每次结束都 restore stack 到上一层，最终在最外层直接到 end-label。不过如果最后递归的还有额外运算，则还需要保存这里用到的值，比如 * n 的 gcd 递归，n 也要保存在 stack 中。此外，如果递归是树状的，即 gcd (- n 1), gcd (- n 2) 形式的，则还需要在 contiune save 和 restore 到 stack 前还处理好目标 continue 到的下一个 label 名。
下面是 expt 基于迭代和递归的不同实现的寄存器机器的数据和控制流程，可以看到迭代更接近人的思维方式，而递归则对机器更友好。
左图为迭代的 DataPath，其 Controller 代码如下所示，可以看到这里使用 stack 维护了 continue，实现较为复杂。
(controller
(save continue (label expt-done))
expt-loop
(test (op =) (reg n) (const 0))
(branch (label base-case))
(save continue)
(assign continue (label expt-after))
(assign n (op -) (reg n) (const 1))
(goto (label expt-loop))
expt-after
(restore continue)
(assign val (op *) (reg b) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
expt-done)
右图为递归的 DataPath，其 Controller 代码如下所示，可以看到这里没有借助于 stack，实现非常简单且高效。
(controller
(assign product 1)
(assign counter (reg n))
expt-loop
(test (op =) (reg counter) (const 0))
(goto (label expt-end))
(assign counter (op +) (reg counter) (const 1))
(assign product (op *) (reg product) (reg b))
expt-end)
总结而言，我们的控制器描述语言包含如下指令，其中 reg 后跟着寄存器名，const 后跟着一个常量，其可以是字符串：(const "abc") 也可以是符号 (const abc) 还可以是表 (const (a b c)) 或 (const ())。
寄存器机器的模拟
寄存器机器用例
下面给出了一个寄存器机器的模拟器，可以通过 make-machine，传入需要的寄存器、需要 Scheme 支持的基本过程映射，控制器代码，通过 set-register-contents! 设定寄存器值，然后 start 启动，之后即可从特定寄存器获取计算结果，下面是 gcd 的例子：
(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)
稍微复杂一些的使用递归实现的 exp 的例子（这个例子使用了一些调试命令，比如在开始时初始化堆栈 (op initialize-stack)，读取屏幕输入的 n 的值 (op read)，之后开始执行，当执行结束后打印堆栈状态 (op print-stack-satistics)，打印计算值）：
(define expt-machine
(make-machine
'(b n val continue)
(list (list '= =) (list '* *) (list '- -))
'(expt-start
(perform (op initialize-stack))
(perform (op printf) (const "\nInput n again >>\n"))
(assign n (op read))
(save continue (label expt-done))
expt-loop
(test (op =) (reg n) (const 0))
(branch (label base-case))
(save continue)
(assign continue (label expt-after))
(assign n (op -) (reg n) (const 1))
(goto (label expt-loop))
expt-after
(restore continue)
(assign val (op *) (reg b) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
expt-done
(perform (op printf) (const "\nResult is ~a\n") (reg val))
(perform (op print-stack-satistics))
(goto (label expt-start)))))
(set-register-contents! expt-machine 'b 4)
(set-register-contents! expt-machine 'n 3)
总的入口 make-machine
下面开始提供此 make-machine 过程，这里做的事就是委托 make-new-machine 提供的包含内部状态的消息传递风格的数据抽象以安装寄存器机器和 Scheme 过程的操作映射、分配计算所需的寄存器、安装寄存器指令序列（注意这里的指令并非文本，而是通过 assemble 过程进行了“编译”处理）。
;通过委托 make-new-machine 实例完成模拟器构建,其中 controller
;文本通过 assemble 过程翻译为指令。
(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))))
寄存器数据抽象
对于寄存器数据抽象而言，消息传递风格的写法维护了一个内部的表表示寄存器内容，支持 get 和 set 来读写此内容。
;寄存器实例,维护一个内部变量,可获取和写入
(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))
一种支持追踪寄存器的实现 make-register-with-track 如下所示，这里额外标记了是否开启追踪，如果开启，则在赋值时打印值的变化（需要配合 make-new-machine Ex5.18 标记的注释代码工作）：
;Ex5.18
(define (make-register-with-track name)
(let ((contents '*unassigned*)
(track #f))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set)
(lambda (value)
(if track (printf "[Reg]~a:~a->~a\n"
name contents value))
(set! contents value)))
((eq? message 'track-on) (set! track #t))
((eq? message 'track-off) (set! track #f))
(else (error "Unknown request --REGISTER" message))))
dispatch)) ;Ex5.18
此外是一些辅助过程，比如 start 调用模拟器 start 开始执行指令，get/set-register-contents 用来读写特定模拟器寄存器的值。
(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))
堆栈数据抽象
对于堆栈而言和寄存器数据抽象类似，其内部维护了一个表，可 push 和 pop，通过 initialize 进行初始化。
;堆栈实例,维护一个内部表,可 push 和 pop,initialize 将表清空
(define (make-stack)
(let ((s '()))
(define (push x) (set! s (cons x s)))
(define (pop) (if (null? s) (error "Empty stack -- POP" s)
(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))
一个支持统计堆栈状态的堆栈抽象如下所示，其包含了总共执行的命令、最大深度和当前深度，其需要配合下文 make-new-machine 中的 ;Ex5.14 代码运行。
;Ex5.14
(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" s)
(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)
(printf "\ntotal-pushes = ~d, maximum-depth = ~d\n"
number-pushes 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))
模拟器数据抽象
对于模拟器而言，make-new-machine 通过消息传递方式提供了支持，这里保存的内部状态有用于指向当前指令执行位置的 pc 寄存器，用于保存 test 判断结果的 flag 寄存器，以及一个堆栈 stack，程序“代码”序列 the-instruction-sequence。通过 make-machine 安装的 Scheme 操作映射将保存在 the-ops 表中，程序所需的寄存器保存在 register-table 中。出现在此部分的注释和标识为 Ex5.XX 的部分，都是 SICP 第五章对于此模拟器的功能增强，大部分参见上文和下文各个具体实现过程，特殊的比如 Ex5.15 的增强是用来提供一种对当前指令计数的跟踪支持，Ex5.16 对于指令追踪的支持（执行时打印指令文本）。
;make-new-machine 实现了模拟器,其中 pc 保存下一个执行的指令(每次执行
;指令都修改 pc 使其指向下一套需要执行的指令,大部分简单增加 pc 值,而
;比如 branch 和 goto 则直接指向特定值),flag 保存 test 指令结果,
;stack 保存堆栈信息,the-instruction-sequence 保存程序编译后的指令
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(trace #f) ;Ex5.16
;(stack-table '()) ;Ex5.11
;(extra (make-extra-info)) ;Ex5.12
;(exec-count 0) ;Ex5.15
(the-instruction-sequence '())) ;(make-machine 时安装)
(let ((register-table ;(make-machine 时安装)
(list (list 'pc pc) (list 'flag flag)))
(the-ops ;(make-machine 时安装)
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;(lambda () (map (lambda (reg-pair) ;Ex5.11
; ((assoc stack-table (car reg-pair)) 'initialize)
;) register-table))
(list 'print-stack-satistics ;Ex5.14
(lambda () (stack 'print-statistics)))
(list 'print-counting ;Ex5.15
(lambda () (printf "Count ~d\n" exec-count)))
(list 'reset-counting ;Ex5.15
(lambda () (set! exec-count 0)))
(list 'trace-on ;Ex5.16
(lambda ()
;Ex5.18
;(for-each (lambda (pair) ((cadr pair) 'trace-on)) register-table))
(set! trace #t)))
(list 'trace-off ;Ex5.16
(lambda ()
;Ex5.18
;(for-each (lambda (pair) ((cadr pair) 'trace-off)) register-table))
(set! trace #f)))
(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)))
;(let ((st (assoc stack-table name))) ;Ex5.11
; (if st ((assoc stack-table name) 'initialize)
; (set! stack-table (list (list name (make-stack)) stack-table))))
'register-allocated)
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val (cadr val) (error "Unknown register:" name))))
(define (execute)
;(set! exec-count (+ 1 exec-count)) ;Ex5.15
(let ((insts (get-contents pc)))
(if (null? insts) 'done
(begin ( ;Ex5.16
;(if trace (printf "\n~a\n" (instruction-text (car insts))))
(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)
;((eq? message 'extra-info) extra) ;Ex5.12
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
dispatch 暴露了一些可操作的接口，比如安装指令、分配寄存器，获取堆栈和操作映射，start 过程委托这里的 start 消息，通过设置 pc，调用 execute 对 pc 处指令进行逐行调用并执行。现在问题的核心是，如何从控制器文本得到编译后的指令呢，换言之，上述 make-machine 中的 assemble 过程如何实现呢？
assemble 的实现如下所示，其通过 extract-labels 来逐行处理控制器文本，并逐步构建 insts 指令表和 labels 标签表，这里 extract-labels 的实现很有 CPS 的风格。在收集完毕后，update-insts! 通过对每条指令 inst 应用 make-execution-procedure 后设置到了模拟器的 the-instruction-sequence 中，以方便执行代码。
;将控制器语言进行编译,extract-labels 用于根据此语言构造出指令表
;和标签表,update-insts! 用于
(define (assemble controller-text machine)
(extract-labels controller-text
(lambda (insts labels)
(update-insts! insts labels machine)
insts)))
;顺序扫描文本元素,第一个参数为语言文本,第二个参数为对指令和标签的处理方法。
;这里实际实现的时候是为每个文本元素进行递归调用(当前文本元素存储在 next-inst 中,
;剩余元素存储在 text 中,如果当前元素为符号,则就是标签,将其构造并调用 receive
;方法插入到标签表中,反之则插入到指令表中)在 text 最末尾开始构建这两张表,每次都
;通过 cons 进行表内容的扩充,直到最上层 receive 通过 update-insts! 将其写入了
;模拟器。(extract-labels 的 receive 是一种对结果的回调,其提供了处理多个返回值
;的优雅方法,另一种实现方式是不使用 receive 而是在 (extract-labels) 中直接使用
;(extract-labels (cdr text)) 并对其 car 和 cdr 获取 insts 和 labels 以构建 cons)
(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 "Duplicate label found -- EXTRACT-LABEL"
next-inst)
(receive insts
(cons (make-label-entry next-inst insts)
labels)))
(receive (cons (make-instruction next-inst) insts)
labels)))))))
;当收集完毕 insts 和 labels 后,通过 machine 暴露的 API 对其内部状态进行更改
;这里会为每个 inst 指令根据其文本来生成对应的操作,核心在于 make-execution-procedure
(define (update-insts! insts labels machine)
(let ((pc (get-register machine 'pc))
(flag (get-register machine 'flag))
(stack (machine 'stack))
(ops (machine 'operations)))
(define number 0)
(for-each
(lambda (inst)
(set-instruction-execution-proc!
inst
(make-execution-procedure
(instruction-text inst) labels machine
pc flag stack ops))
;(set-car! inst (cons number inst)) Ex5.17
;(set! number (+ number 1)) Ex.5.17
)
insts)))
这里 Ex5.17 注释的代码用来包含源代码行数信息，以便在调试打印源码时可以将其标号打印出来。
因此这里的“魔法”实际上发生在 “make-execution-procedure” 这个过程中，其通过操纵 pc、flag、stack、ops、labels 和 machine，将一条控制器指令翻译为模拟器可执行的“汇编代码”。这个过程和 eval 很类似，本质上就是一个根据控制器指令语法分情况讨论的过程。
首先先建立指令的数据抽象，其用在了上文的 make-new-machine 的 execute 和 assemble 的 update-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))
标签的数据抽象类似，包含标签名和其后的指令表，注意此指令表并不是标签下的，而是从标签到末尾，lookup-label 提供了从模拟器 labels 中查找特定标签的方法。
;标签体数据抽象,包含了标签名和其包含的指令表
(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))))
对于 make-execution-procedure 而言，这里根据赋值、测试、分支、强制分支、堆栈读写、指令和关机（自定义的一个指令）进行了分派。这里 Ex5.13 提供了一种延迟分配寄存器的方式，其更接近实际寄存器机器的执行情况。
;将每条指令根据上下文:labels, machine, pc, flag, stack, ops 翻译为可执行指令
(define (make-execution-procedure inst labels machine pc flag stack ops)
(cond ((eq? (car inst) 'assign)
;Ex5.13 allocate reg first need them(more like real machine)
;(let ((reg-name (cadr inst)))
; (if ((machine 'get-register) reg-name) #f
; ((machine 'allocate-register) reg-name)))
(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) 'halt)
(make-halt machine pc flag))
(else (error "Unknown instruction type -- ASSEMBLE" inst))))
在具体分派之前，下列过程抽取了一些数据抽象和基本过程，比如让 pc 下移一行，判断表达式是否为 operation，并选择此 operation 内容，是否为 label，并选择此 label 内容，是否为 register，并选择此 register 内容，是否为 constant 并选择常量值。
; move pc to next inst
(define (advance-pc pc) (set-contents! pc (cdr (get-contents pc))))
; exp is op?: (op xxx) (reg xxx) (const xxx)
(define (operation-exp? exp) (and (pair? exp) (tagged-list? (car exp) 'op)))
(define (operation-exp-op exp) (cadr (car exp)))
(define (operation-exp-operands exp) (cdr exp))
; exp is label?
(define (label-exp? exp) (tagged-list? exp 'label))
(define (label-exp-label exp) (cadr exp))
; exp is reg?
(define (register-exp? exp) (tagged-list? exp 'reg))
(define (register-exp-reg exp) (cadr exp))
; exp is const?
(define (constant-exp? exp) (tagged-list? exp 'const))
(define (constant-exp-value exp) (cadr exp))
对于赋值语句而言，分为简单赋值和复杂赋值，前者通过 make-primitive-exp 解析寄存器值，然后写入被赋值寄存器，后者通过 make-operation-exp，先获取操作对象的值（寄存器或常量），之后通过 ops 映射表找到 scheme 过程并进行 apply，注意这里最后返回的是一个 lambda，这里尚未进行调用，执行后要让 pc + 1。
;将赋值语句翻译为可执行命令
;eg. (assign t1 (op multiple) (reg product) (reg controller)) #make-op-exp
;(assign t1 (reg product)) #make-pri-exp
(define (make-assign inst machine labels operations pc)
(define (assign-reg-name ass-inst) (cadr ass-inst)) ;t1
(define (assign-value-exp ass-inst) (cddr ass-inst)) ;(op ..) (reg ..)
(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 ;apply scheme's proc
value-exp machine labels operations)
(make-primitive-exp ;reg or const's content
(car value-exp) machine labels))))
(lambda ()
;when execute by machine, call this lambda to
;eval value-proc and set assign target reg computed value
;and let pc go next inst
(set-contents! target (value-proc))
(advance-pc pc)))))
测试语句与之类似，应用 op 操作 apply 得到布尔值并更新 flag 寄存器的值。
;将测试语句翻译为可执行命令
;(test (op >) (reg controller) (reg n)))
(define (make-test inst machine labels operations flag pc)
(define (test-condition inst) (cdr inst)) ;(op >)
(let ((condition (test-condition inst)))
(if (operation-exp? condition) ;test need a op
(let ((condition-proc
(make-operation-exp ;apply scheme's proc
condition machine labels operations)))
(lambda () ;set flag reg the bool value, go next
(set-contents! flag (condition-proc))
(advance-pc pc)))
(error "Bad TEST instruction -- ASSEMBLE" inst))))
分支跳转和无条件跳转较为类似，分支跳转先找到 flag，根据结果选择静默 pc + 1 或者更新 pc 为目标标签的代码。无条件跳转对于标签获取标签代码设置 pc，对于寄存器获取寄存器内容设置 pc。
;将跳转分支翻译为可执行命令，找到 label 名下的代码，根据 flag 决定向 pc 写入指令
;还是直接到下一条指令
;(branch (label base-case))
(define (make-branch inst machine labels flag pc)
(define (branch-dest inst) (cadr inst)) ;(label base-case)
(let ((dest (branch-dest inst)))
(if (label-exp? dest)
(let ((insts (lookup-label labels (label-exp-label dest))))
(lambda () ;if flag is true, set pc insts or go next directly
(if (get-contents flag)
(set-contents! pc insts)
(advance-pc pc))))
(error "Bad BRANCH instruction -- ASSEMBLE" inst))))
;将无条件跳转语句翻译为可执行命令,可能跳转目标是 label 或 reg，如果是 label 则直接重写
;pc,如果是 reg，则获取此 reg 的值并重写 pc
;(goto (label base-case))
(define (make-goto inst machine labels pc)
(define (goto-dest inst) (cadr inst)) ;(label base-case)
(let ((dest (goto-dest inst)))
(cond ((label-exp? dest) ;fetch label insts and set pc insts
(let ((insts (lookup-label labels (label-exp-label dest))))
(lambda () (set-contents! pc insts))))
((register-exp? dest) ;fetch reg contents and set pc contents
(let ((reg (get-register machine (register-exp-reg dest))))
(lambda () (set-contents! pc (get-contents reg)))))
(else (error "Bad GOTO instruction -- ASSEMBLE" inst)))))
对于堆栈操作，这里使用的是不保存寄存器名称的单堆栈，save 进行堆栈 push，restore 进行堆栈 pop。
;将保存到堆栈语句翻译为可执行命令
;(save n)
(define (stack-inst-reg-name inst) (cadr inst)) ;n
(define (make-save inst machine stack pc)
(let ((reg (get-register machine (stack-inst-reg-name inst))))
(lambda () ;get reg content and push it to stack
(push stack (get-contents reg))
(advance-pc pc))))
;将从堆栈中恢复语句翻译为可执行命令
;(restore n)
(define (make-restore inst machine stack pc)
(let ((reg (get-register machine (stack-inst-reg-name inst))))
(lambda () ;pop stack to reg and go next
(set-contents! reg (pop stack))
(advance-pc pc))))
另一种堆栈的实现方案是将寄存器名和值都保存在堆栈，获取前检查名称，不匹配则报错。
;Ex5.11
;原始方式不检查 stack 值和 reg name 对应关系，因此对于 fib 机器而言，
;afterfib-n-2 的 (assign n (reg val)) (restore val) 可合并为 (restore n)
;而之后的 (assign val (op +) (reg val) (reg n)) 将不受影响。
;另外一种处理堆栈的方式，将寄存器名和寄存器值序对保存到堆栈，而非仅保存值
(define (make-save-way-2 inst machine stack pc)
(let ((reg (get-register machine (stack-inst-reg-name inst))))
(lambda ()
(push stack (cons (stack-inst-reg-name inst) (get-contents reg)))
(advance-pc pc))))
(define (make-restore-way-2 inst machine stack pc)
(let* ((reg-name (stack-inst-reg-name inst))
(reg (get-register machine reg-name))
(stack-return (pop stack)))
(lambda ()
(if (not (eq? (car stack-return) reg-name))
(error "stack poped reg is not " reg-name))
(set-contents! reg (cdr stack-return))
(advance-pc pc))))
第三种处理方式是选择在 make-new-machine 中实现 stack-table 而非 stack，为每个寄存器保存一个 stack（另一种方式是在 register 中保存单独的 stack 变量，但这打破了寄存器的含义）。
;Ex5.11
;另外一种堆栈的实现方案，每个寄存器保存一个单独堆栈，在 machine 中使用 stack-table 而非 stack
;当初始化时为每个寄存器都初始化其 stack 放入 stack-table 中(参见 make-new-machine 注释)
(define (make-save-way-3 inst machine stack pc)
(let ((reg (get-register machine (stack-inst-reg-name inst))))
(lambda ()
(push (assoc stack (stack-inst-reg-name inst)) (get-contents reg))
(advance-pc pc))))
(define (make-restore-way-3 inst machine stack pc)
(let ((reg-name (stack-inst-reg-name inst))
(reg (get-register machine reg-name)))
(lambda ()
(pop (assoc stack reg-name))
(set-contents! reg (cdr stack-return))
(advance-pc pc))))
最后是指令语句，这里直接 make-operation-exp 后直接执行了，为的就是副作用。
;将指令语句翻译为可执行命令
;(perform (op printf) (reg a))
(define (make-perform inst machine labels operations pc)
(define (perform-action inst) (cdr inst)) ;(op ..) (reg a)
(let ((action (perform-action inst)))
(if (operation-exp? action) ;apply scheme's proc and go next
(let ((action-proc (make-operation-exp
action machine labels operations)))
(lambda () (action-proc) (advance-pc pc)))
(error "Bad PERFORM instruction -- ASSEMBLE" inst))))
上述赋值、指令等语句依赖于两个过程：make-primitive-exp 和 make-operation-exp 如下所示：
;用于赋值语句中对基本赋值进行处理
;(assign t1 (reg product)) #make-pri-exp
;如果是值，则返回值，标签则返回其指令，寄存器则返回其内容
(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))))
;用于赋值语句中对复杂赋值进行处理
;(assign t1 (op multiple) (reg product) (reg controller)) #make-op-exp
;operation-exp op 在 operations 中有对应的 Scheme 过程，先找到它
;然后对于每个 operation-exp operands 都 make-primitive-exp 去获取其值
;(可能是 const、寄存器等），之后通过 apply 去应用它得到结果
(define (make-operation-exp exp machine labels operations)
;根据 operations 表查找符号对应的 Scheme 过程，比如 + (('- -) ('+ +))
(define (lookup-prim symbol operations)
(let ((val (assoc symbol operations)))
(if val (cadr val) (error "Unknown op -- ASSEMBLE" symbol))))
(let ((op (lookup-prim (operation-exp-op exp) operations))
(aprocs (map (lambda (e)
(if (label-exp? e) ;just allow reg and const
(error "label can not cast to prime value -- MAKE-OP-EXP" e)
(make-primitive-exp e machine labels)))
(operation-exp-operands exp))))
(lambda () (apply op (map (lambda (p) (p)) aprocs)))))
然后是一个 halt 指令扩展，模拟机器断电情况：
;reset pc、stack and flag value, no api to get all reg to clean
;(halt)
(define (make-halt machine pc flag)
(begin ((machine 'stack) 'initialize)
(set-contents! pc '*unassigned*)
(set-contents! flag '*unassigned*)))
（Ex5.12）寄存器模拟器的代码可能需要进行进一步的分析，因此可以在 assemble 编译的时候将每种情况收集起来，这里使用前几章的 make-table 抽象实现双层表：
;('*table* (key1 (keya record) (keyb record2)) (key2 (keya record3)))
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record (cdr record) #f))
#f)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
（Ex5.12）然后在 make-new-machine 中保存 extra 局部变量保存此表（参见注释），然后在 assemble 编译数据分派 make-execution-procedure 的时候将不同语句收集起来方便后续分析。这里保存的信息有：
;Ex5.12 extra info for machine code analysis
(define (make-extra-info)
(let ((data (make-table)))
(define get (data 'lookup-proc))
(define put (data 'insert-proc!))
;将 inst 分类插入到表中
(define (add-to-all inst) (put 'all (car inst) inst))
;将 goto inst 插入到 'goto 'goto 项的表中
(define (add-to-go-to inst)
(let ((old-list (get 'goto 'goto)))
(if old-list ;非第一次插入
(if (memq? old-list inst) #f ;存在相同
(put 'goto 'goto (cons inst old-list))) ;不存在相同
(put 'goto 'goto (list inst))))) ;第一次插入
;将 restored 和 saved 插入到 'stack 'stack 项的表中
(define (add-to-stack inst)
(let ((old-list (get 'stack 'stack)))
(if old-list
(if (memq? old-list inst) #f
(put 'stack 'stack (cons inst old-list)))
(put 'stack 'stack (list inst)))))
;将每个 reg 的赋值来源都放插入到 'reg '{reg-name} 项的表中
(define (add-to-reg-val-source reg-name inst)
(let ((old-list (get 'reg reg-name)))
(if old-list
(if (memq? old-list inst) #f
(put 'reg reg-name (cons inst old-list)))
(put 'reg reg-name (list inst)))))
(define (dispatch m)
(cond ((eq? m 'add-to-all) add-to-all)
((eq? m 'add-to-goto) add-to-go-to)
((eq? m 'add-to-stack) add-to-stack)
((eq? m 'add-to-reg-val-source) add-to-reg-val-source)))
dispatch))
;Ex5.12
(define (make-execution-procedure-with-extra inst labels machine pc flag stack ops)
(define extra (machine 'extra))
(define add-all (extra 'add-to-all))
(define add-go (extra 'add-to-goto))
(define add-stack (extra 'add-to-stack))
(define add-reg-val (extra 'add-to-reg-val-source))
(add-all inst)
(cond ((eq? (car inst) 'assign)
(add-reg-val (cadr inst) inst)
(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)
(add-go inst)
(make-goto inst machine labels pc))
((eq? (car inst) 'save)
(add-stack inst)
(make-save inst machine stack pc))
((eq? (car inst) 'restore)
(add-stack inst)
(make-restore inst machine stack pc))
((eq? (car inst) 'perform)
(make-perform inst machine labels ops pc))
((eq? (car inst) 'halt)
(make-halt machine pc flag))
(else (error "Unknown instruction type -- ASSEMBLE" inst))))
此外，这里实现的 make-machine 手动传入需要的寄存器，这并不是必须的，在 assemble 时首次遇到新寄存器名时再进行分配是更好的做法（也更接近真实情况），其代码参见 make-execution-procedure 注释部分（采用这种方法，就无须对 machine 'allocate-register 分配寄存器了）。
最后，我们可能给还想要为寄存器机器提供断点功能，可以在某行设置断点、之后执行到此行将会中断执行，可恢复机器执行动作，清除此端点和所有断点。一种简单的实现是维护一个断点管理器数据抽象，可将特定行数据保存在此管理器，可清除特定行、删除所有管理器端点。对于 make-new-machine 的 start 而言，如果开启调试时，每执行一条语句都查找当前语句是否为断点（放在 execute 执行当前命令后检查，这样的缺点是第一行不能打断点，但是优点是恢复时无需额外处理，直接继续 execute 即可，另一种处理方式是在 execute 前检查命令，恢复断点时额外的忽略当前行的断点以继续），如果是则执行完此条语句前打印当前代码、行数和堆栈以及统计信息，停止执行，通过 continue 来恢复执行过程。
.. same as make-new-machine
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts) 'done
(if ((break 'break?) (car (instruction-text insts))) #f
(begin ((instruction-execution-proc (car insts)))
(execute))))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
;((eq? message 'continue) (execute)) ;Ex5.19
.. same as make-new-machine
(define (make-breakpoint-manager)
(let ((lines '()) (ignore -1))
(define (remove lines item)
(if (null? lines) '()
(let ((head (car lines)))
(if (= head item)
(remove (cdr lines) item)
(cons (car lines) (remove (cdr lines) item))))))
(define (set-breakpoint n)
(if (memq n lines) #f (set! lines (cons n lines))))
(define (need-break? n)
(if (= ignore n) (begin (set! ignore -1) #f)
(memq n lines)))
(define (dispatch cmd)
(cond ((eq? cmd 'set) set-breakpoint)
((eq? cmd 'break?) need-break?)
((eq? cmd 'remove)
(lambda (n) (set! lines (remove lines n))))
((eq? cmd 'ignore-last) (set! ignore n))
((eq? cmd 'reset) (set! lines '()))))
dispatch)))
;一种简单的 breakpoint 实现：只支持单断点
(define (set-breakpoint machine n) (((machine 'break) 'set) n))
(define (proceed-machine machine)
((machine 'break) 'ignore-last) (machine 'continue))
(define (cancel-breakpoint machine n) (((machine 'break) 'remove) n))
(define (cancel-all-breakpoints machine) ((machine 'break) 'reset))
存储分配和垃圾收集
在上面两节中，我们介绍了如何把 LISP 过程手动翻译为寄存器机器指令，如何通过一个寄存器模拟器来执行寄存器机器指令。现在剩下的问题就是，如何将 LISP 过程自动翻译为寄存器机器指令（参见下一节“显示控制的求值器”）以及处理寄存器模拟器和实际物理寄存器机器间的差异 —— 实际机器的寄存器是有限的，不能按照寄存器模拟器中无限个寄存器这样来处理（寄存器可包含基本数字，但对于符号、各种基于表结构的数据抽象，寄存器可以包含对于内存指针的引用，而将实际内容存储在内存中），换言之 —— 存储分配和垃圾收集，维持一种无限的假象（存储分配和垃圾收集使得我们的寄存器机器模拟器更接近真实的物理机器）。
常规计算机的存储器（内存）可以看做若干个“小隔间序列”，其中每个小隔间都有其唯一名字（地址），可保存有限信息。机器可提供两个基本操作：取出特定位置数据，将新数据赋给指定位置。基于此可实现存储器地址的增量操作和顺序访问。
寄存器机器模拟器需要提供一个基于表的数据抽象以表示内存（为什么不是基于一个 C 数组的方式表示存储器是因为 LISP 各种数据结构和表的关系更密切，更容易实现映射），为此，我们引入两个 vector 向量用于保存表序对的 car 序列和 cdr 序列，vector 支持如下 API：(vector-ref <vector> <n>) (vector-set! <vector> <n> <value>) 可分别获取向量特定位置值、为特定位置设定值（地址算术计算偏移设定即可）。对于 LISP 数据结构（表）而言，比如 ((1 2) 3 4)，使用方块指针的表示如下所示，假设寄存器机器采用两个向量，那么其对应关系的一种实现方式如下图所示，这里 pX 表示指向 Index 为 X 的值，nX 表示数字 X，e0 表示空指针。这里对于实际值的表示有很多方法，一般会包括符号和数据，其中符号采用若干个比特位表示，如果数据可以放在一个小格子里（基本数据），那么就放下，如果放不下，比如符号，则通过指针指向一段连续的小格子。因为 eq? 是对指针进行比较，因此对于符号而言，系统每次读入符号都回去对象表 obarray 查找是否有现有实例，如果有将其指针返回，反之分配实例且将其指针返回，这保证所有看起来相同的符号指针都相同。
对于如下表达式而言，其表结构和盒子、指针表示如下所示：
因此，现在可以基于如下两个对向量操纵的 API 实现 car, cdr, set-car!, set-cdr! 以及 cons 和堆栈了。
(vector-ref vector n)
(vector-set! vector n value)
; reg 现在保存的是 vector 的 index
; car 和 cdr 的实现，从 the-cars/cdrs 获取 index 处的值
(assign reg1 (op car) (reg reg2))
(assign reg1 (op cdr) (reg reg2))
(assign reg1 (op vector-ref) (reg the-cars) (reg reg2))
(assign reg1 (op vector-ref) (reg the-cdrs) (reg reg2))
; set-car/cdr! 的实现，找到 reg1 index 并更新其 the-cars/cdrs 值
(assign reg1 (op set-car!) (reg reg2))
(assign reg1 (op set-cdr!) (reg reg2))
(perform (op vector-set!) (reg the-cars) (reg reg1) (reg reg2))
(perform (op vector-set!) (reg the-cdrs) (reg reg1) (reg reg2))
;cons 的实现，将这对值分别插入 the-cars 和 the-cdrs 新位置并返回其 index
(assign reg1 (op cons) (reg reg2) (reg reg3))
(perform (op vector-set!) (reg the-cars) (reg free) (reg reg2))
(perform (op vector-set!) (reg the-cdrs) (reg free) (reg reg3))
(assign reg1 (reg free))
(assign free (op +) (reg free) (const 1))
; 堆栈的实现：使用 the-stack 寄存器执行 cons 命令即可
(save <reg>)
(assign the-stack (op cons) (reg <reg>) (reg the-stack))
(perform (op initialize-stack))
(assign the-stack (const ()))
下面是 count-leave 递归（不带计数器，树状递归）的 LISP 过程以及使用了这里寄存器 car、cdr 支持（存储分配）的汇编代码：
(controller
(assign back-to (label count-end))
count-start ;1 2
(test (op null?) (reg tree))
(branch (label count-null))
(assign res (op pair?) (reg tree))
(test (op not) (reg res))
(branch (label count-not-pair))
;set up to (count-leave (car tree))
(save back-to)
(assign back-to (label count-back-after-1))
(save tree)
(assign (reg tree) (op car) (reg tree))
(goto (label count-start))
count-back-after-1 ;4
(restore tree)
(restore back-to)
;set up to (count-leave (cdr tree))
(save back-to)
(assign back-to (label count-back-after-2))
(save val)
(assign (reg tree) (op cdr) (reg tree))
(goto (label count-start))
count-back-after-2 ;5
(assign val2 val)
(restore val)
(restore back-to)
(assign val (op +) (reg val) (reg val2))
(goto (reg back-to))
count-null ;3
(assign val (const 0))
(goto (reg back-to))
count-not-pair ;3
(assign val (const 1))
(goto (reg back-to))
count-end)
带有显式计数器的递归的 count-leaves LISP 过程和汇编代码：
(controller
(assign back-to (label count-end))
(assign n (const 0))
count-start ;1 2
(test (op null?) (reg tree))
(branch (label count-null))
(assign res (op pair?) (reg tree))
(test (op not) (reg res))
(branch (label count-not-pair))
;set up to (count-iter (car tree) n)
(save back-to)
(assign back-to (label count-back-inner))
(save tree)
(assign (reg tree) (op car) (reg tree))
(goto (label count-start))
count-back-inner ;3
(restore tree)
(restore back-to)
;set up to (count-iter (cdr tree) ...)
(assign (reg tree) (op cdr) (reg tree))
(goto (label count-start))
count-null ;4
(goto (reg back-to))
count-not-pair ;4
(assign n (op +) (reg n) (const 1))
(goto (reg back-to))
count-end)
基于基本的寄存器机器表操作，可以实现 append 和 append! 支持：
(define (append list1 list2)
(if (null? list1) list2
(cons (car list1) (append (cdr list1) list2))))
(controller
(assign continue (label append-end))
append-start
(test (op null?) (reg list1))
(branch (label return-b))
(save list1)
(save continue)
(assign continue (label back-to-cons))
(assign list1 (op cdr) (reg list1))
(goto (label append-start))
back-to-cons
(restore continue)
(restore list1)
(assign list1 (op car) (reg list1))
(assign val (op cons) (reg list1) (reg val))
(goto (reg continue))
return-b
(assign val (reg list2))
(goto (reg continue))
append-end)
(define (append! list1 list2)
(if (null? (cdr list1)) (set-cdr! list1 list2)
(append! (cdr list1) list2)))
(controller
append!-start
(assign list-temp (op cdr) (reg list1))
(test (op null?) (reg list-temp))
(branch (label return-it))
(assign list1 (reg list-temp))
(goto (label append!-start))
return-it
(assign list1 (op set-cdr!) (reg list1) (reg list2))
append!-end)
因为计算机内存不是无限大的，因此势必要考虑上述表结构的垃圾回收问题，这里使用最经典的分半法垃圾回收策略（垃圾回收本来就是 LISP 提出的），假设有一个称之为 root 的寄存器包含一个指向内存结构的指针，用于访问所有数据。将此内存结构分为两半，一半使用，另一半不使用，当前一半用尽（free 到达末尾），将 free 和 scan 指向另一半的开头，将 root 所指的序对重新分配到新位置并更新 root 指针，递增 free 指针，在原序对 car 标记其已经移走（破碎的心），在 cdr 标记其新的位置。scan 用于从根部开始处理所有可达性对象的移动，其开始指向重分配的根，但是根的 car 和 cdr 仍然指向老存储区对象，移动 scan 并重分配这样的对象：检查其是否移走（car 是否为破碎的心标记），如果没有移走，则将其复制到 free 所指的位置，更新 free，在老位置设置破碎的心标志和指向新位置的指针，且更新当前 scan 的 car 的指针（如果不采用这种方式，每次移动一个对象，将遍历之前工作区所有对象修改其指针指向新位置，效率较差），如果已经被移走，则利用其 cdr 中指向新位置的指针替换正在被扫描的序对的指针，直到所有可访问对象都完成了移动和扫描，此时 scan 指针将超过 free 指针，这一过程就结束了。每次一半内存结束，都循环往复这个过程就可以以维持无穷内存的假象。
这一表述的寄存器机器语言实现如下所示，重置指针，分配 ROOT，然后从根部开始扫描（根节点遍历可达性），如果没有遇到破碎的心标记，则将其数据移动到新位置并设置旧位置为破碎的心，如果遇到破碎的心，则表示其已经移动，找到移动后的新位置并继续，一直遍历可达性直到结束，然后翻转新旧存储区，垃圾回收结束。
(begin-garbage-collection ;开始垃圾回收，设置状态
(assign free (const 0))
(assign scan (const 0))
(assign old (reg root))
(assign relocate-continue (label reassign-root))
(goto (label relocate-old-result-in-new))
reassign-root ;回收开始，将 root 重新指向新位置
(assign root (reg new))
(goto (label gc-loop))
gc-loop ;判断是否可以切到另一半存储，不可以的话
;则为下一个序对 car 重新分配（将其放入 old），并保证返回后继续处理
(test (op =) (reg scan) (reg free))
(branch (label gc-flip))
(assign old (op vector-ref) (reg new-cars) (reg scan))
(assign relocate-continue (label update-car))
(goto (label relocate-old-result-in-new))
update-car ;更新 scan 处的 car 并准备更新 scan 处的 cdr
(perform (op vector-set!) (reg new-cars) (reg scan) (reg new))
(assign old (op vector-ref) (reg new-cdrs) (reg scan))
(assign relocate-contiune (label update-cdr))
(goto (label relocate-old-result-in-new))
update-cdr ;更新 scan 处的 cdr 并且将 scan 递增，继续下一个
(perform (op vector-set!) (reg new-cdrs) (reg scan) (reg new))
(assign scan (op +) (reg scan) (const 1))
(goto (label gc-loop))
relocate-old-result-in-new
(test (op pointer-to-pair?) (reg old))
(branch (label pair))
(assign new (reg old)) ;指向一个基本类型的数（不在旧内存中），不做修改
(goto (reg relocate-continue))
pair
(assign oldcr (op vetor-ref) (reg the-cars) (reg old))
(test (op broken-heart?) (reg oldcr))
(branch (label already-moved))
(assign new (reg free)) ;如果没有移动，则将 new 设置为 free
(assign free (op +) (reg free) (const 1)) ;递增 free
;设置 new 的 car 和 cdr 指向原来的值
(perform (op vector-set!) (reg new-cars) (reg new) (reg oldcr))
(assign oldcr (op vector-ref) (reg the-cdrs) (reg old))
(perform (op vector-set!) (reg new-cdrs) (reg new) (reg oldcr))
;在旧位置的 car 处增加破碎的心标记, cdr 指向新位置
(perform (op vector-set!)
(reg the-cars) (reg old) (const broken-heart))
(perform (op vector-set!) (reg the-cdrs) (reg old) (reg new))
(goto (reg relocate-continue))
already-moved
;如果已经移动，找到 cdr 指向的新位置，继续下一个
(assign new (op vector-ref) (reg the-cdrs) (reg old))
(goto (reg relocate-continue))
gc-flip
;将 the-cdrs 指向 new-cdrs，将 new-cdrs 变为 the-cdrs
;将 the-cars 指向 new-cars，将 new-cars 变为 the-cars
(assign temp (reg the-cdrs))
(assign the-cdrs (reg new-cdrs))
(assign new-cdrs (reg temp))
(assign temp (reg the-cars))
(assign the-cars (reg new-cars))
(assign new-cars (reg temp)))
显式控制的求值器
下面的代码提供了一个显式控制的求值器，其中包含一个堆栈和七个寄存器，这里的代码可以通过 make-machine 装载（需要额外将这里使用到的命令重映射为元循环求值器的对应过程，比如操作环境框架的过程，表达式的选择过程等），其从用户输入读取 LISP 表达式并进行求值，不过和之前的元循环求值器不同，这里的代码直接被解释为寄存器机器指令执行。 ;一个堆栈，七个寄存器 ;exp 表达式 ;env 环境 ;val 特定环境下求值表达式的结果 ;continue 支持递归 ;proc 用于求值组合式 ;argl 用于求值组合式 ;unev 用于求值组合式 首先是 event-loop 事件循环，读入和输出的命令，如果出错，这里会跳转到 signal-error 打印错误并回到事件循环。
(read-eval-print-loop
(perform (op initialize-stack)) ;如果出错，堆栈可能不为空
(perform (op prompt-for-input) (const ">> input:"))
(assign exp (op read))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (label eval-dispatch))
print-result
(perform (op print-stack-satistics)) ;for perform monitor
(perform (op announce-output) (const ">> value:"))
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
unknown-expression-type ;未指定表达式错误
(assign val (const unknown-expression-type-error))
(goto (label signal-error))
unknown-procedure-type ;未指定过程错误
(restore continue)
(assign val (const unknown-procedure-type-error))
(goto (label signal-error))
signal-error ;打印 val 的值并回到事件循环
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
eval 依旧是一个分情况讨论的过程，和元循环求值器类似。
eval-dispatch ;分情况讨论
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op appplication?) (reg exp))
(branch (label ev-appplication))
(goto (label unknown-expression-type))
自求值、变量、引号、lambda 都很简单，直接设置 val 寄存器、在 env 查找变量并设置 val 寄存器，去除引号并设置到 val 寄存器，将 lambda 参数和体构造为过程结构并设置到 val 寄存器。
ev-self-eval ;自求值直接设置 val reg
(assign val (reg exp))
(goto (reg continue))
ev-variable ;变量的话在 env 中进行查找并设置 val reg
(assign val (op lookup-variable-value) (reg exp) (reg env))
(goto (reg continue))
ev-quoted ;引号去除引号并返回
(assign val (op text-of-quotation) (reg exp))
ev-lambda
;lambda 表达式分别获取参数和体，然后和环境一起构造过程并写入 val reg
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure) (reg unev) (reg exp) (reg env))
(goto (reg continue))
对于过程应用而言，先处理运算符，然后逐个处理运算对象，这里涉及很多层 goto 跳转，以及堆栈数据的保存和加载。
ev-appplication ;为应用某个过程，需要将 operator 写入 exp
;并调用 eval-dispatch，之后返回处理 operands
(save continue)
(save env) ;返回后对于 operands 求值
(assign unev (op operands) (reg exp))
(save unev) ;保存 operands 信息
(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator))
; operator 求值后到 ev-appl-did-operator 中处理 operands
(goto (label eval-dispatch))
ev-appl-did-operator ;恢复 operands 和环境
;之后将 operator 求的值保存在 proc 中，检查 operands 是否
;为空，如果为空，则直接 apply-dispatch 反之将 operator 入栈
;对于参数开始求值循环
(restore unev)
(restore env)
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
ev-appl-operand-loop ;开始对于 operands 的逐个处理
;先保存当前列表，然后从 operands 中取出一个 operand，
;如果这是最后一个，那么进入 ev-appl-last-arg 反之则
;保存 env 和 operands 信息，设置锚点 ev-appl-accu-arg
;后对此运算对象进行计算
(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg))
(goto (label eval-dispatch))
ev-appl-accumulate-arg ;处理完此 operand 后，恢复剩下的 operands
;表达式，环境 env 和已计算的 operands，对已计算的 operands -
;argl 进行 append，将此表达式移除出剩下的 operands - unev，
;然后继续处理下一个 operand
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop))
ev-appl-last-arg ;对最后一个参数而言，现在无需保存
;环境和未求值表 - unev 了，这里设置重新返回的锚点为
;ev-appl-accum-last-arg 其执行完毕后直接 apply
(assign continue (label ev-appl-accum-last-arg))
(goto (label eval-dispatch))
ev-appl-accum-last-arg
(restore argl) ;已计算的 operands
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc) ;operator
(goto (label apply-dispatch))
eval 最终会通过 apply 进行应用，这里也是分情况讨论，对于基本过程让 Scheme 处理，对于复杂过程进行扩充环境，对过程体进行逐行求值，返回最后一行结果。注意这里使用了尾递归优化。
apply-dispatch ;基本过程和复杂过程进行分派
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(goto (label unknown-procedure-type))
primitive-apply ;应用基本过程
(assign val (op apply-primitive-procedure)
(reg proc) (reg argl))
(restore continue) ;返回到锚点
(goto (reg continue))
compound-apply ;应用复杂过程
;从 operator 中获取 env，然后配合 operands 形参 unev 和实际值 argl
;扩充环境，重写 env，然后对 body 进行 ev-seq 逐行求值
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
ev-begin ;对于 begin 的求值，将被求值的表达式序列放在 unev 中，
;将 continue 保存在堆栈中，跳到 ev-seq
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
ev-sequence ;从需要求值的表达式序列中取出第一个写入 exp
(assign exp (op first-exp) (reg unev))
;如果是最后一个 exp，则进入 ev-seq-last-exp
;反之保存剩余表达式，当前环境，设置锚点返回 ev-seq-cont
;然后进行 eval-dispatch
(test (op last-exp?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (lambel ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue ;恢复 env 和剩余 exp，继续下一个 exp 求值
(restore env)
(restore unev)
(assign unev (op rest-exps) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp ;如果是最后一个 exp，不再保存 env，直接
;eval-dispatch 求值即返回整个 seq 结果
(restore continue)
;这里的实现支持了尾递归，直接 goto eval-dispatch 而非
;goto (reg continue)，后者会无用的 restore、save 才返回
;eg. (define (count n) (printf "~d\n" n) (count (+ n 1)))
;如果没有尾递归优化，将耗尽堆栈空间
(goto (label eval-dispatch))
对于 if 而言，先判断谓词，之后进入不同分支，执行不同动作。对于 cond 而言，一种方式是派生为 cond->if 再处理，另一种是直接转换为寄存器模拟器机器指令执行：
ev-if ;因为要对谓词判断，因此判断之前保存 exp,env
;锚点，并设置判断 if-predicate 后返回的锚点
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide ;谓词判断后，恢复 env,exp,cont,
;如果谓词为真，则进入 ev-if-consequent 中
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
ev-if-alternative ;执行 alternative 语句，直接返回
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent ;执行 consequent 语句，直接返回
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
; ev-cond ;Ex5.23
; (assign exp (op cond->if) (reg exp))
; (goto ev-if)
; ev-let ;Ex5.23
; (assign exp (op let->lambda) (reg exp))
; (goto (label ev-lambda))
; Ex5.24 (cond ((= 1 2) 3 4) ((= 4 5) 6 7) (else 8 9))
; ev-cond
; (save exp)
; (save env)
; (save unev)
; (save continue)
; ;note. cond-body return ((cond-1-pre) (cond-1-seq)) ..
; (assign unev (op cond-body) (reg exp))
; ;note. is-last-cond return whether this pair is last
; (test (op is-last-cond) unev)
; (branch (label ev-cond-last))
; (assign continue (label ev-cond-check))
; (assign exp (op car) (reg unev))
; (goto (label eval-dispatch))
; ev-cond-check ;根据当前分支谓词情况分派
; (restore continue)
; (restore unev)
; (restore env)
; (restore exp)
; (test (op true?) (reg val))
; (branch (label ev-cond-go))
; (assign unev (op cdr) (reg unev))
; (goto (ev-cond))
; ev-cond-go ;执行中间分支
; (assign exp (op cdr) (reg exp))
; (save continue (label ev-cond))
; (goto (label eval-sequence))
; ev-cond-last ;执行最后分支
; (assign exp (op cdr) (reg exp))
; (goto (label eval-sequence))
对于赋值和定义而言，找到变量名，计算表达式的值，调用 set-variable-value! 或 define-variable! 将值更新/写入环境框架。
ev-assignment ;赋值语句，找到变量和表达式，保存变量名，环境和
;当前锚点后，对于表达式进行 dispatch 后返回 ev-ass-1 完成最终赋值。
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1 ;对变量 unev 和值 val 在 env 下赋值
;之后继续执行之前的锚点
(restore continue)
(restore env)
(restore unev)
(perform (op set-variable-value!)
(reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition ;定义和赋值类似，对值进行 dispatch eval
;在此之前保存变量名、环境和锚点，之后恢复并执行赋值
;然后从锚点继续
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform (op define-variable!)
(reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
)
编译
我们在上一节已经看到了如何将 LISP 程序构造为由寄存器模拟器指令组成的特定程序机器，也看到了如何抹平寄存器模拟器和实际物理寄存器机器的差异，通过内存分配和垃圾回收以维持一种无穷的假象。得益于在上一章学习的“元循环求值器知识”，我们使用寄存器模拟器指令实现了一个通用 LISP 程序机器（将源语言的基本过程用机器语言写出，作为其程序库，之后将源程序使用数据结构表示，解释器遍历此数据结构，通过库的基本子程序模拟源程序所要求的行为），使得我们可以基于此“求值器”抽象屏蔽寄存器机器的细节，提高语言的表达力和生产力。但执行 LISP 代码的方式不仅限于解释，在这一节，我们将介绍一种称之为编译的方式，其将 LISP 程序直接映射为寄存器机器指令，并且直接由寄存器机器执行。解释和编译各有优缺点，解释可以保留源码，可以在排错的过程中构造新程序并随时将其加入系统，而编译的效率则更高（每次遇到表达式，解释器都要进行分类工作，比如过程应用，而编译器对于表达式的分析仅一次，之后指令序列就固化了，另一方面，因为编译器的目标不在于给表达式求值，所以可以进行全局性的优化，避免不必要的堆栈操作、寄存器读写、直接访问特定框架而非执行 lookup-variable-value 搜索），现代 LISP 通常采用互补的方式，对已经排除错误的程序部分进行编译，而还在进行交互式开发和排错的部分执行解释。
下面的代码摘录自解释器章节，用来对谓词进行判断：
(define (self-evaluating? exp) ;2, "Hello World"
(cond ((number? exp) #t) ((string? exp) #t) (else #f)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp) (tagged-list? exp 'quote)) ;(quote xxx)
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) #f))
(define (assignment? exp) (tagged-list? exp 'set!)) ;(set! a 233)
(define (assignment-variable exp) (cadr exp)) ;a
(define (assignment-value exp) (caddr exp)) ;233
(define (definition? exp) (tagged-list? exp 'define))
;(define <var> <value>) or (define (<var> <pa>) <body>)
;(define <var> (lambda (<pa>) <body>)) same as the first condition
(define (definition-variable exp) ;<var>
;(printf "[define-var] called\n")
(if (symbol? (cadr exp)) (cadr exp) (caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp)) (caddr exp) ;<value>
(make-lambda (cdadr exp) (cddr exp)))) ;<pa>.. <body>..
(define (lambda? exp) (tagged-list? exp 'lambda)) ;(lambda (x y) a b)
(define (lambda-parameters exp) (cadr exp)) ;x y
(define (lambda-body exp) (cddr exp)) ;a b
(define (make-lambda parameters body) (cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if)) ;(if (<pre>) <a> <b> )
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp) (if (not (null? (cdddr exp))) (cadddr exp) '#f))
(define (make-if pre conse alt) (list 'if pre conse alt))
(define (begin? exp) (tagged-list? exp 'begin)) ;(begin (xxx) (yyy))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (make-begin seq) (cons 'begin seq))
(define (sequence->exp seq) ;sequence to exp, sometime (begin xxx)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (application? exp) (pair? exp)) ;(operator operands...)
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (cond? exp) (tagged-list? exp 'cond)) ;(cond (???))
(define (cond-clauses exp) (cdr exp)) ;(pred action..): (a b) or (else g)
(define (cond-else-clause? clause) (eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond-spec-form? clause) (eq? (cadr clause) '=>)) ;(<pre> => <act>)
(define (cond-spec-form-actions clause) (caddr clause)) ;<act>
(define (cond->if exp)
(define (expand-clauses clauses)
(if (null? clauses) '#f
(let ((first (car clauses)) (rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "else clause isn't last -- COND->IF" clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
(expand-clauses (cond-clauses exp)))
(define (let? exp) (tagged-list? exp 'let))
;(let ((a 2) (b 3)) x y) -> ((lambda (a b) x y) 2 3)
(define (let->lambda exp)
(let ((var-pairs (cadr exp)) (body-exps (cddr exp)))
(cons (make-lambda (map car var-pairs) body-exps)
(map cadr var-pairs))))
;(let name ((a 2) (b 3)) x y (name a b)) ->
;((lambda () (define (name a b) x y (name a b)) (name 2 3)))
(define (make-define-lambda name vars body calls)
(list (list 'lambda '()
(cons 'define (cons (cons name vars) body))
(cons name calls))))
(define (let->comp-lambda exp)
(let ((name (cadr exp))
(var-smb (map car (caddr exp)))
(var-exp (map cadr (caddr exp)))
(body (cdddr exp)))
(make-define-lambda name var-smb body var-exp)))
(define (let->combination exp)
(if (and (symbol? (cadr exp)) (pair? (caddr exp)))
(let->comp-lambda exp) (let->lambda exp)))
;(let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z))
;(let ((x 3)) (let ((y (+ x 2))) (let ((z (+ x y 5))) (* x z))))
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*->nested-lets exp)
(define (make-let var-pairs body-exp)
(list 'let var-pairs body-exp))
(define (nested-lets var-pairs body-seq)
(if (null? var-pairs) (sequence->exp body-seq)
(make-let (list (car var-pairs))
(nested-lets (cdr var-pairs) body-seq))))
(nested-lets (cadr exp) (cddr exp)))
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (letrec-inits exp) (cadr exp))
(define (letrec-body exp) (cddr exp))
(define (letrec->let exp)
(cons 'let (cons (map (lambda (pair) (list (car pair) '*unassigned*))
(letrec-inits exp))
(append (map (lambda (pair)
(list 'set!
(car pair)
(cadr pair)))
(letrec-inits exp))
(letrec-body exp)))))
(define (callable? exp) (tagged-list? exp 'call)) ;(call + 1 2)
(define (while? exp) (tagged-list? exp 'while))
(define (while->lambda exp)
(let ((pre (cadr exp)) (body (cddr exp)))
(let ((new-body (append body (list (make-if pre (list 'fun) #t)))))
(make-define-lambda 'fun '() new-body '()))))
这个编译器的核心在于 compile 过程，这是一个分情况讨论的函数。target 表示将计算结果放入哪个寄存器，linkage 为如何处理接下来的动作，有三种情况 next 继续下一条指令，return 从堆栈返回（goto (reg continue))，特定标号则跳转到特定标号去。
(define (compile exp target linkage)
;target 指的是表达式值保存的位置，linkage 指的是表达式编译结果代码
;在自身执行之后如何继续下去:
;next - 继续下一条指令 (什么也不生成)
;return - 从被编译过程返回 (生成 goto (reg continue))，
;特定标号 - 跳到一个命名的入口点 (生成 goto (label xxx))。
(cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp) (compile-variable exp target linkage))
((assignment? exp) (compile-assignment exp target linkage))
((definition? exp) (compile-definition exp target linkage))
((if? exp) (compile-if exp target linkage))
((lambda? exp) (compile-lambda exp target linkage))
((begin? exp) (compile-sequence (begin-actions exp)
target linkage))
((cond? exp) (compile (cond->if exp) target linkage))
;这里存在继续优化的空间，对于 + - * / 等基本指令，可以不通过 application?
;对 operator、operands 进行 apply-prim-proc 处理，可以直接 (op +) (reg a) (reg b)
;但是指令只能处理二元运算，所以要依次处理两个：对于每一次处理而言
;先对前两个 operands 进行 compile 后，放在 argl 中并拆成 val1 和 val,
;然后编译为 assign val op val1 val，op 的计算不需要 env，此外，如果基本指令
;不作为 operator，比如 (handle + 1 2 3) (op 1 2 3) 那么处理这个 + 时，
;还是要将其看做一个 variable-lookup(汇编代码不能把 + 在数据和动作间变换)
;这就导致了这里的 op + 必须被看做一个 variable-lookup，换言之，基本指令只能在字面表达式
;的时候被有效编译进行汇编代码优化。
((application? exp) (compile-application exp target linkage))
(else (error "Unknown expression type -- COMPILE" exp))))
每条编译的表达式都依赖一些寄存器，或读或写，make-inst-sequence 提供了一种抽象结构，用于表示表达式编译后的汇编指令和其依赖的 RW 寄存器。提供两个 API：append-instruction-sequence 直接将代码拼接，preserving 则小心处理两串汇编指令，以保证前者对寄存器的写入不影响后者（在其前后防止 save 和 restore）为了简化其过程实现，额外提供一个寄存器列表表示指令在这些寄存器有彼此影响：
;将两个指令序列简单的顺序放置
;(append-instruction-sequences <seq1> <seq2>)
;将两个指令序列顺序放置，并根据 seq1 中是否使用了某个寄存器为其包围
;save 和 restore 指令，以让 seq2 不受影响
;(preserving (list <reg1> <reg2>) <seq1> <seq2>)
;每一个指令序列都包含三个部分：需要的寄存器(RW)，修改的寄存器(W)，指令s
(define (make-instruction-sequence needs modifies statements)
(list needs modifies statements))
(define (empty-instruction-sequence) (make-instruction-sequence '() '() '()))
;(make-instruction-sequence '(env continue) '(val)
; '((assign val (op look) (const x) (reg env))
; (goto (reg continue))))
;(make-instruction-sequence '() '() '())
寄存器的使用是编译的难点，不同形式可使用不同寄存器以优化代码效率，在之前的手写汇编程序时，我们用 env 表示对表达式的求值韩静，proc 表示对运算操作的存储，argl 用于依次对运算对象进行求值和累计，比如下面四个表达式，其可以在某些汇编过程省略不同的寄存器以提高效率：
;reg env use to eval exp
;reg proc use to call application operator
;reg argl use to call each application's operatnd
;(f 'x 'y) ×argl ×proc ×env
;((f) 'x 'y) ×argl ×proc ×env((f) don't need env, 'x and 'y don't need env)
;(f (g 'x) y) √argl √proc ×env(operator f don't need env)
;(f (g 'x) 'y) √argl √proc ×env(operator and operands's env, 'y do't need env)
比如当操作对象是一个符号（而非 exp）时，可以优化 env 和 unev 的使用（在显示控制的求值器实现中）：
; a way to optimized stack usage(env and unev) if operator is a symbol
#| ev-application
(save continue)
(assign unev (op operands) (reg exp))
(assign exp (op operator) (reg exp))
(test (op symbol?) (reg exp)) ;; is the operator is symbol?
(branch (label ev-appl-operator-symbol))
(save env)
(save unev)
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-operator-symbol
(assign continue (label ev-appl-did-operator-no-restore))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
ev-appl-did-operator-no-restore
(assign argl (op empty-arglist))
(assign proc (reg val)) ; the operator
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc) |#
根据 linkage 种类不同，提供 end-with-linkage 过程用于将编译后的 inst-seq 和 linkage 代码进行拼装：
;为不同 linkage 方式生成 instruction-sequence
(define (compile-linkage linkage)
(cond ((eq? linkage 'return)
(make-instruction-sequence '(continue) '()
'((goto (reg continue)))))
((eq? linkage 'next) (empty-instruction-sequence))
(else (make-instruction-sequence '() '()
`((goto (label ,linkage)))))))
;将某个 instruction-sequence 和特定 linkage 方式指令进行组合
(define (end-with-linkage linkage instruction-sequence)
;(printf "DEBUG ~a ~a\n" linkage instruction-sequence)
(preserving '(continue) instruction-sequence
(compile-linkage linkage)))
对于自求值表达式和 quoted 表达式，对应为 target 赋值的 assign 语句，变量表达式则对应查找操作后赋值。
;自求值表达式编译，直接为 target 赋值，,target 的写法用于计算再构造 list
;在 Chez Scheme 中，其需要搭配 ` 而非 ' 使用
(define (compile-self-evaluating exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`(assign ,target (const ,exp)))))
;标号表达式编译，去除 quote 后设置到 target 中
(define (compile-quoted exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`((assign ,target (const ,(text-of-quotation exp)))))))
;变量编译，执行汇编查找动作并赋值给 target
(define (compile-variable exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op lookup-variable-value)
(const ,exp) (reg env))))))
对于赋值语句和定义语句而言，先对值进行编译，然后将其和赋值/定义动作串联起来，注意这里对于寄存器的使用，获取值的 linkage 是 next，写入值的 inst-seq 需要读取 env 和 val（值保存位置），需要写入 target 寄存器，串联动作的 env 需要保存和恢复。
;赋值编译，先生成查找值的汇编代码，然后将其拼接到调用 set-variable-value!
;的汇编代码上，因为产生变量值可能修改 env，因此这里需要保留。
(define (compile-assignment exp target linkage)
(let ((var (assignment-variable exp))
(get-value-code (compile (assignment-value exp) 'val 'next)))
(end-with-linkage linkage
(preserving '(env) get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op set-variable-value!)
(const ,var) (reg val) (reg env))
(assign ,target (const ok))))))))
;定义编译，类似于赋值编译，注意 get-value-code 直接将结果保存到了 val 中供
; define-variable! 定义时使用
(define (compile-definition exp target linkage)
(let ((var (definition-variable exp))
(get-value-code (compile (definition-value exp) 'val 'next)))
(end-with-linkage linkage
(preserving '(env) get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op define-variable!)
(const ,var)
(reg val) (reg env))
(assign ,target (const ok))))))))
对于 if 表达式而言，需要对谓词、两个分支都进行编译，然后进行组合，这里的组合使用了特殊的 parallel-inst-sequences，见下文。
;if 表达式的编译
;<compiled-pre>
;(test (op false?) (reg val))
;(branch (label false-branch))
;true-branch
;<compiled-true>
;false-branch
;<compiled-false>
;after-if
(define (compile-if exp target linkage)
;这里不使用这三个原始标号的原因是可能存在 if 嵌套
(let ((t-branch (make-label 'true-branch))
(f-branch (make-label 'false-branch))
(after-if (make-label 'after-if)))
(let ((consequent-linkage ;如果下一步是 next 则跳到if末尾
(if (eq? linkage 'next) after-if linkage)))
;谓词编译将结果写入 val，consequent 编译并处理下一步，alternative
;编译并处理下一步（下一步本来就是 after-if 无需额外处理）
(let ((p-code (compile (if-predicate exp) 'val 'next))
(c-code (compile (if-consequent exp) target consequent-linkage))
(a-code (compile (if-alternative exp) target linkage)))
(preserving '(env continue) ;env 是因为真假分支可能需要
;continue 是因为分支的连接代码可能需要
p-code ;consequent 和 alternative 互不干扰
(append-instruction-sequences
(make-instruction-sequence '(val) '()
`((test (op false?) (reg val))
(branch (label ,f-branch))))
(parallel-instruction-sequences
(append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code))
after-if))))))
对于序列而言，对每一个表达式进行编译并组合：
;对于序列（begin or 过程体）的编译就是对每个表达式分别编译并且将其组合起来
;如果是最后一步，则额外处理连接问题，反之使用 next 即可
(define (compile-sequence seq target linkage)
(if (last-exp? seq)
(compile (first-exp seq) target linkage)
(preserving '(env continue)
(compile (first-exp seq) target 'next)
(compile-sequence (rest-exps seq) target linkage))))
对于 lambda 而言，其本质是一个过程对象的构造（环境和标签）和赋值操作，不过这里为了方便，将过程体也进行编译并放在其后面，因为这二者互不影响，因此使用 tack-on-inst-sequence 进行组合，参见下文。对于过程体的编译先提供标号，然后扩充环境，对过程体每一个表达式进行编译。
;对于 lambda 而言，顺便生成其过程体的代码
;<构造过程对象>
;<连接> or (goto (label after-lambda))
;<过程体>
;after-lambda
(define (compile-lambda exp target linkage)
(let ((proc-entry (make-label 'entry))
(after-lambda (make-label 'after-lambda)))
(let ((lambda-linkage
(if (eq? linkage 'next) after-lambda linkage)))
(append-instruction-sequences
(tack-on-instruction-sequence
;用于将 lambda-body 拼接到 lambda 赋值指令后
(end-with-linkage lambda-linkage
(make-instruction-sequence
'(env) (list target)
`((assign ,target ;构造过程对象(标号+环境)并赋值
(op make-compiled-procedure)
(label ,proc-entry)
(reg env)))))
(compile-lambda-body exp proc-entry))
after-lambda))))
;对过程体进行编译，首先获取形参，然后在一个标签：proc-entry 后
;更新并扩展环境，最后生成过程体
(define (compile-lambda-body exp proc-entry)
(let ((formals (lambda-parameters exp)))
(append-instruction-sequences
(make-instruction-sequence '(env proc argl) '(env)
`(,proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment)
(const ,formals)
(reg argl)
(reg env))))
(compile-sequence (lambda-body exp) 'val 'return))))
; add for register machine baisc ops:
; (define (make-compiled-procedure entry env)
; (list 'compiled-procedure entry env))
; (define (compiled-procedure? proc)
; (tagged-list? proc 'compiled-procedure))
; (define (compiled-procedure-entry c-proc) (cadr c-proc))
; (define (compiled-procedure-env c-proc) (caddr c-proc))
组合式的编译是这个编译器最难实现的部分，其需要先对运算对象编译，然后通过 construct-arglist 进行整合到 argl 中，然后通过 compile-proc-call 生成实际调用过程（过程应用）。
;组合式的编译，包含三部分：运算符编译结果保存在 proc 中，linkage 为 next
;求值运算对象并构造实际参数表放在 argl 中，用给定目标和连接编译过程调用结果
(define (compile-application exp target linkage)
(let ((proc-code (compile (operator exp) 'proc 'next))
(operand-codes (map (lambda (operand) (compile operand 'val 'next))
(operands exp))))
(preserving '(env continue)
proc-code
(preserving '(proc continue)
(construct-arglist operand-codes)
(compile-procedure-call target linkage)))))
;将编译好的每个运算对象合并起来放到 argl 中
(define (construct-arglist operand-codes)
;这里是从右到左求值的（类似于 Chez Scheme），如果想要反向
;那么不 reverse，argl 合并的时候使用 append 而非 list 进行
(let ((operand-codes (reverse operand-codes))) ;从最后一个开始处理
(if (null? operand-codes)
;如果没有参数，则为 argl 赋值为空列表
(make-instruction-sequence '() '(argl)
'((assign argl (const ()))))
(let ((code-to-get-last-arg
(append-instruction-sequences
(car operand-codes)
;从尾部开始，依次获取一个运算对象结果，将其放到 val 中
;将 argl 已有运算对象结果和 val 合并
(make-instruction-sequence '(val) '(argl)
'((assign argl (op list) (reg val)))))))
(if (null? (cdr operand-codes))
code-to-get-last-arg ;如果没有剩下的（到第一个），直接返回
;如果有，则递归对所有运算对象进行合并
(preserving '(env) code-to-get-last-arg
(code-to-get-rest-args (cdr operand-codes))))))))
;递归处理剩下的 arg 并生成编译代码
(define (code-to-get-rest-args operand-codes)
(let ((code-for-next-arg
(preserving '(argl) (car operand-codes)
(make-instruction-sequence '(val argl) '(argl)
'((assign argl (op cons) (reg val) (reg argl)))))))
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving '(env) code-for-next-arg
(code-to-get-rest-args (cdr operand-codes))))))
过程应用是一个根据基本和复杂过程进行分类讨论的过程，如果是基本过程，应用 apply-prim-proc 动作，对于复杂过程，调用 compile-proc-appl 进行处理。
;过程应用：
;(test (op primitive-procedure?) (reg proc))
;(branch (label primitive-branch))
;compiled-branch
;<code>
;primitive-branch
;(assign <target> (op apply-primitive-procedure)
; (reg proc) (reg argl))
;<linkage>
;after-call
(define (compile-procedure-call target linkage)
(let ((primitive-branch (make-label 'primitive-branch))
(compiled-branch (make-label 'compiled-branch))
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
;如果是基本过程，则跳到对应 label，反之继续执行
(make-instruction-sequence '(proc) '()
`((test (op primitive-procedure?) (reg proc))
(branch (label ,primitive-branch))))
(parallel-instruction-sequences
;对复杂过程和简单过程分别编译，如果是基本过程，则
;调用 apply-pri-pro 指令并将结果写入 target reg
(append-instruction-sequences
compiled-branch
(compile-proc-appl target compiled-linkage))
(append-instruction-sequences
primitive-branch
(end-with-linkage linkage
(make-instruction-sequence '(proc argl) (list target)
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl)))))))
after-call))))
compile-proc-appl 对复杂过程进行了编译，这里进行了尾递归优化，详情参加下文注释，本质就是跳到对应编号位置执行并继续 linkage。
;过程调用的实际编译过程
;[a]如果连接的是一个标号 <target> 则过程调用看上去是：
;(assign continue (label proc-return)) 保存返回位置
;(assign val (op compiled-procedure-entry) (reg proc))
;(goto (reg val)) 跳转到过程体
;proc-return 返回后写入 target 并去 linkage
;(assign <target> (reg val))
;(goto (label <linkage>))
;[b]如果连接的是 return 则需要先对 continue 进行保存：
;(save continue)
;(assign continue (label proc-return)) 保存返回位置
;(assign val (op compiled-procedure-entry) (reg proc))
;(goto (reg val)) 跳转到过程体
;proc-return 返回后写入 target 并去 linkage
;(assign <target> (reg val))
;(restore continue)
;(goto (reg continue))
;[c]实际上，如果连接的是标号 <target> 那么可以直接这样写：
;(assign continue (label <linkage>))
;(assign val (op compiled-procedure-entry) (reg proc))
;(goto (reg val))
;[d]如果连接的是 return，那么可以直接这样写(continue 中保存着所需地址)
;这种写法可以让我们实现尾递归，对于 C 系语言，堆栈不仅保存了返回值还保存了
;实参和局部变量以避免垃圾收集（我们的实现实参和变量都位于可废料收集的存储区内）：
;但其缺点在于尾递归难以实现（一些复杂的 LISP 编译器可堆栈保存实参不破坏尾递归）
;(assign val (op compiled-procedure-entry) (reg proc))
;(goto (reg val))
(define (compile-proc-appl target linkage)
(cond ((and (eq? target 'val) (not (eq? linkage 'return))) ;[c]
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,linkage))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val)))))
;一般情况下目标都是 val，除非将求值运算符的目标定在 proc
((and (not (eq? target 'val)) (not (eq? linkage 'return)));[a]
(let ((proc-return (make-label 'proc-return)))
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,proc-return))
(assign val (op compiled-procedure-entry) (reg proc))
(goto reg val)
,proc-return
(assign ,target (reg val))
(goto (label ,linkage))))))
((and (eq? target 'val) (eq? linkage 'return)) ;[d]
(make-instruction-sequence '(proc continue) all-regs
'((assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val)))))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE" target))))
下面提供了一些辅助函数，用于实现 inst-sequence 的合并：
(define all-regs '(env proc val argl continue))
;(make-instruction-sequence '(env continue) '(val)
; '((assign val (op look) (const x) (reg env))
; (goto (reg continue))))
(define (registers-needed s) (if (symbol? s) '() (car s)))
(define (registers-modified s) (if (symbol? s) '() (cadr s)))
(define (statements s) (if (symbol? s) (list s) (caddr s)))
(define (needs-registers? seq reg) (memq reg (registers-needed seq)))
(define (modifies-registers? seq reg) (memq reg (registers-modified seq)))
(define (list-union s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (list-union (cdr s1) s2))
(else (cons (car s1) (list-union (cdr s1) s2)))))
(define (list-difference s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (list-difference (cdr s1) s2))
(else (cons (car s1) (list-difference (cdr s1) s2)))))
;将多条 inst-seq 组合到一个 inst-seq
(define (append-instruction-sequences . seqs)
;将两条 inst-seq 组合为一个 inst-seq
;将seq1 R-reg和seq2 R-reg & seq1 W-reg 的合并为总共 R
;将seq1 W 的和seq2 W的合并为总共 W 的
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(list-difference (registers-needed seq2)
(registers-modified seq1)))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs)
(empty-instruction-sequence)
(append-2-sequences (car seqs) (append-seq-list (cdr seqs)))))
(printf "APPEND ~a\n" seqs)
(append-seq-list seqs))
;将两条 inst-seq 组合到一个 inst-seq，且处理其中依赖的 regs 关系
(define (preserving regs seq1 seq2)
;(printf "DEBUG-PRE ~a ~a ~a\n" regs seq1 seq2)
(if (null? regs) (append-instruction-sequences seq1 seq2)
;从第一个依赖的 reg 开始，如果它在 seq1 被修改且 seq2 需要
;则为 seq1 进行变换，在其前保存此 reg，在其后恢复此 reg
;注意现在此 reg 不再被 Write(because restore)
;要从新指令的 modified 中删除
;且此 reg 现在被 Read(for save)，要添加到新的 needed 列表
(let ((first-reg (car regs)))
(if (and (needs-registers? seq2 first-reg)
(modifies-registers? seq1 first-reg))
(preserving (cdr regs)
(make-instruction-sequence
(list-union (list first-reg)
(registers-needed seq1))
(list-difference (registers-modified seq1)
(list first-reg))
(append `((save ,first-reg))
(statements seq1)
`((restore ,first-reg))))
seq2)
(preserving (cdr regs) seq1 seq2)))))
;用于 compile-lambda 中将过程和 body 序列拼接，body 不作为组合序列的一部分
;因此无需其所 RW 的寄存器集合。
(define (tack-on-instruction-sequence seq body-seq)
(make-instruction-sequence
(registers-needed seq)
(registers-modified seq)
(append (statements seq) (statements body-seq))))
;用于 compile-if 和 compile-procedure-call 两个分支的拼接
;这里组合起来的 R W 寄存器只需要取并集，不用担心 seq1 对 seq2 的影响
(define (parallel-instruction-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(registers-needed seq2))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
和解释器遇到的问题一样，这里生成的标签需要唯一，以避免嵌套导致的问题，使用一个全局变量实现标签生成：
(define label-counter 0)
(define (new-label-number)
(set! label-counter (+ 1 label-counter)) label-counter)
(define (make-label name)
(string->symbol
(string-append (symbol->string name) (number->string (new-label-number)))))
最后，可以尝试对一些基本 LISP 过程进行编译，可以看到递归、迭代、有无尾递归优化、有无 preserving 对堆栈的优化（对不需要的寄存器不 save 和 reload，对 C 之类的语言而言，堆栈保存了返回值和局部变量、形参，这导致递归的代价要变得更高，因此其不得不提供了 for 等循环语句，而 LISP 的递归实现并没有处理局部变量、形参，因此递归实现就非常自然、优雅和高效，且完全必须要 for 循环语句）。
;(trace compile)
(display (compile
'(define (factorial n)
(if (= n 1) 1 (* (factorial (- n 1)) n)))
'val
'next))
(pretty-print (compile
'(define (factorial-alt n)
(if (= n 1) 1 (* n (factorial-alt (- n 1)))))
'val
'next))
注意我们这个编译器在查找变量时的低效，比如下面的表达式，这里的 let 和 lambda 都是词法作用域，最内部的 x 需要跨越两层框架到最外层找到 3。如果我们可以提供一种方法，使得在查找每个变量时都能够告知寄存器机器查找它所在的框架位置，那么效率将会提高很多。比如下图右图
下面是寄存器机器动作：查找实参环境 index 获取值、为实参环境特定 index 写入值。
; FOR REGISTER MACHINE -- 实参数据，通过 index 查找和写入
;a simple impl for lexical-address, lookup and set action depends on a good env.
;address 本质是堆栈和堆栈偏移指针，env 本质是形参列表的列表
(define (lexical-address addr-frame addr-offset) (cons addr-frame addr-offset))
(define (addr-frame address) (car address))
(define (addr-offset address) (cdr address))
(define (lexical-address-lookup env address)
(let* ((frame (list-ref env (addr-frame address)))
(value (list-ref (frame-values frame) (addr-offset address))))
(if (eq? value '*unassigned*)
(error "the variable is unassigned -- LEXICAL-ADDRESS-LOOKUP" address)))
value)
(define (lexical-address-set! env address value)
(let ((frame (addr-frame address)) (offset (addr-frame address)))
(define (set-value! f pos)
(if (= f 0) (set-car! f value)
(set-value! (cdr f (- pos 1)))))
(set-value! frame offset value)))
在 lambda body 的编译过程中，形参环境轨迹被保留了下来。
;词法作用域环境生成，保存形参轨迹
(define (compile-lambda-body-with-env exp proc-entry ct-env)
(let ((formals (lambda-parameters exp)))
(append-instruction-sequences
(make-instruction-sequence '(env proc argl) '(env)
`(,proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment)
(const ,formals)
(reg argl)
(reg env))))
;(compile-sequence (scanout-defines (lambda-body exp))
; 'val 'return)))) ;See Ex4.16
(compile-sequence (lambda-body exp) 'val 'return
(cons formals ct-env)))))
下面是编译器使用的查找特定形参所在位置的方法，其被用在编译变量、赋值语句中生成寄存器机器指令以在特定索引位置进行查找或写入。
; FOR COMPILER MACHINE -- 根据形参数据找到特定 variable 的 index
;(find-variable 'c '((y z) (a b c d e) (x y))) => (1,2)
(define (find-variable variable frames)
(define (var-in-frame var items count)
(cond ((null? items) #f)
((eq? var (car items)) count)
(else (var-in-frame var (cdr items) (+ count 1)))))
(define (search-frame frames frame-index)
(if (null? frames) 'not-found
(let ((offset (var-in-frame variable (car frames) 0)))
(if offset (cons frame-index offset)
(search-frame (cdr frames) (+ frame-index 1))))))
(search-frame frames 0))
;词法作用域内根据环境轨迹查找，如果找不到退回到全局查找，反之执行词法作用域查找
(define (compile-variable-with-env exp target linkage ct-env)
(let ((var-index (find-variable exp ct-env)))
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
,(if (eq? var-index 'not-found)
'(op lookup-variable-value)
'(op lexical-address-lookup))
(const ,(if (eq? var-index 'not-found)
exp var-index))
(reg env)))))))
;词法作用域根据环境轨迹赋值，以便 compile-variable-with-env 进行查找
(define (compile-assignment-with-env exp target linkage ct-env)
(let ((var (assignment-variable exp))
(get-value-code
(compile (assignment-value exp) 'val 'next ct-env)))
(let* ((var-index (find-variable var ct-env))
(var-found (not (eq? var-index 'not-found))))
(end-with-linkage linkage
(preserving '(env) get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform ,(if var-found
'(op lexical-address-set!)
'(op set-variable-value!))
(const ,(if var-found var-index var))
(reg val) (reg env))
(assign ,target (const ok)))))))))
因为我们的寄存器机器是模拟器，因此实参环境和形参环境本质是同一个数据结构：在编译时，先在 lambda body 编译时生成形参占位符表，在赋值和查找变量编译时通过此形参占位符表信息生成对应操作特定位置变量读写的指令。当编译好之后的实际寄存器模拟器执行过程中，现在的 env 就是填充好了形参的 env，赋值动作将形参替换为实参，在查找时对此数据结构获取特定位置的值，因为总是先赋值后查找，所以这里总能获取到实参（为了避免获取到形参的问题，可以在执行前为此环境结构每一个对象替换为 unassigned）。
下面是一种能够实现自动扩充的数据结构插入和查找的实现：
;env is running environment, like (<stackNow> <prevStack> .. <firstStack>)
;each stack (list 'var-frame 1 2 3 4), address like (cons 1 2)
(define (lexical-address-lookup address env)
(define (index env count) (if (= count 0) (car env) (index (cdr env) (- count 1))))
(cond ((or (not (pair? address))
(not (number? (car address)))
(not (number? (cdr address))))
(error "lexical-address-lookup invalid addr" address))
((null? env)
(error "lexical-address-lookup not found variable in" address))
((= (car address) 0)
(let ((var (index (cdar env) (cdr address))))
(if (eq? var '*unassigned*)
(error "lexical-address-lookup unassigned val" address)
var)))
(else (lexical-address-lookup (cons (- (car address) 1) (cdr address))
(cdr env)))))
(define (lexical-address-set! address val env)
(define (index env count) (if (= count 0) (car env) (index (cdr env) (- count 1))))
(define (rebuild-line line index)
(if (null? line) (set! line '(*unassigned*)))
(cond ((= index 0) (cons val (cdr line)))
(else (cons (car line) (rebuild-line (cdr line) (- index 1))))))
(if (null? (cdr env)) (set-cdr! env (cons (list 'var-frame) '())))
(cond ((or (not (pair? address))
(not (number? (car address)))
(not (number? (cdr address))))
(error "lexical-address-set invalid addr" address))
((= (car address) 0)
(set-cdr! (car env) (rebuild-line (cdar env) (cdr address))))
(else (lexical-address-set! (cons (- (car address) 1) (cdr address))
val (cdr env)))))
(define (empty-env) '((var-frame)))
最后，为了打造一个基于解释器和编译代码的 REPL，可以这样做：先将指令进行编译并写入 val 寄存器，设置全局环境并启动直接控制的解释器，这时会执行编译代码，之后进入 REPL 循环，我们可以输入对解释代码对应过程的调用，解释性的查看其过程结果输出以及堆栈统计信息，相比较直接对此直接控制的解释器输入过程定义并求值，基于预先编译的求值能够大量节省压栈操作，降低堆栈深度，提高程序性能。
下面这张图展示了 SICP 1-5 章，尤其是第五章各个小节的关系，黄色为 Scheme 代码，蓝色为汇编代码。一开始我们使用 Scheme 实现了寄存器模拟器（Ch5.1），然后手动把一些 Scheme 代码翻译成了汇编代码执行（Ch5.2，Ch5.3），之后用汇编代码写了一个直接控制的解释器（Ch5.4），最后使用 Scheme 代码写了一个编译器（Ch5.5），使其可以自动将 Scheme 代码翻译为汇编代码，作为最终的结果，Scheme 代码可以编译执行（比如过程定义），也可以在解释器中解释执行（比如过程调用），这种方式充分利用了编译的性能和解释的开发调试灵活性。
最后，让我们对解释和编译的区别作为本书的结尾。解释器将所用的机器提升到用户层面，而编译器则将用户程序降低到机器语言的层面，正是因为这一根本性的差异，导致了解释器可以方便的交互开发和排错，因为程序执行的各个步骤都是按照程序员熟悉的抽象方式进行组织的。编译后的代码执行的更快，是因为程序执行在机器语言层面，编译器可以自由的进行各种跨越高层抽象的优化（另一个比喻：解释器问太多问题，而编译器编译后的代码不会，因为解释器处于一个高层抽象，其必须孤立的将机器指令对应到一个表达式上，因为缺失上下文而不得不需要辅助信息，而编译器处于一个底层抽象，其有整个程序运行的蓝图，信息丰富，因此可以进行各种语句、堆栈和寄存器优化且不需要问太多问题）。一种将这两者结合起来的方法是对库代码使用编译而对需要排错的代码使用解释。在 JVM 上，我们也看到了解释和编译相结合的很好的例子：来自高层的 Java, Kotlin, Scala, Clojure 等代码被编译（前端）为字节码，字节码通过解释为机器代码以及对热点字节码编译为机器代码结合的方式，为 JVM 应用开发提供了方便易用的 Debug 体验、热加载替换、性能监控、安全能力，同时保证了程序性能。
; Java/Scala/Kotlin/Clojure ---> Byte Code ---> Machine Code
; Compile Interrupt to Machine Code
; or
; Hotspot Compile to Machine Code