P423是IUB一门关于编译器构造的课程. 和C311一样, 历史都比较悠久了. 当然, 课程的内容是不断更新的, 比如说现在的P423课程会使用一本叫做Essentials of Compilation的书. 但是, 我这里的笔记是针对曾经的Kent Dybvig还在IUB时上的P423课程的作业材料的探究.
我最初是在2020年初的时候开始阅读这些作业材料, 大概花了一段时间我才搞明白整个作业的结构. 最终, 我决定倒着完成这些作业. 不过, 实际上我只完成了作业的后半部分. 前半部分里我遇到了一些困难, 最终导致我没能完成所有的作业. 当初写的代码已经全被我删除了, 这是我的坏习惯. 不过, 至少我还记得一些东西. 现在, 我决定复习一下之前完成的作业, 并试着真正写完一个从Scheme到x86的优化编译器.
nanopass编译器框架实际上不是必要的, 只需要一个最简单的模式匹配宏也足够完成P423作业了. 当然了, nanopass提供了比较fancy的机制, 例如catamorphism, 这真的很方便, 但是没有的话也不是不能写编译器就是了.
我决定和上次一样, 仍然使用C311课程里的那个模式匹配宏, 据说这是Oleg Kiselyov写的, 我做了一点修改.
(define-syntax match
(syntax-rules (guard)
((_ v) (error 'match "~s" v))
((_ v (pat (guard g ...) e ...) cs ...)
(let ((fk (lambda () (match v cs ...))))
(ppat v pat (if (and g ...) (let () e ...) (fk)) (fk))))
((_ v (pat e ...) cs ...)
(let ((fk (lambda () (match v cs ...))))
(ppat v pat (let () e ...) (fk))))))
(define-syntax ppat
(syntax-rules (unquote)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (unquote var) kt kf) (let ((var v)) kt))
((_ v (x . y) kt kf)
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(ppat vx x (ppat vy y kt kf) kf))
kf))
((_ v lit kt kf) (if (eqv? v (quote lit)) kt kf))))我印象中, 后半部分最令我捉摸不透的地方实际上是purify-letrec, 我到现在还是没能理解letrec和letrec*的语义, 而且似乎顶层程序的语义也值得好好琢磨. 闭包变换也多花了我一段时间, 因为实际上网上没法找到那次作业的pdf文件. 但是, 我的确可以猜出来大致上要做什么, 而且在某个上过P423课程的人写的作业里, 我找到了比较详尽的描述, 所以没有耗费我太多精力. 实际上, 闭包变换在概念上是比较简单的. 至于是不是有人故意删除了这次作业的文件, 那就不得而知了.
为了完成这个作业, 除了作业要求材料之外, Andy Keep为了展示nanopass框架而写的两个编译器是值得阅读的, Andy Keep的PhD论文也是值得阅读的. Kent Dybvig的PhD论文, 以及其他一些关于Chez Scheme优化的论文, 同样地令人感兴趣. 有些材料没有那么适切, 但也仍然值得阅读, 比如Appel的Compiling with Continuations, 其刻画了SML/NJ的后端.
parse-scheme这次作业仅需要完成parse-scheme, 目的主要是将最初的源语言规约为更加紧凑的形式, 并对于输入进行一些简单的验证, 排除一些基本的错误. 当然, 顺便进行一下变换, 使得变量名唯一, 这是之后诸多分析和变换的基础.
虽然概念上没有什么复杂的地方, 但是写起来有许多细节问题, 导致我当初写得非常难受, 似乎也犯了不少错误. 不过, 最终我的代码和主流也稍微有所不同, 因为我试图解决一类常见但也经常不被注意到的问题, 就是绑定可以引入名字和关键词
相同的变量, 这时的处理我选择和一般的Scheme实现一致. 但是, 似乎网上别人上传的作业解答都没有注意到这一点. 当然, 这也不能算很重要就是了.
parse-scheme这个pass的输入语言的句法如下:
<exp> ::= <fixnum>
| <boolean>
| (quote <datum>)
| <var>
| (if <exp> <exp>)
| (if <exp> <exp> <exp>)
| (set! <var> <exp>)
| (begin <exp>+)
| (lambda (<var>*) <exp>+)
| (let ((<var> <exp>)*) <exp>+)
| (letrec ((<var> <exp>)*) <exp>+)
| (and <exp>*)
| (or <exp>*)
| (<prim> <exp>*)
| (<exp> <exp>*)
<datum> ::= ()
| <boolean>
| <fixnum>
| (<datum> . <datum>)
| #(<datum>*)
<boolean> ::= #t
| #f<fixnum>是一个位的带符号整数. 至于为什么是位, 这是因为我们拿了位用作类型标记 (type tag). Scheme是一种动态类型的语言, 所以需要运行时的类型标记. 另外, 可以提前剧透一下, <fixnum>的类型标记是000, 这不是随意选择的, 而是有原因的. 当然, 原因之后再说. <var>实际上就是一个Scheme符号而已, 不是其他东西. 单分支的if, 理论上而言是利用其副作用, 若是不能成立, 我们选择返回(void), 这是许多Scheme实现的选择, 用其表达利用副作用的意图. 当然, 单分支的if是以宏扩展一般的方式转化为正常的if表达式的. 非终结符后面跟着的星号叫做Kleene star, 这是相当标准的东西, 表示零个或任意有限多个. 非终结符后面跟着的加号叫做Kleene plus, 也基本上是相当标准的东西, 表示一个或(更多的)任意有限多个. begin表达式可以有多个句法参数, 但是只有最后一个才是作为值意图的, 其余的那些表达式我们则是意图利用其副作用. lambda, let, letrec这三种构造里出现的诸变量应该是互异的, 这没有什么可说的. let和letrec的绑定规则, 其实大家也是知道的, 当然的确是有所不同的. and和or也相当于是利用宏扩展实现的, 会被转换为嵌套的if表达式. 应用一个原始过程和应用非原始过程的句法其实很像, 不过其实在这种情况下的确是必要的. 读者可能会发现, <prim>竟然不能单独出现, 这其实和正常的Scheme实现还不太一样. 不过, 也不是什么大的限制, 毕竟可以使用扩展. 当然, 编译器可以考虑纳入这种单独出现的原始过程引用的句法, 但是这里无所谓啦. 之前只出现了and和or, not去哪里了呢, not是一个过程, 而不是特殊句法. 不过, 老实说, not也将以宏展开的形式实现就是了. 我们选取的Scheme子集的每个过程都有固定的元数 (arity), 原始过程当然不例外, 我们会检查应用原始过程时元数是否正确. 至于在最一般的情况下检查元数是否合规, 其实不是简单的问题. 的确可以做一部分简单的情况, 但是我不想增加复杂性了. 老实说, 在句法上区分原始过程应用和非原始过程应用对于之后的pass是有益的, 但是P423里没有这么做. 我怀疑出发点还是在于这使得中间的pass看起来会更像是普通的Scheme表达式, 因而检查的时候可以直接在Scheme的REPL里尝试, 不知道Kent Dybvig是不是这样想的. 反正不管怎么说, 我们并没有进行区分. 最后我们来说说<datum>, 但其实也没有什么可说的了. 序对和向量的记号都是按照Lisp语言的记法来的, 所以Lisper应该都能理解. 注意, 这里没有符号字面量, 因为实现符号需要另外的机制, 其实不算复杂, 但是估计Kent Dybvig认为没有必要教这种东西, 之后学生可以自己学会. 大概要说的就是这么多了.我现在意识到我几年前写的每个pass都犯了一个共同的错误, 就是没有区分原始过程应用和非原始过程应用. 以我的直觉来看, 这应该会导致一些混乱而不清晰的代码, 比如说很多时候原始应用不必再次进入递归过程之中. 这会导致一个问题, 处理变量的逻辑有时还需要剔除意外而来的原始过程, 这并不符合follow the syntax的精神. 至于是否一定会造成什么问题, 我其实回忆不起来很细节的事情了. 但是印象中, 可能因此出现的问题我应该是以丑陋的方式解决了.
现在其实可以动笔开始写了, 不过在这之前, 其实我们还需要写一些辅助过程, 辅助过程被放在utils.rkt里. 正好, 我们也可以说明一下编译器整体的结构, 实际上非常简单. 每个编译器pass都是独立(成一个文件)的, 只依赖于utils.rkt, 然后都会provide一个过程. 最后, 有一个文件将这些pass组合在一起, 形成一个完整的编译器.
首先, 我们需要unique-symbol来生成唯一的标识符, 这是通过一个全局的计数器实现的.
(define (make-counter x)
(lambda ()
(set! x (+ x 1))
x))
(define unique-symbol
(let ((counter (make-counter -1)))
(lambda (x)
(string->symbol
(format "~s.~s" x (counter))))))其次, 我们需要实现集合. 其实, Racket的确有一个集合数据结构, 而且效率肯定比我们随便用顺序可达的列表实现的集合要高. 但是呢, 现在我们的确不在乎编译的效率, 也没想着测试复杂的输入. 不论如何, 之后都可以再改.
(define (set? x)
(cond ((null? x) #t)
((memq (car x) (cdr x)) #f)
(else (set? (cdr x)))))
(define (set-cons x s)
(if (memq x s)
s
(cons x s)))
(define (U s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (U (cdr s1) s2))
(else (cons (car s1) (U (cdr s1) s2)))))
(define (I s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (cons (car s1) (I (cdr s1) s2)))
(else (I (cdr s1) s2))))
(define (D s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (D (cdr s1) s2))
(else (cons (car s1) (D (cdr s1) s2)))))接着, 让我们想一想我们对于<fixnum>的要求, 写下谓词target-fixnum?.
(define (target-fixnum? x)
(and (integer? x)
(exact? x)
(<= (- (expt 2 60)) x (- (expt 2 60) 1))))datum?也不要忘了.(define (datum? x)
(or (null? x) (boolean? x) (target-fixnum? x)
(and (pair? x) (datum? (car x)) (datum? (cdr x)))
(and (vector? x)
(let ((len (vector-length x)))
(let loop ((i 0))
(cond ((= len i) #t)
((datum? (vector-ref x i)) (loop (+ i 1)))
(else #f)))))))最后, 让我们写下用来解构let或letrec绑定的过程, 以及构造let或letrec构造的过程. 老实说, 没有必要将中间表示设计得看上去和Scheme长得一样, 但是可能Kent Dybvig乐意这么做吧. 另外, nanopass本身提供了方便解构和构造这类东西的机制, 但是我们没有就是了, 所以不得不采取这种看起来比较迂回的方法.
(define (: bds k)
(k (map car bds) (map cadr bds)))
(define (Let x* e* body)
(list 'let (map list x* e*) body))
(define (Letrec x* e* body)
(list 'letrec (map list x* e*) body))好了, 差不多就是这样. 如果之后用到什么其他的辅助过程, 那就之后再说. 接下来, 我们终于开始着手写parse-scheme.
在parse-scheme的内部, 我们会有两个互递归的过程parse和parse-form. 这两者的功能很容易从名字中看出来, parse-form用来parse特殊形式相关的构造, 其余则由parse处理, parse可以接受一般的<exp>作为参数.
(define (parse-scheme exp)
(define prim-env
'((+ . 2)
(- . 2)
(* . 2)
(= . 2)
(< . 2)
(> . 2)
(<= . 2)
(>= . 2)
(null? . 1)
(boolean? . 1)
(fixnum? . 1)
(pair? . 1)
(vector? . 1)
(box? . 1)
(procedure? . 1)
(eq? . 2)
(not . 1)
(cons . 2)
(car . 1)
(cdr . 1)
(set-car! . 2)
(set-cdr! . 2)
(make-vector . 1)
(vector-length . 1)
(vector-ref . 2)
(vector-set! . 3)
(box . 1)
(unbox . 1)
(set-box! . 2)
(void . 0)))
(define (make-body exps env)
(cond ((null? exps) (error 'parse-scheme "empty begin body"))
((null? (cdr exps)) ((parse env) (car exps)))
(else (cons 'begin (map (parse env) exps)))))
(define (parse env)
(lambda (exp)
(match exp
(,n (guard (number? n)) (if (target-fixnum? n)
`(quote ,n)
(error 'parse-scheme "invalid number ~s" n)))
(,b (guard (boolean? b)) `(quote ,b))
(,x (guard (symbol? x))
(cond ((assq x env) => cdr)
((assq x prim-env)
(error 'parse-scheme
"primitive ~s should not appear independently" x))
(else (error 'parse-scheme "unbound variable ~s" x))))parse-scheme起手是这样的, 实际上我们还未触及什么实质性的逻辑. 即便如此, 还是有一些应该解释的东西. prim-env是一个固定的上下文, 在递归过程中不会发生改变. 或许有的人将其当作基础的环境, 在递归中会得到增长, 但从概念上来说这么做是有点混乱的, 不过能达成目的就行. prim-env里记录了原始过程的名字和其对应的元数, 元数是用来检查原始应用表达式的. env和prim-env不同, 其记录的是旧名字和新名字之间的绑定. 另外, 读者看到, 我们的确不允许原始过程单独以变量的形式的出现. 对于常量, 我们会将其用quote包裹, 这约简了句法的复杂性 (也就是减少了一些产生式). 至于make-body的作用, 之后我们才会看到, 它主要是为了将<exp>+都转换为恰好一个<exp>. 多于一个<exp>的情况下, 我们会将其转换成begin形式, 这是我们所期望的语义.
((,rator . ,rands)
(if (symbol? rator)
(let ((a (assq rator env)))
(if a
(let ((rator (cdr a))
(rands (map (parse env) rands)))
(cons rator rands))
(let ((a (assq rator prim-env)))
(if a
(let ((arity (cdr a)))
(unless (= (length rands) arity)
(error 'parse-scheme
"arity mismatch expected ~s given ~s"
arity (length rands)))
(let ((rands (map (parse env) rands)))
(if (eq? rator 'not)
`(if ,(car rands) '#f '#t)
(cons rator rands))))
((parse-form env) exp)))))
(map (parse env) exp))))))parse的最后一部分还是比较复杂的, 我们需要分类拆解来看. 首先, 在rator是一个符号的情况下, 实际上有两种可能. 一种可能是原始过程应用, 还有一种可能是非原始过程应用. 我们需要先在环境中去检索这个符号, 如果存在的话, 就说明其应该是一个非原始过程应用. 这里有一个很自然的地方, 就是如果绑定变量的名字和原始过程一致, 那么这个绑定就会遮盖原始过程. 因此, 我们不能先在原始环境中检索符号, 那不符合输入语言的语义. 若是环境中没有这个符号, 那么就在原始环境中寻找. 若是找到了, 就说明这是一个原始过程应用. 并且, 此时我们可以检查元数的一致性. 这里我们对于not进行了特殊处理, 对其进行了扩展. 如果环境和原始环境中都找不到这个符号, 说明这个表达式可能是一个特殊形式, 所以接下来的任务就交给parse-form了. 当然, 我们不能排除这个符号是在引用一个未绑定的变量, 不过这件事情当然也交由parse-form处理. 以上我们只考虑了rator为一个符号的情况, 实际上rator还有可能是一个表达式, 那么此时肯定是一个非原始的过程应用, 我们以直接的结构递归对待.
(define (parse-form env)
(lambda (exp)
(match exp
((quote ,d) (if (datum? d)
exp
(error 'parse-scheme "invalid datum ~s" d)))
((if ,q ,a) `(if ,((parse env) q) ,((parse env) a) (void)))
((if ,q ,a ,e) `(if ,((parse env) q) ,((parse env) a) ,((parse env) e)))
((set! ,x ,e)
(let ((x (cond ((assq x env) => cdr)
((assq x prim-env)
(error 'parse-scheme "can't assign to prim ~s" x))
(else (error 'parse-scheme "unbound variable ~s" x))))
(e ((parse env) e)))
`(set! ,x ,e)))
((begin . ,exps) (make-body exps env))
((and . ,exps)
(if (null? exps)
''#t
(let ((exps (map (parse env) exps)))
(let loop ((exp (car exps)) (exps (cdr exps)))
(if (null? exps)
exp
`(if ,exp ,(loop (car exps) (cdr exps)) '#f))))))
((or . ,exps)
(if (null? exps)
''#f
(let ((exps (map (parse env) exps)))
(let loop ((exp (car exps)) (exps (cdr exps)))
(if (null? exps)
exp
(let ((t (unique-symbol 't)))
`(let ((,t ,exp))
(if ,t ,t ,(loop (car exps) (cdr exps))))))))))我们继续来看parse-form. 这一部分所做的事情基本都是自明的. 对于and和or形式的扩展方式, 每一个Schemer应该都不陌生. 这本质上和利用宏来实现and和or如出一辙. 在扩展or的时候, 不要忘了使用let绑定引入临时变量以避免重复求值.
((lambda ,x* . ,exps)
(unless (set? x*)
(error 'parse-scheme "invalid formals ~s" x*))
(let* ((x*^ (map unique-symbol x*))
(env^ (append (map cons x* x*^) env))
(body (make-body exps env^)))
`(lambda ,x*^ ,body)))
((let ,bds . ,exps)
(: bds
(lambda (x* e*)
(unless (set? x*)
(error 'parse-scheme "invalid let LHS vars ~s" x*))
(let* ((x*^ (map unique-symbol x*))
(env^ (append (map cons x* x*^) env))
(e* (map (parse env) e*))
(body (make-body exps env^)))
(Let x*^ e* body)))))
((letrec ,bds . ,exps)
(: bds
(lambda (x* e*)
(unless (set? x*)
(error 'parse-scheme "invalid letrec LHS vars ~s" x*))
(let* ((x*^ (map unique-symbol x*))
(env^ (append (map cons x* x*^) env))
(e* (map (parse env^) e*))
(body (make-body exps env^)))
(Letrec x*^ e* body)))))
(,else (error 'parse-scheme "unbound variable ~s" (car exp))))))
((parse '()) exp))以上就是parse-scheme的全部代码了. 这段程序主要是处理绑定结构. 对于这三种绑定结构, 我们都需要使用unique-symbol来引入新的名字, 然后将这些旧名字和新名字之间的绑定加入到环境中. 我们对于let和letrec的处理几乎是完全一致的, 只是在处理e*那里, let的环境是env, 而letrec的环境是env^, 这反映了两者在语义上的不同.
让我们来看几个例子. 注意, 变量的编号并不重要, 应该等价地阅读.
> (parse-scheme
'(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88)))
'(letrec ((even?.0 (lambda (n.2) (if (= n.2 '0) '#t (odd?.1 (- n.2 '1)))))
(odd?.1 (lambda (n.3) (if (= n.3 '0) '#f (even?.0 (- n.3 '1))))))
(even?.0 '88))> (parse-scheme '(and 1 2 3 4 5))
'(if '1 (if '2 (if '3 (if '4 '5 '#f) '#f) '#f) '#f)> (parse-scheme '(or 1 2 3 4 5))
'(let ((t.0 '1))
(if t.0
t.0
(let ((t.1 '2))
(if t.1 t.1 (let ((t.2 '3)) (if t.2 t.2 (let ((t.3 '4)) (if t.3 t.3 '5))))))))> (parse-scheme
'(let ((x 0))
(let ((x (+ x 1)))
(let ((x (+ x 2)))
(+ x 3)))))
'(let ((x.0 '0)) (let ((x.1 (+ x.0 '1))) (let ((x.2 (+ x.1 '2))) (+ x.2 '3))))本部分的最后, 我们应该给出parse-scheme的输出语言的句法.
<exp> ::= (quote <datum>)
| <uvar>
| (if <exp> <exp> <exp>)
| (set! <uvar> <exp>)
| (begin <exp>+)
| (lambda (<uvar>*) <exp>)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<uvar> <exp>)*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp>*)<var>变成了<uvar>. 并且, 产生式的种类更少, 也更加规整了.convert-complex-datum这次作业需要编写多个pass, 不过先让我们来完成convert-complex-datum. 这个pass的目的在于将复杂的<datum>转换为简单的<immediate>, 其中<immediate>的句法为
<immediate> ::= ()
| <boolean>
| <fixnum><datum>该怎么办呢? 答曰, 通过某些原始过程的组合得到, 并且在一开始就进行分配. 何谓原始过程的组合, 我们来枚举一些例子.'(#t . #f)(cons '#t '#f)'#(#t #f)(let ((vec.0 (make-vector '2)))
(begin
(vector-set! vec.0 '0 '#t)
(vector-set! vec.0 '1 '#f)
vec.0))vec.0这个变量的编号只是意思一下, 不代表实际一定会是这样.既然在一开始就分配这些常量, 我们需要在执行的过程中记录一些绑定. 这些绑定可以随着执行过程一起传递, 也可以定义一个全局变量, 通过赋值来积累这些绑定. 在这里更多是一种口味问题, 我认为没有明显的优劣, 两种风格我都尝试过.
(define (convert-datum x)
(cond ((pair? x)
(list 'cons (convert-datum (car x)) (convert-datum (cdr x))))
((vector? x)
(let ((l (vector-length x)))
(if (= l 0)
'(make-vector '0)
(let ((v (unique-symbol 'vec)))
`(let ((,v (make-vector (quote ,l))))
,(let loop ((i l) (e* (cons v '())))
(if (= i 0)
(cons 'begin e*)
(let ((i (- i 1)))
(loop i
(cons
`(vector-set!
,v (quote ,i)
,(convert-datum (vector-ref x i)))
e*))))))))))
(else `(quote ,x))))当然, 不论采用何种风格, 首先我们都需要编写转换过程convert-datum. 这个过程没有什么难的, 就是很直接的结构递归.
以下我将展示两种风格, 首先是利用副作用来积累绑定的版本.
(define (convert-complex-datum exp)
(define bindings '())
(define (add-binding! datum)
(define t (unique-symbol 't))
(define d (convert-datum datum))
(push! (list t d) bindings)
t)
(define (convert exp)
(match exp
((quote ,d) (if (or (pair? d) (vector? d))
(add-binding! d)
exp))这是convert-complex-datum的开头, 我们定义了一个全局的变量bindings. 当我们遇到一个复杂的<datum>时, 就会调用add-binding!, 作为命名约定的!是在提示我们该过程含有副作用. 它会生成一个新的变量, 然后构造这个变量和转换之后的<datum>之间的绑定, 将其添加到bindings里, 并且最终返回生成的这个变量, 其中push!是一个特殊形式, 可以按照以下方式定义.
(define-syntax push!
(syntax-rules ()
((_ x l) (set! l (cons x l)))))实际上主要的逻辑就集中于开头, 剩余的代码只是一些定式而已.
(,uvar (guard (symbol? uvar)) uvar)
((if ,q ,a ,e) `(if ,(convert q)
,(convert a)
,(convert e)))
((set! ,uvar ,exp) `(set! ,uvar ,(convert exp)))
((begin . ,exps) (cons 'begin (map convert exps)))
((lambda ,x* ,body) `(lambda ,x* ,(convert body)))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map convert e*))
(body (convert body)))
(Let x* e* body)))))
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map convert e*))
(body (convert body)))
(Letrec x* e* body)))))
((,prim . ,rands)
(guard (prim? prim))
`(,prim . ,(map convert rands)))
((,rator . ,rands)
(map convert exp))))
(let ((exp (convert exp)))
(if (null? bindings)
exp
`(let ,bindings ,exp))))最后, 如果没有绑定, 也没有必要添加空的let就是了. 当然, 这是一个可有可无的优化, 主要目的只是让我看得更顺眼一点. 另外, 还有一点要说, 通过prim?来区分是否是原始应用看起来有点尴尬, 但是既然我们没有设计直接分辨两者的句法, 那么这的确是必要的. 至于如何实现, 没有什么秘密, 读到这里的人应该都明白.
接着, 让我们展示不基于副作用来积累绑定的版本, 或者说更函数式的版本. 有的人可能更喜欢这个版本, 这是因为在刚才的版本里, 有些求值顺序是由实现隐式决定的, 不那么确定或者说具有可预测性. 更函数式的版本允许我们细致地控制求值顺序, 这样不同的Scheme实现也可以显而易见地产生相同的结果.
(define (convert-complex-datum exp)
(define (convert* exp* k)
(if (null? exp*)
(k '() '())
(convert
(car exp*)
(lambda (exp bindings0)
(convert*
(cdr exp*)
(lambda (exp* bindings1)
(k (cons exp exp*)
(append bindings0 bindings1))))))))
(define (convert exp k)
(match exp
((quote ,d) (if (or (pair? d) (vector? d))
(let ((t (unique-symbol 't)))
(k t `((,t ,(convert-datum d)))))
(k exp '())))还是先来看开头, 这奠定了代码的基本结构. 我们使用了所谓的延续传递风格来返回多值, 这只是一种可能的手段, 当然还有其他各种写法. convert*基于convert, 它意图转换一列表达式, 并将得到的绑定合并起来. 当然, 更准确地说, convert*和convert是一种互递归的关系. 对于(quote ,d)的处理和之前并没有本质区别, 只是我们现在将结果传递给延续参数
k而已.
(,uvar (guard (symbol? uvar)) (k uvar '()))
((if ,q ,a ,e)
(convert*
(cdr exp)
(lambda (qae bindings)
(k (cons 'if qae) bindings))))
((set! ,uvar ,exp)
(convert exp (lambda (exp bindings)
(k `(set! ,uvar ,exp) bindings))))
((begin . ,exp*)
(convert* exp* (lambda (exp* bindings)
(k (cons 'begin exp*) bindings))))
((lambda ,x* ,body)
(convert body (lambda (body bindings)
(k `(lambda ,x* ,body) bindings))))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(convert*
e* (lambda (e* bindings0)
(convert
body (lambda (body bindings1)
(k (Let x* e* body)
(append bindings0 bindings1)))))))))
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(convert*
e* (lambda (e* bindings0)
(convert
body (lambda (body bindings1)
(k (Letrec x* e* body)
(append bindings0 bindings1)))))))))
((,prim . ,rands)
(guard (prim? prim))
(convert* rands (lambda (rands bindings)
(k (cons prim rands) bindings))))
((,rator . ,rands) (convert* exp k))))
(convert exp (lambda (exp bindings)
(if (null? bindings)
exp
`(let ,bindings ,exp)))))以上是剩下来的代码, 没有什么好说的. 我们通常遵循这样一种模式, 通过convert或者convert*进行转换, 然后对于返回的表达式和绑定加工一下再返回.
现在让我们来看一些例子. 当然, 在这之前, 我们需要将convert-complex-datum和parse-scheme连接起来, 通过函数复合compose.
(define compil
(compose convert-complex-datum
parse-scheme
))接着才是例子.
> (compil '(letrec ((append (lambda (l1 l2)
(if (null? l1)
l2
(cons (car l1)
(append (cdr l1) l2))))))
(append '(0 1 2) '(3 4 5))))
'(let ((t.3 (cons '0 (cons '1 (cons '2 '())))) (t.4 (cons '3 (cons '4 (cons '5 '())))))
(letrec ((append.0
(lambda (l1.1 l2.2)
(if (null? l1.1) l2.2 (cons (car l1.1) (append.0 (cdr l1.1) l2.2))))))
(append.0 t.3 t.4)))> (compil '(+ 1 (* 2 3)))
'(+ '1 (* '2 '3))> (compil '(vector-length '#(0 1 2)))
'(let ((t.0
(let ((vec.1 (make-vector '3)))
(begin
(vector-set! vec.1 '0 '0)
(vector-set! vec.1 '1 '1)
(vector-set! vec.1 '2 '2)
vec.1))))
(vector-length t.0))> (compil ''#(#(0) (1) (#t #f)))
'(let ((t.0
(let ((vec.1 (make-vector '3)))
(begin
(vector-set!
vec.1
'0
(let ((vec.2 (make-vector '1))) (begin (vector-set! vec.2 '0 '0) vec.2)))
(vector-set! vec.1 '1 (cons '1 '()))
(vector-set! vec.1 '2 (cons '#t (cons '#f '())))
vec.1))))
t.0)本部分的最后, 让我们给出convert-complex-datum的输出语言的句法.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (set! <uvar> <exp>)
| (begin <exp>+)
| (lambda (<uvar>*) <exp>)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<uvar> <exp>)*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp>*)
<immediate> ::= ()
| <boolean>
| <fixnum><datum>被替换为了<immediate>.uncover-assigned现在让我们接着完成uncover-assigned, 这个pass实际上是为了convert-assignments作准备, 当然purify-letrec也会用到这里得到的信息. uncover-assigned是为了分析被赋值了的变量, 然后在这些变量被绑定引入的地方标示出来. 正如刚才所说, uncover-assigned是为了convert-assignments作准备, convert-assignments的目的在于消除赋值. 消除赋值的方法是将set!形式转换为等效的利用box相关函数的表达式. 为什么要消除赋值呢? 这是因为在赋值存在的情况下之后的闭包变换难以进行.
uncover-assigned写起来当然也非常容易, 不过这次我们最好要先明确其输出语言的句法.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (set! <uvar> <exp>)
| (begin <exp>+)
| (lambda (<uvar>*) (assigned (<uvar>*) <exp>))
| (let ((<uvar> <exp>)*) (assigned (<uvar>*) <exp>))
| (letrec ((<uvar> <exp>)*) (assigned (<uvar>*) <exp>))
| (<prim> <exp>*)
| (<exp> <exp>*)lambda, let, letrec的句法发生了变化, 也就是记录了被赋值的变量. 为了明显起见, 这里还使用了assigned进行提示, 但是从功能上来说这可有可无, 只是便于阅读而已.编写uncover-assigned需要我们分析和积累被赋值的变量, 并自下而上地传递. 当我们碰到绑定结构时, 它会截胡
由它引入且被赋值的变量, 这其实有点让人联想到lambda绑定自由变量的过程. 诚然如此, 之后当我们进行闭包变换时, 首先要进行uncover-free来分析自由变量, 而其写法与uncover-assigned如出一辙. 多说一句, 自下而上地分析也保证了我们分析的被赋值变量和自由变量与绑定结构(的遮盖行为)相适配.
(define (uncover-assigned exp)
(define (uncover* exp*)
(if (null? exp*)
(values '() '())
(let-values (((exp u*) (uncover (car exp*)))
((exp* v*) (uncover* (cdr exp*))))
(values (cons exp exp*) (U u* v*)))))
(define (uncover exp)
(match exp
((quote ,i) (values exp '()))
(,uvar (guard (symbol? uvar)) (values exp '()))
((if ,q ,a ,e)
(let-values (((qae u*) (uncover* (cdr exp))))
(values (cons 'if qae) u*)))
((set! ,uvar ,exp)
(let-values (((exp u*) (uncover exp)))
(values `(set! ,uvar ,exp)
(set-cons uvar u*))))这是uncover-assigned的开头, 我展示了一种和convert-complex-datum不同的返回多值的方法, 也就是使用values. 这里最值得关注的其实是处理(set! ,uvar ,exp)的部分, uvar是被赋值的变量, 当然也不要忘记exp的被赋值变量. set-cons和U类似, 但只是添加一个元素到某个集合中.
((begin . ,exp*)
(let-values (((exp* u*) (uncover* exp*)))
(values (cons 'begin exp*) u*)))
((lambda ,x* ,body)
(let-values (((body u*) (uncover body)))
(values `(lambda ,x*
(assigned ,(I x* u*) ,body))
(D u* x*))))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let-values (((e* u*) (uncover* e*))
((body v*) (uncover body)))
(values (Let x* e* `(assigned ,(I x* v*) ,body))
(U u* (D v* x*)))))))
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let-values (((e* u*) (uncover* e*))
((body v*) (uncover body)))
(define w* (U u* v*))
(values (Letrec x* e* `(assigned ,(I x* w*) ,body))
(D w* x*))))))接着, 我们应该将注意力集中到三种绑定结构上来: lambda, let, letrec. 处理这三种构造的代码都是清晰的, 只是我想提请读者注意一下letrec和let的处理方式的确不同, letrec的绑定可以管辖到它的右支的那些表达式, 因而需要将e*的被赋值变量u*和body的被赋值变量v*并为w*.
((,prim . ,rands)
(guard (prim? prim))
(let-values (((rands u*) (uncover* rands)))
(values `(,prim . ,rands) u*)))
((,rator . ,rands) (uncover* exp))))
(let-values (((exp u*) (uncover exp)))
(if (null? u*)
exp
(error 'uncover-assigned "unbound assigned variables ~s" u*))))收尾的部分并不那么有趣, 只是我们需要注意, 我们并不期望存在未被绑定的被赋值变量. 当然了, 一般来说这不太可能, 因为未被绑定的变量在parse-scheme那里就被拦截下来了. 不过, 层层设防还是有好处的, 因为笔误是永远也无法排除的.
说点无关紧要的话, 就是我们的转换是保守
的. 何谓保守, 就是我们没有试图分析什么样的赋值是在运行时真正可达的, 而是将所有具有嫌疑的变量都一网打尽. 当然, 根据可计算理论的经典结果, 想要完美地进行这种分析在一般情况下是不可能的. 因此, 其实绝大多数编译器中的pass都是保守的. 不过, 的确我们在之后是可以有机会去优化一下的, 不过现在不是好时机.
以下是一些例子, 当然记得更新compil的定义.
> (compil '(let ((counter (let ((x 0))
(lambda ()
(set! x (+ x 1))
x))))
(counter)
(counter)
(counter)))
'(let ((counter.0
(let ((x.1 '0))
(assigned
(x.1)
(lambda () (assigned () (begin (set! x.1 (+ x.1 '1)) x.1)))))))
(assigned () (begin (counter.0) (counter.0) (counter.0))))> (compil '(letrec ((append (lambda (l1 l2)
(if (null? l1)
l2
(cons (car l1)
(append (cdr l1) l2))))))
(append '(0 1 2) '(3 4 5))))
'(let ((t.3 (cons '0 (cons '1 (cons '2 '()))))
(t.4 (cons '3 (cons '4 (cons '5 '())))))
(assigned
()
(letrec ((append.0
(lambda (l1.1 l2.2)
(assigned
()
(if (null? l1.1)
l2.2
(cons (car l1.1) (append.0 (cdr l1.1) l2.2)))))))
(assigned () (append.0 t.3 t.4)))))purify-letrec老实说, 我并不真正理解purify-letrec. 但是, 既然它将要做的事情描述得很明确, 只是写一写没有多大问题.
letrec的问题在于它太灵活了, 其实对它稍作限制, 也不会影响任何常见程序的表达. 不过, 既然Scheme的原则就是消除限制, 那么我就不得不严肃一点思考怎么处理letrec.
如果一个Scheme实现不提供letrec, 那么我们可以通过宏来实现letrec, 其中最简单但也最低效的转换方式是将
(letrec ((x e) ...) body)(let ((x (void)) ...)
(let ((t e) ...)
(set! x t)
...
body))t是新的变量. 为什么说这种方式低效呢? 因为它会阻碍之后的优化.letrec并非洪水猛兽, 对于最简单纯粹的letrec, 我们想直接保留其形式. 何谓纯粹呢? 也就是说, letrec的右支诸表达式均为lambda表达式, 并且由该letrec引入的诸变量均未得到赋值, 例如
(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88))现在让我们来详细描述作业14里的purify-letrec的所作所为. 首先, letrec的右支诸表达式和体都会递归地应用这个转换. 接着, 我们将letrec的绑定分为三种情况, 分别是简单, lambda, 复杂. lambda我们已经说过了, 也就是右支是一个lambda且其绑定至的变量未被赋值. 至于简单和复杂之分, 还是让我引用作业的原文吧.
A simple expression contains no occurrences of the variables bound by the可以看到, 对于简单表达式的判定存在一定的灵活空间. 不过, 简单绑定还不完全等同于简单表达式, 它还需要被绑定至的变量没有被赋值. 若是一个绑定不满足这两个条件中的任何一个, 那么它就是一个复杂绑定.letrecexpression and no applications unless nested withinlambdaexpressions. The latter constraint prevents simple expressions from reaching a call tocall/ccif we ever addcall/ccto our language. Of course, at that time we would also rule out primitive calls tocall/ccitself. It would also make sense to disallowletrecexpressions, to prevent this pass from becoming nonlinear, and to disallow other expressions, such aslambdaexpressions, to reduce the cost of thesimplecheck. Use your own judgement on this as long as you do treat as simple constants, references to variables not bound by the letrec, and primitive calls with simple operands.
letrec的右支表达式引用了其绑定的变量, 然而却没有被lambda包裹, 那么此时其实编译器按照letrec的语义应该引起一个异常才对. (当然, 被lambda包裹还是有可能被求值, 此时还是应该引起异常.) 换言之, 一个合理的letrec表达式的右支出现的没有包裹在lambda里的变量一定是不会引用该letrec绑定的变量的. 我的猜测是, 这留待运行时才会抛出异常, 因为全然分析这种可能性应该也是不可计算的. 不过, 在简单的情形下, 检查出这种错误应该是容易的, 比如上述情况.)最终, 在我们将letrec的绑定划分为了
(x_s e_s) ... : simple
(x_l e_l) ... : lambda
(x_c e_c) ... : complex(let ((x_s e_s) ...)
(assigned ()
(let ((x_c (void)) ...)
(assigned (x_c ...)
(letrec ((x_l e_l) ...)
(let ((x_t e_c) ...)
(assigned ()
(begin
(set! x_c x_t)
...
body))))))))x_t ...是新的变量. 我们看到, letrec已没有了assigned, 这是因为letrec所绑定的每个变量均不会被赋值.(define (purify-letrec exp)
(define (purify exp)
(match exp
((quote ,i) exp)
(,uvar (guard (symbol? uvar)) uvar)
((if ,q ,a ,e)
(cons 'if (map purify (cdr exp))))
((set! ,uvar ,exp)
`(set! ,uvar ,(purify exp)))
((begin . ,exp*)
(cons 'begin (map purify exp*)))
((lambda ,x* (assigned ,u* ,body))
`(lambda ,x*
(assigned ,u* ,(purify body))))
((let ,bds (assigned ,u* ,body))
(: bds
(lambda (x* e*)
(let ((e* (map purify e*))
(body (purify body)))
(Let x* e* `(assigned ,u* ,body))))))以上这些代码对于purify-letrec而言都不是实质性的, 所以让我们将注意力聚焦到对于letrec的处理上来.
((letrec ,bds (assigned ,u* ,body))
(: bds
(lambda (x* e*)
(let ((e* (map purify e*))
(body (purify body)))
(define (assigned? x) (memq x u*))
(define (bound? x) (memq x x*))
(define (lambda? e)
(and (pair? e)
(eq? (car e) 'lambda)))
(define (simple? e)
(match e
((quote ,i) #t)
(,x (guard (symbol? x)) (not (bound? x)))
((if . ,e*) (andmap simple? e*))
((begin . ,e*) (andmap simple? e*))
((,prim . ,e*)
(guard (prim? prim))
(andmap simple? e*))
(,else #f)))
(define (Leta x* e* u* body)
(if (null? x*)
body
`(let ,(map list x* e*)
(assigned ,u* ,body))))首先, 我们应该做一些准备工作, 故我们递归地变换了e*和body, 并定义了assigned?, bound?, lambda?, simple?, Leta. 其中的Leta只是为了方便地构造带有assigned的let而已, 不过它还多做了一个判断, 避免空let绑定的产生.
(let iter ((x* x*)
(e* e*)
(xs* '())
(es* '())
(xl* '())
(el* '())
(xc* '())
(ec* '()))
(if (null? x*)
(let ((xt* (map (lambda (x)
(unique-symbol 't))
xc*)))
(Leta
xs* es* '()
(Leta
xc* (map (lambda (x) '(void)) xc*) xc*
(Letrec
xl* el*
(Leta
xt* ec* '()
`(begin
,@(map (lambda (xc xt)
`(set! ,xc ,xt))
xc* xt*)
,body))))))这部分展示了我们通过一个迭代将绑定划分为不同的种类, 并且在划分结束后按照之前所描述的转换方式来构造表达式.
(let ((x (car x*))
(x* (cdr x*))
(e (car e*))
(e* (cdr e*)))
(cond ((assigned? x)
(iter x* e* xs* es* xl* el*
(cons x xc*) (cons e ec*)))
((lambda? e)
(iter x* e* xs* es*
(cons x xl*) (cons e el*)
xc* ec*))
((simple? e)
(iter x* e*
(cons x xs*) (cons e es*)
xl* el* xc* ec*))
(else
(iter x* e* xs* es* xl* el*
(cons x xc*) (cons e ec*)))))))))))这部分是划分的逻辑: 如果变量被赋值, 那么不论如何绑定都是复杂的; 接着表达式有可能是lambda, 那么绑定就是lambda; 然后表达式有可能是简单的, 那么绑定就是简单的; 最后, 如果还没有被归类, 那无疑就是一个复杂绑定了.
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map purify rands)))
((,rator . ,rands)
(map purify exp))))
(purify exp))收尾没有什么令人惊讶的地方.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (set! <uvar> <exp>)
| (begin <exp>+)
| (lambda (<uvar>*) (assigned (<uvar>*) <exp>))
| (let ((<uvar> <exp>)*) (assigned (<uvar>*) <exp>))
| (letrec ((<uvar> (lambda (<uvar>*) (assigned (<uvar>*) <exp>)))*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp>*)最后, 我们给出purify-letrec输出的语言的句法. 我们可以看到, letrec不再具有assigned形式, 并且其右支的诸表达式一定是lambda表达式.
以下是一些例子.
> (compil
'(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88)))
'(letrec ((odd?.1
(lambda (n.3) (assigned () (if (= n.3 '0) '#f (even?.0 (- n.3 '1))))))
(even?.0
(lambda (n.2) (assigned () (if (= n.2 '0) '#t (odd?.1 (- n.2 '1)))))))
(begin (even?.0 '88)))> (compil
'(letrec ((x 10))
(set! x (+ x 1))
x))
'(let ((x.0 (void)))
(assigned
(x.0)
(letrec ()
(let ((t.1 '10))
(assigned () (begin (set! x.0 t.1) (begin (set! x.0 (+ x.0 '1)) x.0)))))))> (compil
'(letrec ((f (lambda ()
(set! f g)
1))
(g (lambda () 0)))
(f)))
'(let ((f.0 (void)))
(assigned
(f.0)
(letrec ((g.1 (lambda () (assigned () '0))))
(let ((t.2 (lambda () (assigned () (begin (set! f.0 g.1) '1)))))
(assigned () (begin (set! f.0 t.2) (f.0)))))))我们没有试图消除冗余的begin, 不过这在之后的pass会被优化, 空let和letrec也是.
convert-assignmentsconvert-assignments施行的是所谓的赋值变换 (assignment conversion). 据我所知, 这是Kent Dybvig发明的, 用来解决闭包变换和赋值不能兼容的问题. 这个变换会降低具有大量赋值的程序的运行速度, 但是正常的Scheme程序应该也没有多少赋值.
目前, let和lambda还具有附加的assigned结构, 这将作为我们的脚手架使用. 我们会用box包裹被赋值变量的值, 将set!形式转变为对于函数set-box!的调用, 将对于被赋值变量的引用转变为通过调用unbox函数得到置于盒子 (box) 中的值.
举一个简单的例子或许比较容易理解.
(let ((x '2) (y '3))
(assigned (x)
(begin
(set! x (* x y))
x)))(let ((t '2) (y '3))
(let ((x (box t)))
(begin
(set-box! x (* (unbox x) y))
(unbox x))))lambda的处理也是类似的.convert-assignments应该是相当简单的pass. 注意到我们应该维护一个运行时的上下文, 其记录了哪些变量是被赋值了的.
(define (convert-assignments exp)
(define (Let x* e* body)
(if (null? x*)
body
`(let ,(map list x* e*) ,body)))
(define ((apply-env env) x)
(cond ((assq x env) => cdr)
(else x)))
(define (convert env)
(lambda (exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) ((apply-env env) x))
((if ,q ,a ,e)
(cons 'if (map (convert env) (cdr exp))))
((set! ,uvar ,exp)
`(set-box! ,uvar ,((convert env) exp)))
((begin . ,exp*)
(cons 'begin (map (convert env) exp*)))开头没有什么希奇的地方. 这里的Let是为了避免冗余的let绑定, 这是因为每当我们遇到lambda和let时, 都要试图转换assigned结构, 而对于空的assigned, 没有必要放置一个空的let绑定上去. 另外, apply-env具有两种不同的用途 (稍微算是滥用), 这在之后的代码中会看得很清楚.
((lambda ,x* (assigned ,u* ,body))
(define t*
(map (lambda (x) (unique-symbol 't)) u*))
(define ctx (map cons u* t*))
(define y*
(map (apply-env ctx) x*))
(define box*
(map (lambda (t) `(box ,t)) t*))
(define env^
(append (map (lambda (u)
(cons u `(unbox ,u))) u*)
env))
(define body^ ((convert env^) body))
`(lambda ,y*
,(Let u* box* body^)))convert的实质逻辑集中在对于lambda和let的处理上. 我们先看lambda, let是完全类似的. 我们需要为被赋值的变量u*生成相应的新变量t*, 然后的处理基本上遵循之前的描述. 现在我们可以看到env的形状了, 它是被赋值变量u和表达式`(unbox ,u)的对应. 当然, 其实记录被赋值变量已经足够了, 这里只是一种可能的实现方式.
((let ,bds (assigned ,u* ,body))
(: bds
(lambda (x* e*)
(let* ((e* (map (convert env) e*))
(env^ (append
(map (lambda (u)
(cons u `(unbox ,u))) u*)
env))
(body ((convert env^) body)))
(define t*
(map (lambda (x) (unique-symbol 't)) u*))
(define ctx (map cons u* t*))
(define y*
(map (apply-env ctx) x*))
(define box*
(map (lambda (t) `(box ,t)) t*))
(Let y* e*
(Let u* box* body))))))对于let的处理基本上和lambda一样, 只是不要忘了转换右支e*, 其上下文仍应为env, 因为let绑定管辖不到其右支.
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (convert env) e*))
(body ((convert env) body)))
(Letrec x* e* body)))))
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map (convert env) rands)))
((,rator . ,rands)
(map (convert env) exp)))))
((convert '()) exp))收尾相当平淡无奇. 可以看到, 对于letrec的处理完全是平凡的, 因为该做的事情在purify-letrec里就已经完成了.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (lambda (<uvar>*) <exp>)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<uvar> (lambda (<uvar>*) <exp>))*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp>*)最后我们给出convert-assignments的输出语言的句法. 和uncover-assigned之前的语言的句法相比, 赋值形式set!消失了, 并且letrec的右支变得更加狭隘, 只能是lambda表达式了.
以下是一些例子.
> (compil
'(let ((x 0) (y 1) (z 2))
(let ((counter (lambda ()
(set! x (+ x 1))
(set! z (+ z 2))
(cons x z))))
(counter)
(counter)
(counter))))
'(let ((t.4 '0) (y.1 '1) (t.5 '2))
(let ((x.0 (box t.4)) (z.2 (box t.5)))
(let ((counter.3
(lambda ()
(begin
(set-box! x.0 (+ (unbox x.0) '1))
(set-box! z.2 (+ (unbox z.2) '2))
(cons (unbox x.0) (unbox z.2))))))
(begin (counter.3) (counter.3) (counter.3)))))> (compil
'(letrec ((f (lambda ()
(set! f g)
1))
(g (lambda () 0)))
(f)))
'(let ((t.3 (void)))
(let ((f.0 (box t.3)))
(letrec ((g.1 (lambda () '0)))
(let ((t.2 (lambda () (begin (set-box! f.0 g.1) '1))))
(begin (set-box! f.0 t.2) ((unbox f.0)))))))optimize-direct-calloptimize-direct-call是一个简单的优化步骤, 所以它不会改变句法. 它的想法也非常简单, 就是将
((lambda (x ...) body) e ...)(let ((x e) ...) body)let的变换的逆.(define (optimize-direct-call exp)
(define (optimize exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) x)
((if ,q ,a ,e)
(cons 'if (map optimize (cdr exp))))
((begin . ,exp*)
(cons 'begin (map optimize exp*)))
((lambda ,x* ,body)
`(lambda ,x* ,(optimize body)))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map optimize e*))
(body (optimize body)))
(Let x* e* body)))))
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map optimize e*))
(body (optimize body)))
(Letrec x* e* body)))))
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map optimize rands)))以上只能算是样板代码 (boilerplate code). 若是借助于某种编译器框架, 或许可以写得更加简单.
((,rator . ,rands)
(let ((rator (optimize rator))
(rands (map optimize rands)))
(match rator
((lambda ,x* ,body)
(unless (= (length x*) (length rands))
(error 'optimize-direct-call
"arity mismatch expected ~s given ~s"
(length x*) (length rands)))
(Let x* rands body))
(,else (cons rator rands)))))))
(optimize exp))处理应用是convert的实质部分, 其实也就是判断rator是否是lambda表达式而已.
句法没有发生变化, 不再赘述. 以下是一些例子.
> (compil
'((lambda (x y)
(set! x (* x x))
(set! y (* y y))
(+ x y))
3 4))
'(let ((t.2 '3) (t.3 '4))
(let ((x.0 (box t.2)) (y.1 (box t.3)))
(begin
(set-box! x.0 (* (unbox x.0) (unbox x.0)))
(set-box! y.1 (* (unbox y.1) (unbox y.1)))
(+ (unbox x.0) (unbox y.1)))))> (compil
'(((lambda (x)
(lambda (y)
(+ x y)))
1) 2))
'((let ((x.0 '1)) (lambda (y.1) (+ x.0 y.1))) '2)remove-anonymous-lambda顾名思义, remove-anonymous-lambda是为了消除匿名的lambda. 所谓的匿名lambda, 指的是没有直接出现在let或者letrec右支的lambda. 对于藏在右支而非直接出现的情况, 当然也应该视为匿名的.
对于匿名lambda的处理是很简单的, 即为其赋一个名字而已. 换言之, 匿名的
(lambda (x ...) body)(letrec ((t (lambda (x ...) body))) t)t是一个新的变量. 这样的转换不依赖于上下文, 直接进行即可.(define (remove-anonymous-lambda exp)
(define (remove exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) x)
((if ,q ,a ,e)
(cons 'if (map remove (cdr exp))))
((begin . ,exp*)
(cons 'begin (map remove exp*)))
((lambda ,x* ,body)
(define t (unique-symbol 't))
(define l `(lambda ,x* ,(remove body)))
`(letrec ((,t ,l)) ,t))以上代码中只有对于lambda的处理是实质性的. 能在这里被捕获的lambda一定是匿名的, 否则会被let和letrec截胡. 我们放心地生成新的变量t, 并施行前述的转换.
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(remove body)))
(,else (remove e))))
e*))
(body (remove body)))
(Let x* e* body)))))
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(remove body)))))
e*))
(body (remove body)))
(Letrec x* e* body)))))对于let和letrec的处理可以说是意料之中的事情, 它们大抵上是类似的. let和letrec都剔出了右支出现的lambda单独处理. 对于let而言, 这是为了避免引入冗余的letrec绑定. 对于letrec而言, 这则是必要的, 因为其右支只能是lambda. 因此, 处理letrec右支的match仅有一个分支, 其他情况并不符合句法.
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map remove rands)))
((,rator . ,rands)
(map remove exp))))
(remove exp))收尾是平淡无奇的, 输出语言的句法也并没有发生变化. 暂时我们还不能将lambda从产生式中剔除, 因为有些lambda是被let绑定的. 不过, 经过接下来的sanitize-binding-forms之后, 我们的确可以和lambda说再见了.
然而, 刚才我们的描述实际上并不够准确. 严格来说, remove-anonymous-lambda的输出实际上是原本句法的一个子集. 在编写之后的sanitize-binding-forms时, 既可以采用原本的句法, 也可以采用更加精细的句法. 从理论上来说, 后者应该有一定的效率优势. 当然, 说了这么多废话, 下面是更精细的句法.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (let ((<uvar> <exp0>)*) <exp>)
| (letrec ((<uvar> <lam>)*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp>*)
<exp0> ::= <lam> | <exp>
<lam> ::= (lambda (<uvar>*) <exp>)看起来有点fancy, 不是吗? 不过这能将lambda表达式的出现限制在let和letrec的右支里.
以下是一些例子.
> (compil
'(let ((compose (lambda (f g)
(lambda (x)
(f (g x))))))
((compose (lambda (x) (* x x))
(lambda (x) (+ x 3)))
13)))
'(let ((compose.0
(lambda (f.1 g.2) (letrec ((t.6 (lambda (x.3) (f.1 (g.2 x.3))))) t.6))))
((compose.0
(letrec ((t.7 (lambda (x.4) (* x.4 x.4)))) t.7)
(letrec ((t.8 (lambda (x.5) (+ x.5 '3)))) t.8))
'13))> (compil
'(let ((c (let ((x 0))
(lambda ()
(set! x (+ x 1))
x))))
(c) (c) (c)))
'(let ((c.0
(let ((t.2 '0))
(let ((x.1 (box t.2)))
(letrec ((t.3
(lambda ()
(begin (set-box! x.1 (+ (unbox x.1) '1)) (unbox x.1)))))
t.3)))))
(begin (c.0) (c.0) (c.0)))sanitize-binding-formssanitize-binding-forms的目的很简单, 也就是将let绑定的lambda表达式提取出来, 将其转换成由letrec绑定的. 在这个pass之后, 一切lambda表达式就都只能出现在letrec的右支了, 而且当然letrec的右支只能是lambda表达式. 另外, 虽然并非严格必要, sanitize-binding-forms还会消除空let和letrec, 以及冗余的begin. 在某种意义上, 这个pass算是进行闭包变换之前的一块里程碑. 因此, 修整一下程序也并非什么不可理解的事情.
从概念上来说, 编写这个pass并不困难, 应该说一切的要素都似曾相识. 不过, 最终的程序也不是很短, 这需要一点耐心.
(define (sanitize-binding-forms exp)
(define (Let x* e* body)
(if (null? x*)
body
`(let ,(map list x* e*) ,body)))
(define (Letrec x* e* body)
(if (null? x*)
body
`(letrec ,(map list x* e*) ,body)))
(define (make-begin exp*)
(let ((exp* (append-map
(lambda (exp)
(match exp
((begin . ,exp*) exp*)
(,else (list exp))))
exp*)))
(if (null? (cdr exp*))
(car exp*)
(cons 'begin exp*))))
(define (lambda? exp)
(and (pair? exp)
(eq? (car exp) 'lambda)))
(define (sanitize exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) x)
((if ,q ,a ,e)
(cons 'if (map sanitize (cdr exp))))
((begin . ,exp*)
(make-begin (map sanitize exp*)))以上的代码中, 避免空绑定的Let和Letrec, 判断是否是lambda表达式的谓词lambda?, 都应该是容易理解的. make-begin需要一点思考, 因为它并不是在一般情况下消除冗余begin的过程, 而是假定了sanitize的确能够消除冗余的begin. 这是结构递归的想法. 至于一般的make-begin, 可以写成
(define (make-begin exp*)
(define (flatten exp*)
(append-map
(lambda (exp)
(match exp
((begin . ,exp*) (flatten exp*))
(,else (list exp))))
exp*))
(let ((exp* (flatten exp*)))
(if (null? (cdr exp*))
(car exp*)
(cons 'begin exp*)))) ((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(sanitize body)))
(,else (sanitize e))))
e*))
(body (sanitize body)))
(let iter ((x* x*)
(e* e*)
(xo* '())
(eo* '())
(xl* '())
(el* '()))
(if (null? x*)
(Letrec
xl* el*
(Let xo* eo* body))
(let ((x (car x*))
(x* (cdr x*))
(e (car e*))
(e* (cdr e*)))
(if (lambda? e)
(iter x* e* xo* eo*
(cons x xl*) (cons e el*))
(iter x* e* (cons x xo*) (cons e eo*)
xl* el*)))))))))对于let的处理是冗长的, 原因在于我们需要分类, 这看起来有点像之前的purify-letrec的某块内容, 但是概念上要简单得多. 我们只是要区分lambda和非lambda. 最近在GitHub上逛逛别人写的P423作业, 看到有人通过逐一判断的方式避免划分之后引入多余的let或letrec, 我觉得这种写法非常奇怪.
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(sanitize body)))))
e*))
(body (sanitize body)))
(Letrec x* e* body)))))
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map sanitize rands)))
((,rator . ,rands)
(map sanitize exp))))
(sanitize exp))收尾没有什么好解释的地方, 如常而已.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<uvar> (lambda (<uvar>*) <exp>))*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp>*)sanitize-binding-forms的输出语言的句法如上, 虽然之前我们已经刻画过了. 也就是说, 产生式里的lambda表达式没有了. 现在lambda表达式只能出现于letrec的右支, 且letrec的右支只能是lambda表达式.
以下是一些例子.
> (compil '(begin 1 (begin 2 (begin (begin 3 4) 5) 6) 7))
'(begin '1 '2 '3 '4 '5 '6 '7)> (compil
'(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88)))
'(letrec ((odd?.1 (lambda (n.3) (if (= n.3 '0) '#f (even?.0 (- n.3 '1)))))
(even?.0 (lambda (n.2) (if (= n.2 '0) '#t (odd?.1 (- n.2 '1))))))
(even?.0 '88))> (compil
'(((lambda (x)
(lambda (y)
(+ x y)))
1) 2))
'((let ((x.0 '1)) (letrec ((t.2 (lambda (y.1) (+ x.0 y.1)))) t.2)) '2)> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'((letrec ((h.0
(lambda (fact.4)
(letrec ((t.6
(lambda (n.5)
(if (= n.5 '0) '1 (* n.5 (fact.4 (- n.5 '1)))))))
t.6))))
(letrec ((f.1
(lambda (g.2)
(h.0 (letrec ((t.7 (lambda (x.3) ((g.2 g.2) x.3)))) t.7)))))
(f.1 f.1)))
'10)uncover-free实际上作业13还包括optimize-known-call, 不过那是插入闭包变换中间的优化步骤, 所以先让我们来看作业12. uncover-free是闭包变换的预备步骤, 其分析每个lambda表达式的自由变量.
(define (uncover-free exp)
(define (Lam lam k)
(match lam
((lambda ,x* ,body)
(uncover
body
(lambda (body u*)
(define v* (D u* x*))
(k `(lambda ,x*
(free ,v* ,body))
v*))))))
(define (Lam* lam* k)
(if (null? lam*)
(k '() '())
(Lam
(car lam*)
(lambda (lam u*)
(Lam*
(cdr lam*)
(lambda (lam* v*)
(k (cons lam lam*)
(U u* v*))))))))
(define (uncover* exp* k)
(if (null? exp*)
(k '() '())
(uncover
(car exp*)
(lambda (exp u*)
(uncover*
(cdr exp*)
(lambda (exp* v*)
(k (cons exp exp*)
(U u* v*))))))))即便只是开头, 也能看出来uncover-free和uncover-assigned相当类似, 的确如此. 当然, uncover-assigned那里我们使用values返回多值, 而这里我们使用额外的延续参数k, 但这不是本质上的区别. Lam专门用于处理lambda表达式, 现在它只出现在右支. Lam*处理一列lambda表达式, uncover*处理一列表达式, 它们和uncover一道构成了互相递归的过程, 各司其职地处理相应的句法.
现在更详细地描述一下Lam, 它利用uncover分析lambda的体的自由变量, 然后除去被lambda的形式参数绑定的那些变量, 就得到了整个lambda表达式的自由变量. 最后, 我们将自由变量记录于free形式里.
(define (uncover exp k)
(match exp
((quote ,i) (k exp '()))
(,x (guard (symbol? x)) (k x (list x)))
((if ,q ,a ,e)
(uncover*
(cdr exp)
(lambda (qae u*)
(k (cons 'if qae) u*))))
((begin . ,exp*)
(uncover*
exp*
(lambda (exp* u*)
(k (cons 'begin exp*) u*))))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(uncover*
e* (lambda (e* u*)
(uncover
body
(lambda (body v*)
(k (Let x* e* body)
(U u* (D v* x*))))))))))
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(Lam*
e* (lambda (e* u*)
(uncover
body
(lambda (body v*)
(k (Letrec x* e* body)
(D (U u* v*) x*)))))))))以上代码几乎只是常规而已. 不过, 或许应该再强调一下, letrec的右支受到letrec绑定的管辖, 而let的右支不会受到let绑定的管辖. 因此, 计算自由变量的代码也不太一样.
((,prim . ,rands)
(guard (prim? prim))
(uncover* rands
(lambda (rands u*)
(k (cons prim rands) u*))))
((,rator . ,rands) (uncover* exp k))))
(uncover
exp (lambda (exp u*)
(unless (null? u*)
(error 'uncover-free
"unbound variables ~s" u*))
exp)))收尾的时候, 如果整个表达式还有自由变量, 那一定是不太对的. 当然, 或许前面的pass已经能够排除这种情况了, 但我们的确没有必要省略这样的检查, 这有点类似于防御式编程.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<uvar> (lambda (<uvar>*) (free (<uvar>*) <exp>)))*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp>*)句法的变动只出现在lambda表达式里.
以下是一些例子.
> (compil
'(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88)))
'(letrec ((odd?.1
(lambda (n.3) (free (even?.0) (if (= n.3 '0) '#f (even?.0 (- n.3 '1))))))
(even?.0
(lambda (n.2) (free (odd?.1) (if (= n.2 '0) '#t (odd?.1 (- n.2 '1)))))))
(even?.0 '88))> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'((letrec ((h.0
(lambda (fact.4)
(free
()
(letrec ((t.6
(lambda (n.5)
(free
(fact.4)
(if (= n.5 '0) '1 (* n.5 (fact.4 (- n.5 '1))))))))
t.6)))))
(letrec ((f.1
(lambda (g.2)
(free
(h.0)
(h.0
(letrec ((t.7 (lambda (x.3) (free (g.2) ((g.2 g.2) x.3)))))
t.7))))))
(f.1 f.1)))
'10)> (compil
'(let ((counter (let ((x 0))
(lambda ()
(set! x (+ x 1))
x))))
(counter)
(counter)
(counter)))
'(let ((counter.0
(let ((t.2 '0))
(let ((x.1 (box t.2)))
(letrec ((t.3
(lambda ()
(free
(x.1)
(begin (set-box! x.1 (+ (unbox x.1) '1)) (unbox x.1))))))
t.3)))))
(begin (counter.0) (counter.0) (counter.0)))convert-closures顾名思义, convert-closures进行闭包变换, 不过实际上它只是闭包变换的第一步, 而或许uncover-free应该算作闭包变换的第零步. 对于这个变换, 我们最好先明确句法.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<label> (lambda (<uvar> <uvar>*)
(bind-free (<uvar> <uvar>*) <exp>)))*)
(closures ((<uvar> <label> <uvar>*)*) <exp>))
| (<prim> <exp>*)
| (<exp> <exp> <exp>*)只有letrec和非原语应用的句法发生了变换, 但是仅凭这句法的改变并不容易看出来这个变换究竟是在做什么. 实际上, 这个变换主要是为接下来的一步introduce-procedure-primitives作准备. 之后的lambda将不包含有自由变量, 转而引入了一个新的参数, 这也就是为什么新的句法之中lambda至少会拥有一个参数, 这个参数出现在第一个位置上, 代表所谓的闭包指针 (closure pointer)
. 什么是闭包指针呢? 顾名思义, 指向闭包的东西. 那么闭包是什么呢? 这个应该没有Schemer不理解. 简而言之, 技术性地, 一个闭包是一个向量, 其由一个函数指针 (标签)
和诸自由变量的值构成, 而所谓的函数指针里的函数, 其实就是这里不包含自由变量的新lambda. bind-free形式里的参数, 第一个位置上的也是闭包指针, 之后的则是各个自由变量. 之后我们会看到, lambda里原本的自由变量将会从闭包的分量之中提取出来. closures形式只是为引入闭包作准备, 这里每个闭包的数据分别是闭包的名字, 函数指针 (标签), 还有自由变量. 我们之后将会引入构造闭包的原语. 非原语应用的句法改变也是为了配合之后的变换, 此时我们知道在精心安排之下, 出现在rator位置的表达式, 其值应该是(作为向量的)闭包. 这个闭包实际上不能直接应用, 而之后的应用将会变为取出闭包的函数指针, 将闭包和实际参数传递给函数指针. 我们在这里所要做的事情只是复制rator罢了, 并避免可能的重复求值.
(define (convert-closures exp)
(define (convert exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) x)
((if ,q ,a ,e)
`(if ,(convert q)
,(convert a)
,(convert e)))
((begin . ,exp*)
(cons 'begin (map convert exp*)))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map convert e*))
(body (convert body)))
(Let x* e* body)))))开头平平无奇, 只是照常而已.
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(define label*
(map unique-label x*))
(define lam*
(map (lambda (e)
(match e
((lambda ,x* (free ,f* ,body))
(define cp
(unique-symbol 'cp))
`(lambda ,(cons cp x*)
(bind-free
,(cons cp f*)
,(convert body))))))
e*))
(define free**
(map (lambda (e)
(match e
((lambda ,x* (free ,f* ,body))
f*)))
e*))
(define closure*
(map (lambda (x label free*)
`(,x ,label . ,free*))
x* label* free**))
(Letrec
label* lam*
`(closures ,closure* ,(convert body))))))对于letrec的处理是主要的复杂所在, 但是我们所要做的只是生成所需的数据, 例如标签和闭包指针的名字, 最后再按描述将它们放在一起.
((,prim . ,exp*)
(guard (prim? prim))
(cons prim (map convert exp*)))
((,rator . ,rand*)
(let ((rator (convert rator))
(rand* (map convert rand*)))
(if (symbol? rator)
`(,rator ,rator . ,rand*)
(let ((t (unique-symbol 't)))
`(let ((,t ,rator))
(,t ,t . ,rand*))))))))
(convert exp))对于非原始应用的处理需要小心一点, 因为复制rator必须要避免重复求值, 这是由引入额外的let绑定完成的.
最后让我们给出一些例子.
> (compil
'(lambda (x)
(lambda (y)
(lambda (m)
((m x) y)))))
'(letrec ((t.3$6
(lambda (cp.7 x.0)
(bind-free
(cp.7)
(letrec ((t.4$8
(lambda (cp.9 y.1)
(bind-free
(cp.9 x.0)
(letrec ((t.5$10
(lambda (cp.11 m.2)
(bind-free
(cp.11 x.0 y.1)
(let ((t.12 (m.2 m.2 x.0)))
(t.12 t.12 y.1))))))
(closures ((t.5 t.5$10 x.0 y.1)) t.5))))))
(closures ((t.4 t.4$8 x.0)) t.4))))))
(closures ((t.3 t.3$6)) t.3))> (compil
'(let ((x 0) (y 1) (z 2))
(let ((counter (lambda ()
(set! x (+ x 1))
(set! z (+ z 2))
(cons x z))))
(counter)
(counter)
(counter))))
'(let ((t.5 '2) (y.1 '1) (t.4 '0))
(let ((z.2 (box t.5)) (x.0 (box t.4)))
(letrec ((counter.3$6
(lambda (cp.7)
(bind-free
(cp.7 x.0 z.2)
(begin
(set-box! x.0 (+ (unbox x.0) '1))
(set-box! z.2 (+ (unbox z.2) '2))
(cons (unbox x.0) (unbox z.2)))))))
(closures
((counter.3 counter.3$6 x.0 z.2))
(begin
(counter.3 counter.3)
(counter.3 counter.3)
(counter.3 counter.3))))))> (compil
'(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88)))
'(letrec ((odd?.1$4
(lambda (cp.6 n.3)
(bind-free
(cp.6 even?.0)
(if (= n.3 '0) '#f (even?.0 even?.0 (- n.3 '1))))))
(even?.0$5
(lambda (cp.7 n.2)
(bind-free
(cp.7 odd?.1)
(if (= n.2 '0) '#t (odd?.1 odd?.1 (- n.2 '1)))))))
(closures
((odd?.1 odd?.1$4 even?.0) (even?.0 even?.0$5 odd?.1))
(even?.0 even?.0 '88)))optimize-known-call之前我们已经提及这个步骤, 但是按照逻辑顺序其应该放在这个位置.
正如名字里所暗示的那样, optimize-known-call是一个优化步骤, 所以应该不改变句法. 不过, 实际上句法有一点微妙的改变.
<exp> ::= (quote <immediate>)
| <uvar>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<label> (lambda (<uvar> <uvar>*)
(bind-free (<uvar> <uvar>*) <exp>)))*)
(closures ((<uvar> <label> <uvar>*)*) <exp>))
| (<prim> <exp>*)
| (<label> <exp> <exp>*)
| (<exp> <exp> <exp>*)非原始应用现在也可能以标签开头, 这其实也正是优化
的用意. 接下来的introduce-procedure-primitives实际上并不在乎这里是表达式还是标签, 虽然实际上convert-closures, optimize-known-call和introduce-procedure-primitives应该合并为一个步骤. 这可以免去诸多冗余的计算, 但是这里分开的理由大概只是Kent Dybvig认为现在这种安排对于初学者更容易理解, 可惜我并不这么觉得.
本次优化的想法在于, 如果非原始应用的开头直接地引用一个闭包, 我们知道 (或者读者还并不知道, 因为这是下一个变换所做的事情) 接下来我们需要寻找其对应的函数指针, 但是直接引用闭包意味着这个函数指针也可以直接引用, 那么就无需间接的调用 (indirect call) 了. 因此, 接下来的步骤里我们也要注意, 如果非原始应用的开头已经是一个标签, 那么就不能再动了.
(define (optimize-known-call exp)
(define (lookup rator env)
(cond ((assq rator env) => cdr)
(else rator)))
(define ((optimize env) exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) x)
((if ,q ,a ,e)
`(if ,((optimize env) q)
,((optimize env) a)
,((optimize env) e)))
((begin . ,exp*)
(cons 'begin (map (optimize env) exp*)))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (optimize env) e*))
(body ((optimize env) body)))
(Let x* e* body)))))开头没什么好说的, 这里的lookup是为了在环境env之中查找rator是否具有已知的对应标签. 因此, 这个环境是由闭包的名字和其对应的标签的序对构成的. 之后的步骤里, 我们要将非原始应用开头的闭包转换为获取这个闭包所对应的函数指针. 而开头已经是标签的, 那就无需转换了.
((letrec ,bds (closures ,closures ,body))
(define env^
(append
(map
(lambda (c)
(match c
((,name ,label . ,free*)
(cons name label))))
closures)
env))
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x*
(bind-free ,y* ,body))
`(lambda ,x*
(bind-free
,y* ,((optimize env^) body))))))
e*))
(body ((optimize env^) body)))
(Letrec
x* e*
`(closures ,closures ,body))))))处理letrec的部分很长, 但是主要的繁琐是扩展当前的环境env为env^. 这里需要小心的是, letrec所绑定的这些标签的作用域也能覆盖到其右支的诸lambda上.
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map (optimize env) rands)))
((,rator . ,rands)
(let ((rator ((optimize env) rator))
(rands (map (optimize env) rands)))
(if (symbol? rator)
(cons (lookup rator env) rands)
(cons rator rands))))))
((optimize '()) exp))对于非原始应用的处理是这次优化实质上的逻辑核心, 而其是由之前的lookup所完成的. 我们试图找到作为符号的rator所对应的标签, 但是找不到的话就维持原状.
让我们来看一些例子.
> (compil
'(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88)))
'(letrec ((odd?.1$4
(lambda (cp.6 n.3)
(bind-free
(cp.6 even?.0)
(if (= n.3 '0) '#f (even?.0$5 even?.0 (- n.3 '1))))))
(even?.0$5
(lambda (cp.7 n.2)
(bind-free
(cp.7 odd?.1)
(if (= n.2 '0) '#t (odd?.1$4 odd?.1 (- n.2 '1)))))))
(closures
((odd?.1 odd?.1$4 even?.0) (even?.0 even?.0$5 odd?.1))
(even?.0$5 even?.0 '88)))这个例子是比较理想的情况, 因为所有的非原始应用的rator位置都被替换为了其所对应的标签.
> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'(let ((t.17
(letrec ((h.0$8
(lambda (cp.9 fact.4)
(bind-free
(cp.9)
(letrec ((t.6$10
(lambda (cp.11 n.5)
(bind-free
(cp.11 fact.4)
(if (= n.5 '0)
'1
(* n.5 (fact.4 fact.4 (- n.5 '1))))))))
(closures ((t.6 t.6$10 fact.4)) t.6))))))
(closures
((h.0 h.0$8))
(letrec ((f.1$12
(lambda (cp.13 g.2)
(bind-free
(cp.13 h.0)
(h.0$8
h.0
(letrec ((t.7$14
(lambda (cp.15 x.3)
(bind-free
(cp.15 g.2)
(let ((t.16 (g.2 g.2 g.2)))
(t.16 t.16 x.3))))))
(closures ((t.7 t.7$14 g.2)) t.7)))))))
(closures ((f.1 f.1$12 h.0)) (f.1$12 f.1 f.1)))))))
(t.17 t.17 '10))而又一个例子则是不怎么理想的情况.
introduce-procedure-primitives顾名思义, introduce-procedure-primitives引入了一些和过程 (或者说闭包) 相关的原语. 这些原语包括make-procedure, procedure-set!, procedure-code以及procedure-ref, 其中
make-procedure: 接受一个函数指针和一个自然数, 这个自然数代表了自由变量的数目.procedure-set!: 接受一个过程 (或者说闭包), 一个索引, 还有一个值, 然后使得这个过程的索引位置的值是我们所提供的值. 这个过程在构造闭包的过程中要用到.procedure-code: 取一个闭包所包含的函数指针, 此时这个所谓的函数就没有任何自由变量了.
procedure-ref: 接受一个闭包和一个索引, 取闭包的索引位置所对应的值. 这个过程的目的是为了取得自由变量的值, 而闭包的来源则是之前所引入的lambda的额外参数.我们的实现策略是借助于两个互递归的过程intro和Intro, 这实际上反映了自然的句法结构, 因为只有lambda所辖的表达式才需要将其中的自由变量转换为对于procedure-ref的调用. 还有一种更为紧凑的实现策略, 也就是说, 我们要根据上下文来判断是否可能需要调用procedure-ref. 这更多的是个人偏好的问题, 而不是本质性的.
(define (introduce-procedure-primitives exp)
(define (intro exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) x)
((if ,q ,a ,e)
(cons 'if (map intro (cdr exp))))
((begin . ,exp*)
(cons 'begin (map intro exp*)))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map intro e*))
(body (intro body)))
(Let x* e* body)))))
((letrec ,bds (closures ,closures ,body))
(define make-procedure*
(map
(lambda (c)
(match c
((,name ,label . ,free*)
`(,name (make-procedure ,label (quote ,(length free*)))))))
closures))
(define procedure-set!*
(append-map
(lambda (c)
(match c
((,name ,label . ,free*)
(mapi (lambda (free index)
`(procedure-set! ,name (quote ,index) ,free))
free*))))
closures))
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x*
(bind-free
(,cp . ,free*)
,body))
`(lambda ,x* ,((Intro cp free*) body)))))
e*))
(body (intro body)))
(Letrec
x* e*
`(let ,make-procedure*
,(if (null? procedure-set!*)
body
`(begin ,@procedure-set!* ,body))))))))
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map intro rands)))
((,label . ,rands)
(guard (label? label))
(cons label (map intro rands)))
((,rator . ,rands)
(let ((rator (intro rator))
(rands (map intro rands)))
`((procedure-code ,rator) . ,rands)))))鉴于这次的代码很长, 所以每一块我也分割得很长, 因为絮叨的叙述也无助于实际的理解. 对于letrec的处理很长, 但是实际上只是为了准备构造闭包而花了那么多篇幅. 对于以标签开头的非原始应用需要单独处理, 所以引入了新的谓词label?. 其他的非原始应用也仅是需要给rator位置加上procedure-code.
(define (lookup x cp free*)
(let walk ((i 0) (free* free*))
(cond ((null? free*) x)
((eq? x (car free*))
`(procedure-ref ,cp (quote ,i)))
(else
(walk (+ i 1) (cdr free*))))))
(define (Intro cp free*)
(lambda (exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) (lookup x cp free*))
((if ,q ,a ,e)
(cons 'if (map (Intro cp free*) (cdr exp))))
((begin . ,exp*)
(cons 'begin (map (Intro cp free*) exp*)))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (Intro cp free*) e*))
(body ((Intro cp free*) body)))
(Let x* e* body)))))
((letrec ,bds (closures ,closures ,body))
(define make-procedure*
(map
(lambda (c)
(match c
((,name ,label . ,free*)
`(,name (make-procedure ,label (quote ,(length free*)))))))
closures))
(define procedure-set!*
(append-map
(lambda (c)
(match c
((,name ,label . ,free*)
(mapi (lambda (free index)
`(procedure-set! ,name (quote ,index) ,free))
free*))))
closures))
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x*
(bind-free
(,cp . ,free*)
,body))
`(lambda ,x* ,((Intro cp free*) body)))))
e*))
(body ((Intro cp free*) body)))
(Letrec
x* e*
`(let ,make-procedure*
,(if (null? procedure-set!*)
body
`(begin ,@procedure-set!* ,body))))))))
((,prim . ,rands)
(guard (prim? prim))
(cons prim (map (Intro cp free*) rands)))
((,label . ,rands)
(guard (label? label))
(cons label (map (Intro cp free*) rands)))
((,rator . ,rands)
(let ((rator ((Intro cp free*) rator))
(rands (map (Intro cp free*) rands)))
`((procedure-code ,rator) . ,rands))))))
(intro exp))lookup是为了将原本lambda中的自由变量转换为对于闭包的分量的引用. 实际上, 我们这里可以进行额外的检查, 确保lambda里的变量要么来源于闭包, 要么则是lambda内部所绑定的 (包含其参数). 不过, 我是有点懒散了, 目前的情况是如果不在闭包所包含的自由变量之中, 那么直接维持原样就好. 另外我们需要注意的是, 对于每个lambda而言, 我们不需要像之前的环境那样维持一个层次性
的结构, 因为自由变量的值就保存在闭包里. 对于lambda之中的lambda, 它只是直接切换上下文
.
Intro和intro几乎是一模一样的, 只是现在对于变量的处理需要查找. 之前的不需要查找, 是因为我们知道它不在lambda之中, 就谈不上自由变量的事情.
以下是一些例子.
> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'(let ((t.17
(letrec ((h.0$8
(lambda (cp.9 fact.4)
(letrec ((t.6$10
(lambda (cp.11 n.5)
(if (= n.5 '0)
'1
(*
n.5
((procedure-code (procedure-ref cp.11 '0))
(procedure-ref cp.11 '0)
(- n.5 '1)))))))
(let ((t.6 (make-procedure t.6$10 '1)))
(begin (procedure-set! t.6 '0 fact.4) t.6))))))
(let ((h.0 (make-procedure h.0$8 '0)))
(letrec ((f.1$12
(lambda (cp.13 g.2)
(h.0$8
(procedure-ref cp.13 '0)
(letrec ((t.7$14
(lambda (cp.15 x.3)
(let ((t.16
((procedure-code
(procedure-ref cp.15 '0))
(procedure-ref cp.15 '0)
(procedure-ref cp.15 '0))))
((procedure-code t.16) t.16 x.3)))))
(let ((t.7 (make-procedure t.7$14 '1)))
(begin (procedure-set! t.7 '0 g.2) t.7)))))))
(let ((f.1 (make-procedure f.1$12 '1)))
(begin (procedure-set! f.1 '0 h.0) (f.1$12 f.1 f.1))))))))
((procedure-code t.17) t.17 '10))有一点无聊但有趣的事情值得指出, 即Kent Dybvig有意将中间表示的句法安排得和Scheme类似. 所以说, 比如这里, 我们无需为此中间表示单独编写解释器来验证正确性, 其实只需要编写几个和闭包相关的过程即可.
(define (make-procedure label length)
(define vec (make-vector (+ length 1)))
(vector-set! vec 0 label)
vec)
(define (procedure-set! closure index value)
(vector-set! closure (+ index 1) value))
(define (procedure-code closure)
(vector-ref closure 0))
(define (procedure-ref closure index)
(vector-ref closure (+ index 1)))> (let ((t.17
(letrec ((h.0$8
(lambda (cp.9 fact.4)
(letrec ((t.6$10
(lambda (cp.11 n.5)
(if (= n.5 '0)
'1
(*
n.5
((procedure-code (procedure-ref cp.11 '0))
(procedure-ref cp.11 '0)
(- n.5 '1)))))))
(let ((t.6 (make-procedure t.6$10 '1)))
(begin (procedure-set! t.6 '0 fact.4) t.6))))))
(let ((h.0 (make-procedure h.0$8 '0)))
(letrec ((f.1$12
(lambda (cp.13 g.2)
(h.0$8
(procedure-ref cp.13 '0)
(letrec ((t.7$14
(lambda (cp.15 x.3)
(let ((t.16
((procedure-code (procedure-ref cp.15 '0))
(procedure-ref cp.15 '0)
(procedure-ref cp.15 '0))))
((procedure-code t.16) t.16 x.3)))))
(let ((t.7 (make-procedure t.7$14 '1)))
(begin (procedure-set! t.7 '0 g.2) t.7)))))))
(let ((f.1 (make-procedure f.1$12 '1)))
(begin (procedure-set! f.1 '0 h.0) (f.1$12 f.1 f.1))))))))
((procedure-code t.17) t.17 '10))
3628800再来看个例子.
> (compil
'(let ((compose (lambda (f g)
(lambda (x)
(f (g x))))))
((compose (lambda (x) (* x x))
(lambda (x) (+ x 3)))
13)))
'(letrec ((compose.0$9
(lambda (cp.10 f.1 g.2)
(letrec ((t.6$11
(lambda (cp.12 x.3)
((procedure-code (procedure-ref cp.12 '0))
(procedure-ref cp.12 '0)
((procedure-code (procedure-ref cp.12 '1)) (procedure-ref cp.12 '1) x.3)))))
(let ((t.6 (make-procedure t.6$11 '2)))
(begin (procedure-set! t.6 '0 f.1) (procedure-set! t.6 '1 g.2) t.6))))))
(let ((compose.0 (make-procedure compose.0$9 '0)))
(let ((t.17
(compose.0$9
compose.0
(letrec ((t.7$13 (lambda (cp.14 x.4) (* x.4 x.4))))
(let ((t.7 (make-procedure t.7$13 '0))) t.7))
(letrec ((t.8$15 (lambda (cp.16 x.5) (+ x.5 '3))))
(let ((t.8 (make-procedure t.8$15 '0))) t.8)))))
((procedure-code t.17) t.17 '13))))> (letrec ((compose.0$9
(lambda (cp.10 f.1 g.2)
(letrec ((t.6$11
(lambda (cp.12 x.3)
((procedure-code (procedure-ref cp.12 '0))
(procedure-ref cp.12 '0)
((procedure-code (procedure-ref cp.12 '1)) (procedure-ref cp.12 '1) x.3)))))
(let ((t.6 (make-procedure t.6$11 '2)))
(begin (procedure-set! t.6 '0 f.1) (procedure-set! t.6 '1 g.2) t.6))))))
(let ((compose.0 (make-procedure compose.0$9 '0)))
(let ((t.17
(compose.0$9
compose.0
(letrec ((t.7$13 (lambda (cp.14 x.4) (* x.4 x.4))))
(let ((t.7 (make-procedure t.7$13 '0))) t.7))
(letrec ((t.8$15 (lambda (cp.16 x.5) (+ x.5 '3))))
(let ((t.8 (make-procedure t.8$15 '0))) t.8)))))
((procedure-code t.17) t.17 '13))))
256最后让我们给出句法的变化.
<exp> ::= (quote <immediate>)
| <uvar>
| <label>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (let ((<uvar> <exp>)*) <exp>)
| (letrec ((<label> (lambda (<uvar> <uvar>*) <exp>))*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp> <exp>*)<prim>也发生了改变, 多了几个过程. 因此, 之后我们判断是否是原语需要使用另外不同的谓词.lift-letreclift-letrec的目的是为了将所有的letrec都提升至顶层, 在一开始分配. 这次的pass也比较简单, 因为所做的事情真的就只是提升letrec. 而之所以可以这么做, 则有赖于之前各种的约简步骤, 并不那么容易说清楚.
(define (lift-letrec exp)
(define (Lam lam k)
(match lam
((lambda ,x* ,body)
(lift body
(lambda (body binding*)
(k `(lambda ,x* ,body)
binding*))))))
(define (Lam* lam* k)
(if (null? lam*)
(k '() '())
(Lam (car lam*)
(lambda (lam binding*0)
(Lam* (cdr lam*)
(lambda (lam* binding*1)
(k (cons lam lam*)
(append binding*0
binding*1))))))))
(define (lift* exp* k)
(if (null? exp*)
(k '() '())
(lift (car exp*)
(lambda (exp binding*0)
(lift* (cdr exp*)
(lambda (exp* binding*1)
(k (cons exp exp*)
(append binding*0
binding*1))))))))老实说, 这些以*为后缀的辅助过程实际上可以利用某种抽象来构造, 但是我又没有什么动力这么做. 当然了, 主要的逻辑还是在以下的lift之中.
(define (lift exp k)
(match exp
((quote ,i) (k exp '()))
;x may be a uvar or a label
(,x (guard (symbol? x)) (k x '()))
((if ,q ,a ,e)
(lift* (cdr exp)
(lambda (exp* binding*)
(k (cons 'if exp*)
binding*))))
((begin . ,exp*)
(lift* exp*
(lambda (exp* binding*)
(k (cons 'begin exp*)
binding*))))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(lift*
e* (lambda (e* binding*0)
(lift body
(lambda (body binding*1)
(k (Let x* e* body)
(append binding*0
binding*1)))))))))
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(Lam*
e* (lambda (e* binding*0)
(lift body
(lambda (body binding*1)
(k body
(append
(map list x* e*)
binding*0
binding*1)))))))))
((,prim . ,rands)
(guard (prim+? prim))
(lift* rands
(lambda (rands binding*)
(k (cons prim rands)
binding*))))
((,label . ,rands)
(guard (label? label))
(lift* rands
(lambda (rands binding*)
(k (cons label rands)
binding*))))
((,rator . ,rands)
(lift* exp k))))
(lift exp
(lambda (exp binding*)
`(letrec ,binding* ,exp))))而lift的主要逻辑又在letrec之中, 这里我们需要小心地将letrec绑定收集起来, 只留下body的部分. 或许注意到letrec是可能嵌套的, 但是当前的处理足够应付嵌套的情况. 预期之中变换后的表达式是不含有letrec的, 而这些letrec的提升在很大程度上依赖于当前的lambda已经没有了自由变量这一事实. 若是还有自由变量, 则会导致作用域的错位. 自由变量的值现在完全是藉由额外的闭包参数显式传递.
现在让我们给出变换后的句法.
<program> ::= (letrec ((<label> (lambda (<uvar> <uvar>*) <exp>))*) <exp>)
<exp> ::= (quote <immediate>)
| <uvar>
| <label>
| (if <exp> <exp> <exp>)
| (begin <exp>+)
| (let ((<uvar> <exp>)*) <exp>)
| (<prim> <exp>*)
| (<exp> <exp> <exp>*)<exp>的复杂度被进一步约简了, 因为现在letrec也没有了, 跑到了顶层, 并且letrec也将lambda带走了. 也就是说, lambda在开头就被确定下来了.让我们来看一些例子.
> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'(letrec ((h.0$8
(lambda (cp.9 fact.4)
(let ((t.6 (make-procedure t.6$10 '1)))
(begin (procedure-set! t.6 '0 fact.4) t.6))))
(t.6$10
(lambda (cp.11 n.5)
(if (= n.5 '0)
'1
(*
n.5
((procedure-code (procedure-ref cp.11 '0))
(procedure-ref cp.11 '0)
(- n.5 '1))))))
(f.1$12
(lambda (cp.13 g.2)
(h.0$8
(procedure-ref cp.13 '0)
(let ((t.7 (make-procedure t.7$14 '1)))
(begin (procedure-set! t.7 '0 g.2) t.7)))))
(t.7$14
(lambda (cp.15 x.3)
(let ((t.16
((procedure-code (procedure-ref cp.15 '0))
(procedure-ref cp.15 '0)
(procedure-ref cp.15 '0))))
((procedure-code t.16) t.16 x.3)))))
(let ((t.17
(let ((h.0 (make-procedure h.0$8 '0)))
(let ((f.1 (make-procedure f.1$12 '1)))
(begin (procedure-set! f.1 '0 h.0) (f.1$12 f.1 f.1))))))
((procedure-code t.17) t.17 '10)))> (letrec ((h.0$8
(lambda (cp.9 fact.4)
(let ((t.6 (make-procedure t.6$10 '1)))
(begin (procedure-set! t.6 '0 fact.4) t.6))))
(t.6$10
(lambda (cp.11 n.5)
(if (= n.5 '0)
'1
(*
n.5
((procedure-code (procedure-ref cp.11 '0))
(procedure-ref cp.11 '0)
(- n.5 '1))))))
(f.1$12
(lambda (cp.13 g.2)
(h.0$8
(procedure-ref cp.13 '0)
(let ((t.7 (make-procedure t.7$14 '1)))
(begin (procedure-set! t.7 '0 g.2) t.7)))))
(t.7$14
(lambda (cp.15 x.3)
(let ((t.16
((procedure-code (procedure-ref cp.15 '0))
(procedure-ref cp.15 '0)
(procedure-ref cp.15 '0))))
((procedure-code t.16) t.16 x.3)))))
(let ((t.17
(let ((h.0 (make-procedure h.0$8 '0)))
(let ((f.1 (make-procedure f.1$12 '1)))
(begin (procedure-set! f.1 '0 h.0) (f.1$12 f.1 f.1))))))
((procedure-code t.17) t.17 '10)))
3628800> (compil
'(let ((even? (void))
(odd? (void)))
(set! even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(set! odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1)))))
(even? 88)))
'(letrec ((t.6$8
(lambda (cp.9 n.2)
(if (= n.2 '0)
'#t
(let ((t.10 (unbox (procedure-ref cp.9 '0))))
((procedure-code t.10) t.10 (- n.2 '1))))))
(t.7$11
(lambda (cp.12 n.3)
(if (= n.3 '0)
'#f
(let ((t.13 (unbox (procedure-ref cp.12 '0))))
((procedure-code t.13) t.13 (- n.3 '1)))))))
(let ((t.5 (void)) (t.4 (void)))
(let ((odd?.1 (box t.5)) (even?.0 (box t.4)))
(begin
(set-box!
even?.0
(let ((t.6 (make-procedure t.6$8 '1))) (begin (procedure-set! t.6 '0 odd?.1) t.6)))
(set-box!
odd?.1
(let ((t.7 (make-procedure t.7$11 '1))) (begin (procedure-set! t.7 '0 even?.0) t.7)))
(let ((t.14 (unbox even?.0))) ((procedure-code t.14) t.14 '88))))))> (letrec ((t.6$8
(lambda (cp.9 n.2)
(if (= n.2 '0)
'#t
(let ((t.10 (unbox (procedure-ref cp.9 '0))))
((procedure-code t.10) t.10 (- n.2 '1))))))
(t.7$11
(lambda (cp.12 n.3)
(if (= n.3 '0)
'#f
(let ((t.13 (unbox (procedure-ref cp.12 '0))))
((procedure-code t.13) t.13 (- n.3 '1)))))))
(let ((t.5 (void)) (t.4 (void)))
(let ((odd?.1 (box t.5)) (even?.0 (box t.4)))
(begin
(set-box!
even?.0
(let ((t.6 (make-procedure t.6$8 '1))) (begin (procedure-set! t.6 '0 odd?.1) t.6)))
(set-box!
odd?.1
(let ((t.7 (make-procedure t.7$11 '1))) (begin (procedure-set! t.7 '0 even?.0) t.7)))
(let ((t.14 (unbox even?.0))) ((procedure-code t.14) t.14 '88))))))
#tnormalize-context对于这个pass, 我们需要区分各种上下文, 然后将程序塑造成合适的形状, 使得每个表达式都各就其位
. 这是迈向语言无关的中间表示的坚实一步. 实际上, 存在着三类上下文:
let绑定的右支诸表达式.if的第一个句法参数.begin之中除了最后一个表达式之外的其他所有表达式.normalize-context的目的. 比如说, 如果(< 3 4)出现在值上下文之中, 那么这个值应该是什么呢? 难道说是#t吗? 问题在于, 这并非语言无关的. 其他语言可能作出了不同的决策, 例如在C语言里的话这个值是1. 当然了, 不论采取哪一种特定的决策, 这都不是语言无关的. 我们希望之后我们的中间表示能够与具体语言进行很好的分离. 那么, 例如在这种情况下, 我们需要显式添加对于谓词的返回值的具体描述.或许我们应该从给出句法开始, 实际上这次的句法比之前要复杂得多.
<program> ::= (letrec ((<label> (lambda (<uvar> <uvar>*) <value>))*) <value>)
<value> ::= (quote <immediate>)
| <uvar>
| <label>
| (if <pred> <value> <value>)
| (begin <effect>* <value>)
| (let ((<uvar> <value>)*) <value>)
| (<value-prim> <value>*)
| (<value> <value> <value>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (let ((<uvar> <value>)*) <pred>)
| (<pred-prim> <value>*)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (let ((<uvar> <value>)*) <effect>)
| (<effect-prim> <value>*)
| (<value> <value> <value>*)新的阶段.
这个句法几乎完全告诉了我们一切关于该怎么编写normalize-context的线索. 实际上, 和之前一样, 我们要做的事情只是遵循句法结构. 对于三个非终结符<value>, <pred>, <effect>, 我们都编制一个对应的过程. 然后, 在这些过程的体中, 需要什么句法就调用什么过程. 当然了, 实际上还有很多细节需要考虑, 但这要我们结合具体的代码来说明.
(define (normalize-context program)
(define (make-begin e* e)
(if (null? e*)
e
`(begin ,@e* ,e)))
(define (make-nopless-begin e* e)
(if (equal? e '(nop))
(make-effect e*)
(let ((e* (remove-all '(nop) e*)))
(make-begin e* e))))
(define (make-pred value)
`(if (eq? ,value '#f) (false) (true)))
(define (make-effect effect*)
(let ((effect* (remove-all '(nop) effect*)))
(cond ((null? effect*) '(nop))
((null? (cdr effect*)) (car effect*))
(else `(begin . ,effect*)))))这是一些预备, 但是现在还不是说明的好时机, 要等待之后遇到了再说明. 不过, 顾名思义, make-pred会构造一个<pred>, 而make-effect会构造一个<effect>. make-begin和make-nopless-begin比较特殊, 它保持参数e的上下文. 这从我们定义的方式中很容易看出来. 然而, 这里和作业所提供的过程不太一样.
(define (make-nopless-begin x*)
(let ([x* (remove '(nop) x*)])
(if (null? x*)
'(nop)
(make-begin x*))))remove和Racket的不太一样, 去除的是所有值, 我这里用的是自己定义的remove-all. 然而, 这是无关紧要的差异, 我想说的其他方面. 一个显眼的差异是作业的版本只有一个参数, 而我分成了两个. 这个差异想必读者容易理解, 因为实际上e*只可能是由<effect>构成的, 而e则随情况而定, 三种可能都有. 作业的版本在某种意义上还要依赖于<value>和<effect>里都不可能出现(nop). 而且, 对于e是(nop)的情况, 作业的版本更像是歪打正着, 即去掉了最后的(nop)也没事, 反正前面还有其他<effect>顶着. 即便都没有了, 我们恰好就是需要<effect>, (nop)还是对的. 至少我不觉得这是正确的态度. 我参考了许多别的人写的答案, 它们在我使用make-effect的地方也使用了make-nopless-begin, 这两个过程的意蕴是不同的. make-effect只是为了根据数个<effect>来复合成一个<effect>. make-nopless-begin则是将数个<effect>和一个具有特定上下文的表达式合成, 并保持后者的上下文. 我觉得我这种做法是更加清晰明确的. (e*更好的名字其实是effect*就是了.) (define (Value exp)
(match exp
((quote ,i) exp)
(,x (guard (symbol? x)) x)
((if ,q ,a ,e)
`(if ,(Pred q)
,(Value a)
,(Value e)))
((begin . ,exp+)
(:begin exp+
(lambda (exp* exp)
(let ((effect* (map Effect exp*))
(value (Value exp)))
(make-nopless-begin effect* value)))))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map Value e*))
(body (Value body)))
(Let x* e* body)))))
((,prim . ,rands)
(guard (prim+? prim))
(define value* (map Value rands))
(define prim-app (cons prim value*))
(cond ((value-prim? prim) prim-app)
((pred-prim? prim)
`(if ,prim-app '#t '#f))
((effect-prim? prim)
`(begin ,prim-app (void)))))
((,rator . ,rands)
(map Value exp))))虽然这里每一行都是逻辑点, 但是最值得注意的大概还是原始应用部分, 而原始应用中最值得注意的大概是意图利用副作用的原语的显式返回值是(void). 当然了, void的确也是值原语.
(define (Pred exp)
(match exp
((quote ,i)
(if (eq? i #f) '(false) '(true)))
(,x (guard (symbol? x)) (make-pred x))
((if ,q ,a ,e)
`(if ,(Pred q)
,(Pred a)
,(Pred e)))
((begin . ,exp+)
(:begin exp+
(lambda (exp* exp)
(let ((effect* (map Effect exp*))
(pred (Pred exp)))
(make-nopless-begin effect* pred)))))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map Value e*))
(body (Pred body)))
(Let x* e* body)))))
((,prim . ,rands)
(guard (prim+? prim))
(define value* (map Value rands))
(define prim-app (cons prim value*))
(cond ((value-prim? prim)
(make-pred prim-app))
((pred-prim? prim) prim-app)
((effect-prim? prim)
`(begin ,prim-app (true)))))
((,rator . ,rands)
(make-pred (map Value exp)))))Pred大体上和Value很类似. 这里最需要注意的大概就是非原始应用无法直接出现在<effect>上下文, 最后挂上(true)即可. 当然了, 就此还有另外的优化空间, 和常量折叠与传播有关. 然而, 我觉得这些也可以放在另外的pass里, 完全不在这里做了.
(define (Effect exp)
(match exp
((quote ,i) '(nop))
(,x (guard (symbol? x)) '(nop))
((if ,q ,a ,e)
`(if ,(Pred q)
,(Effect a)
,(Effect e)))
((begin . ,exp+)
(:begin exp+
(lambda (exp* exp)
(let ((effect* (map Effect exp*))
(effect (Effect exp)))
(make-nopless-begin effect* effect)))))
((let ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map Value e*))
(body (Effect body)))
(Let x* e* body)))))
((,prim . ,rands)
(guard (prim+? prim))
(cond ((value-prim? prim)
(let ((effect* (map Effect rands)))
(make-effect effect*)))
((pred-prim? prim)
(let ((effect* (map Effect rands)))
(make-effect effect*)))
((effect-prim? prim)
(let ((value* (map Value rands)))
(cons prim value*)))))
((,rator . ,rands)
(map Value exp))))Effect最有趣的地方大概是对于原始应用中的值应用和谓词应用, 我们可以直接丢弃结果, 只是利用参数的副作用. 而且, 有的参数毫无副作用, 所以可以直接丢弃. 这的确相当有趣, 然而其实我知道这里我写的东西是成问题的, 而作业对此的描述也是有问题的. 我感觉Kent Dybvig应该知道一点, 但是他只是想让作业简单一些. 然而, 我感觉从我参考的几个人的答案来看, 他们似乎都没有意识到这个问题, 甚至有个人忘了作业里描述的这一茬了, 直接把参数全扔了. 实际上, 这里的问题在于, 值原语和谓词原语在应用的时候也可能抛出异常, 这在实际编译器进行优化的时候是必须考虑进去的事情. 当然了, 作业做了一点简化, 进行了善意推定, 假设程序都是对的, 这种应用不会抛出异常. 我没有选择打破作业要求, 但是我认为这是值得注意的. (上一段我提及的优化其实和这里的如出一辙就是了, 不过那里我已经考虑了这个问题.)
(match program
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(Value body)))))
e*))
(body (Value body)))
(Letrec x* e* body)))))))最后的收尾完全在意料之中. 不过, 或许我们应该注意到, 虽然lambda的体是在值上下文中的, 但是非原始应用也可以出现在副作用的上下文中, 这已经体现在前面Effect的代码之中了.
现在让我们来看一些例子.
> (normalize-context
'(letrec ()
(let ([x.1 '1] [y.2 '2] [a.3 '3] [b.4 '4] [p.5 (cons '#f '#t)])
(begin
(* (begin (set-car! p.5 '#t) x.1) y.2)
(if (if (car p.5) (if (< x.1 y.2) '#f '#t) '17)
(if (= a.3 b.4) '#f '#t)
(<= y.2 x.1))))))
'(letrec ()
(let ((x.1 '1) (y.2 '2) (a.3 '3) (b.4 '4) (p.5 (cons '#f '#t)))
(begin
(set-car! p.5 '#t)
(if (if (if (eq? (car p.5) '#f) (false) (true))
(if (< x.1 y.2) (false) (true))
(true))
(if (= a.3 b.4) '#f '#t)
(if (<= y.2 x.1) '#t '#f)))))这个是作业里的例子.
> (compil '(lambda (x) (not x)))
'(letrec ((t.1$2 (lambda (cp.3 x.0) (if (if (eq? x.0 '#f) (false) (true)) '#f '#t))))
(let ((t.1 (make-procedure t.1$2 '0))) t.1))> (compil '(lambda (x) (if x 1)))
'(letrec ((t.1$2
(lambda (cp.3 x.0) (if (if (eq? x.0 '#f) (false) (true)) '1 (void)))))
(let ((t.1 (make-procedure t.1$2 '0))) t.1))> (compil
'(begin (void) 1 (void) 2 (void) 3))
'(letrec () '3)> (compil
'(letrec ((even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1))))))
(even? 88)))
'(letrec ((odd?.1$4
(lambda (cp.6 n.3)
(if (= n.3 '0) '#f (even?.0$5 (procedure-ref cp.6 '0) (- n.3 '1)))))
(even?.0$5
(lambda (cp.7 n.2)
(if (= n.2 '0) '#t (odd?.1$4 (procedure-ref cp.7 '0) (- n.2 '1))))))
(let ((odd?.1 (make-procedure odd?.1$4 '1))
(even?.0 (make-procedure even?.0$5 '1)))
(begin
(procedure-set! odd?.1 '0 even?.0)
(procedure-set! even?.0 '0 odd?.1)
(even?.0$5 even?.0 '88))))写得正常
的程序, normalize-context就没什么事情可做.
> (compil
'(lambda (x)
(< x 3) x))
'(letrec ((t.1$2 (lambda (cp.3 x.0) x.0)))
(let ((t.1 (make-procedure t.1$2 '0))) t.1))这个转换严格说来的确就不太对, 直接抛弃了潜在可能出现异常的(< x 3).
或许最后提点无聊的事情, 作业里说(void)在副作用上下文中会变成(nop), 这实际上不需要特殊处理, 因为这是将void视为值原语的自然结果.
specify-representationspecify-representation的目的在于选取一种对于值 (也称对象) 的特定的表示 (或者说编码) 方式, 然后将原语转换为低级的内存操作. 鉴于Scheme是一个动态定型的编程语言, 这种编码需要在运行时带上标记 (tag). 标记的选取通常来说具有一定的任意性, 但是也存在着一些巧思可以优化性能. 在概念上, 值(对象)是一个(带标记的)引用. 不过, 所谓的立即值 (immediate) 可以直接在这个引用里被编码. 然而, 这应该更多地被视为实现相关的想法.
内存操作是以下三种:
(alloc ): 分配个字节, 然后返回起始的地址.(mref ): 获取内存位置在处起的值 (从概念上来说, 是一个64位的数码).(mset! ): 设置内存位置自处起的值为.定长数 (fixnum) 的标记是000. 换言之, 我们有61个位来表示整数值, 然后这个值会被左移3位, 或者说乘上8. 选000作为标记对于fixnum这个类型的运算会比较便利. +和-不需要额外调整, *需要适当地给其中一个参数施行算术右移3位. 选取000作为标记还有一个好处, 那么就是对于向量之类的需要按位置索引的数据结构, 原本的数字就乘上了8, 恰好相当于64位, 所以也无需额外的调整.
(define $false #b00000110)
(define $true #b00001110)
(define $nil #b00010110)
(define $void #b00011110)
(define tag:fixnum #b000)
(define tag:pair #b001)
(define tag:procedure #b010)
(define tag:box #b011)
(define tag:vector #b111)110拿出来用于表示几个常量.将原语转换为内存操作其实没有什么技巧, 只是要确实地想明白到底做了什么. 比如说, 对于一个序对, 我们需要分配16个字节, 其实就是两个64位, 一个是car部分, 一个是cdr部分. 而在对于序对的表示里, 我们只需要指向car部分即可, cdr部分可以根据car的实际地址加上8得到, 因为是连续分配的. 为了取得一个序对的car部分, 只需要给序对的编码减去序对的标记就可以得到实际地址. cdr部分如前所述就是再加上8而已. set-car!和set-cdr!也是类似的, 只是被转换为了mset!而非mref. 其他的数据类型的操作基本上也遵循着类似的模式, 只不过可能需要分配的内存空间是不定的, 需要进行计算. 索引的位置也需要根据实际情况进行计算.
对于数据类型谓词的处理有另外的套路, 其实就是通过logand和某个掩码 (mask) 来得到其标记. boolean?这个谓词有点特殊, 需要ad hoc的处理方式.
(define mask:boolean #b11110111)
(define tag:boolean #b00000110)111, 配合之前已经定义了的标记使用. 对于算术谓词无需额外处理, 而eq?其实只是指针比较, 所以转换为=即可. (define Value-prim
(case-lambda
((void) $void)
((uop x)
(case uop
((car) `(mref ,x ,(- offset:car tag:pair)))
((cdr) `(mref ,x ,(- offset:cdr tag:pair)))
((make-vector)
(define vect (unique-symbol 'vec))
(cond ((number? x)
`(let ((,vect (+ (alloc ,(+ offset:vector-data x)) ,tag:vector)))
(begin
(mset! ,vect ,(- offset:vector-length tag:vector) ,x)
,vect)))
((symbol? x)
`(let ((,vect (+ (alloc (+ ,offset:vector-data ,x)) ,tag:vector)))
(begin
(mset! ,vect ,(- offset:vector-length tag:vector) ,x)
,vect)))
(else
(let ((lent (unique-symbol 'len)))
`(let ((,lent ,x))
(let ((,vect (+ (alloc (+ ,offset:vector-data ,lent)) ,tag:vector)))
(begin
(mset! ,vect ,(- offset:vector-length tag:vector) ,lent)
,vect)))))))
((vector-length)
`(mref ,x ,(- offset:vector-length tag:vector)))
((box)
(define boxt (unique-symbol 'box))
`(let ((,boxt (+ (alloc ,size:box) ,tag:box)))
(begin
(mset! ,boxt ,(- offset:box tag:box) ,x)
,boxt)))
((unbox)
`(mref ,x ,(- offset:box tag:box)))
((procedure-code)
`(mref ,x ,(- offset:procedure-code tag:procedure)))))
((binop x y)
(case binop
((+) (if (and (number? x) (number? y))
(+ x y)
`(+ ,x ,y)))
((-) (if (and (number? x) (number? y))
(- x y)
`(- ,x ,y)))
((*) (cond ((and (number? x) (number? y))
(* x (sra y 3)))
((number? x) `(* ,(sra x 3) ,y))
((number? y) `(* ,x ,(sra y 3)))
(else `(* ,x (sra ,y 3)))))
((cons)
(define pairt (unique-symbol 'pair))
`(let ((,pairt (+ (alloc ,size:pair) ,tag:pair)))
(begin
(mset! ,pairt ,(- offset:car tag:pair) ,x)
(mset! ,pairt ,(- offset:cdr tag:pair) ,y)
,pairt)))
((vector-ref)
(if (number? y)
`(mref ,x ,(+ (- offset:vector-data tag:vector) y))
`(mref ,x (+ ,(- offset:vector-data tag:vector) ,y))))
((make-procedure)
(define proct (unique-symbol 'proc))
(if (and (label? x) (number? y))
`(let ((,proct (+ (alloc ,(+ offset:procedure-data y)) ,tag:procedure)))
(begin
(mset! ,proct ,(- offset:procedure-code tag:procedure) ,x)
,proct))
(error 'specify-representation
"the arguments of make-procedure should be known at compile time")))
((procedure-ref)
(if (number? y)
`(mref ,x ,(+ (- offset:procedure-data tag:procedure) y))
(error 'specify-representation
"procedure-ref: the loc of free var should be known at compile time")))))))
(define Pred-prim
(case-lambda
((predicate x)
(define (make-pred mask tag)
`(= (logand ,x ,mask) ,tag))
(case predicate
((null?) `(= ,x ,$nil))
((boolean?) (make-pred mask:boolean tag:boolean))
((fixnum?) (make-pred mask:fixnum tag:fixnum))
((pair?) (make-pred mask:pair tag:pair))
((vector?) (make-pred mask:vector tag:vector))
((box?) (make-pred mask:box tag:box))
((procedure?) (make-pred mask:procedure tag:procedure))))
((compare x y)
(case compare
((eq?) `(= ,x ,y))
(else `(,compare ,x ,y))))))
(define Effect-prim
(case-lambda
((set obj val)
(case set
((set-car!)
`(mset! ,obj ,(- offset:car tag:pair) ,val))
((set-cdr!)
`(mset! ,obj ,(- offset:cdr tag:pair) ,val))
((set-box!)
`(mset! ,obj ,(- offset:box tag:box) ,val))))
((set obj loc val)
(case set
((vector-set!)
(if (number? loc)
`(mset! ,obj ,(+ (- offset:vector-data tag:vector) loc) ,val)
`(mset! ,obj (+ ,(- offset:vector-data tag:vector) ,loc) ,val)))
((procedure-set!)
(if (number? loc)
`(mset! ,obj ,(+ (- offset:procedure-data tag:procedure) loc) ,val)
(error 'specify-representation
"procedure-set!: the loc of free var should be known at compile time")))))))对于原语的处理是这次pass的核心, 也就是以上所呈现的内容了. 其实里面有的转换没有那么符合Scheme的语义, 比如说对于box的处理, 其实我们应该先对于参数求值, 然后再分配, 而不是像现在这样先分配, 再对参数求值. 不过, 对于当前的Scheme子集而言, 其实两者没什么区别. 也有其他的地方需要特别注意, 比如说对于make-vector的处理, 其参数在为数字或符号的时候有较简单的处理方式, 而在其他一般情况下我们一定要添加let绑定来避免对于其参数进行重复求值, 其中一个直接的原因在于参数可能包含副作用. (实际上, 我参考的三份作业答案里, 只有王垠意识到了这件事情, 其他两个人这里写的都是错的.) 老实说, 这里对于算术的处理有点粗糙, 没有考虑溢出之类的情况, 所以并不能保证在任何时候都正确, 但是我们暂时就满足于这样的处理了, 之后可能会加以改进.
(define (specify-representation program)
(define Value-prim
(case-lambda
((void) $void)
((uop x)
(case uop
((car) `(mref ,x ,(- offset:car tag:pair)))
((cdr) `(mref ,x ,(- offset:cdr tag:pair)))
((make-vector)
(define vect (unique-symbol 'vec))
(cond ((number? x)
`(let ((,vect (+ (alloc ,(+ offset:vector-data x)) ,tag:vector)))
(begin
(mset! ,vect ,(- offset:vector-length tag:vector) ,x)
,vect)))
((symbol? x)
`(let ((,vect (+ (alloc (+ ,offset:vector-data ,x)) ,tag:vector)))
(begin
(mset! ,vect ,(- offset:vector-length tag:vector) ,x)
,vect)))
(else
(let ((lent (unique-symbol 'len)))
`(let ((,lent ,x))
(let ((,vect (+ (alloc (+ ,offset:vector-data ,lent)) ,tag:vector)))
(begin
(mset! ,vect ,(- offset:vector-length tag:vector) ,lent)
,vect)))))))
((vector-length)
`(mref ,x ,(- offset:vector-length tag:vector)))
((box)
(define boxt (unique-symbol 'box))
`(let ((,boxt (+ (alloc ,size:box) ,tag:box)))
(begin
(mset! ,boxt ,(- offset:box tag:box) ,x)
,boxt)))
((unbox)
`(mref ,x ,(- offset:box tag:box)))
((procedure-code)
`(mref ,x ,(- offset:procedure-code tag:procedure)))))
((binop x y)
(case binop
((+) (if (and (number? x) (number? y))
(+ x y)
`(+ ,x ,y)))
((-) (if (and (number? x) (number? y))
(- x y)
`(- ,x ,y)))
((*) (cond ((and (number? x) (number? y))
(* x (sra y 3)))
((number? x) `(* ,(sra x 3) ,y))
((number? y) `(* ,x ,(sra y 3)))
(else `(* ,x (sra ,y 3)))))
((cons)
(define pairt (unique-symbol 'pair))
`(let ((,pairt (+ (alloc ,size:pair) ,tag:pair)))
(begin
(mset! ,pairt ,(- offset:car tag:pair) ,x)
(mset! ,pairt ,(- offset:cdr tag:pair) ,y)
,pairt)))
((vector-ref)
(if (number? y)
`(mref ,x ,(+ (- offset:vector-data tag:vector) y))
`(mref ,x (+ ,(- offset:vector-data tag:vector) ,y))))
((make-procedure)
(define proct (unique-symbol 'proc))
(if (and (label? x) (number? y))
`(let ((,proct (+ (alloc ,(+ offset:procedure-data y)) ,tag:procedure)))
(begin
(mset! ,proct ,(- offset:procedure-code tag:procedure) ,x)
,proct))
(error 'specify-representation
"the arguments of make-procedure should be known at compile time")))
((procedure-ref)
(if (number? y)
`(mref ,x ,(+ (- offset:procedure-data tag:procedure) y))
(error 'specify-representation
"procedure-ref: the loc of free var should be known at compile time")))))))
(define Pred-prim
(case-lambda
((predicate x)
(define (make-pred mask tag)
`(= (logand ,x ,mask) ,tag))
(case predicate
((null?) `(= ,x ,$nil))
((boolean?) (make-pred mask:boolean tag:boolean))
((fixnum?) (make-pred mask:fixnum tag:fixnum))
((pair?) (make-pred mask:pair tag:pair))
((vector?) (make-pred mask:vector tag:vector))
((box?) (make-pred mask:box tag:box))
((procedure?) (make-pred mask:procedure tag:procedure))))
((compare x y)
(case compare
((eq?) `(= ,x ,y))
(else `(,compare ,x ,y))))))
(define Effect-prim
(case-lambda
((set obj val)
(case set
((set-car!)
`(mset! ,obj ,(- offset:car tag:pair) ,val))
((set-cdr!)
`(mset! ,obj ,(- offset:cdr tag:pair) ,val))
((set-box!)
`(mset! ,obj ,(- offset:box tag:box) ,val))))
((set obj loc val)
(case set
((vector-set!)
(if (number? loc)
`(mset! ,obj ,(+ (- offset:vector-data tag:vector) loc) ,val)
`(mset! ,obj (+ ,(- offset:vector-data tag:vector) ,loc) ,val)))
((procedure-set!)
(if (number? loc)
`(mset! ,obj ,(+ (- offset:procedure-data tag:procedure) loc) ,val)
(error 'specify-representation
"procedure-set!: the loc of free var should be known at compile time")))))))
(define (If Context pred e1 e2)
`(if ,(Pred pred)
,(Context e1)
,(Context e2)))
(define (Begin Context exp+)
(:begin exp+
(lambda (exp* exp)
(let ((exp* (map Effect exp*))
(exp (Context exp)))
(make-begin exp* exp)))))
(define (Leto Context bds body)
(: bds
(lambda (x* e*)
(let ((e* (map Value e*))
(body (Context body)))
(Let x* e* body)))))
(define (Value value)
(match value
((quote ,i)
(cond ((eq? i #f) $false)
((eq? i #t) $true)
((eq? i '()) $nil)
(else (ash i shift-fixnum))))
(,x (guard (symbol? x)) x)
((if ,pred ,v1 ,v2) (If Value pred v1 v2))
((begin . ,exp+) (Begin Value exp+))
((let ,bds ,body) (Leto Value bds body))
((,value-prim . ,rands)
(guard (value-prim? value-prim))
(apply Value-prim
value-prim
(map Value rands)))
((,rator . ,rands)
(map Value value))))
(define (Pred pred)
(match pred
((true) '(true))
((false) '(false))
((if ,p1 ,p2 ,p3) (If Pred p1 p2 p3))
((begin . ,exp+) (Begin Pred exp+))
((let ,bds ,body) (Leto Pred bds body))
((,pred-prim . ,rands)
(guard (pred-prim? pred-prim))
(apply Pred-prim
pred-prim
(map Value rands)))))
(define (Effect effect)
(match effect
((nop) '(nop))
((if ,pred ,e1 ,e2) (If Effect pred e1 e2))
((begin . ,exp+) (Begin Effect exp+))
((let ,bds ,body) (Leto Effect bds body))
((,effect-prim . ,rands)
(guard (effect-prim? effect-prim))
(apply Effect-prim
effect-prim
(map Value rands)))
((,rator . ,rands)
(map Value effect))))
(match program
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(Value body)))))
e*))
(body (Value body)))
(Letrec x* e* body)))))))以上则是完整的代码, 不过代码的其他地方从某种意义上说都挺无聊的.
现在让我们给出输出语言的句法.
<program> ::= (letrec ((<label> (lambda (<uvar> <uvar>*) <value>))*) <value>)
<value> ::= <triv>
| (if <pred> <value> <value>)
| (begin <effect>* <value>)
| (let ((<uvar> <value>)*) <value>)
| (alloc <value>)
| (mref <value> <value>)
| (<binop> <value> <value>)
| (<value> <value> <value>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (let ((<uvar> <value>)*) <pred>)
| (<relop> <value> <value>)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (let ((<uvar> <value>)*) <effect>)
| (mset! <value> <value> <value>)
| (<value> <value> <value>*)
<triv> ::= <int> | <uvar> | <label>
<binop> ::= + | - | * | sra | logand
<relop> ::= = | < | > | <= | >=<binop>以及<relop>.让我们再来看一些例子. 正如之前所言, Kent Dybvig故意将句法安排得近于Scheme, 以使得在某种程度上验证可以变得稍微容易一点 (其实不符合do the right thing
的精神). 为此, 我们需要补充几个过程, 不过这些过程也写得很粗糙, 只适用于排除非常明显
的错误. (不过, 实际上这些过程在我编写pass时的确很有用.)
(define (true) #t)
(define (false) #f)
(define (nop) (void))
(define *memory* (make-vector 1000))
(define allocated 0)
(define (alloc size)
(if (and (>= size 0) (= (modulo size 8) 0))
(let ((address allocated))
(set! allocated (+ allocated (quotient size 8)))
(* address 8))
(error 'alloc "invalid size")))
(define (mset! index offset value)
(unless (or (procedure? value) (int64? value))
(error 'mset! "value must be a 64-bit fixnum"))
(let ((x (+ index offset)))
(if (and (>= x 0) (= (modulo x 8) 0))
(let ((actual (quotient x 8)))
(if (< actual allocated)
(vector-set! *memory* actual value)
(error 'mset! "try to access unallocated memory")))
(error 'mset! "invalid arguments:\nindex: ~s\noffset: ~s" index offset))))
(define (mref index offset)
(let ((x (+ index offset)))
(if (and (>= x 0) (= (modulo x 8) 0))
(let ((actual (quotient x 8)))
(if (< actual allocated)
(vector-ref *memory* actual)
(error 'mref "try to access unallocated memory")))
(error 'mref "invalid arguments"))))
(define (get-result encoding)
(case (logand encoding #b111)
((#b000) (sra encoding 3))
((#b001) (cons (get-result (mref encoding (- offset:car tag:pair)))
(get-result (mref encoding (- offset:cdr tag:pair)))))
((#b010) '<procedure>)
((#b011) (box (get-result (mref encoding (- offset:box tag:box)))))
((#b110) (cond ((= encoding $false) #f)
((= encoding $true) #t)
((= encoding $nil) '())
((= encoding $void) (void))))
((#b111)
(let ((len (get-result
(mref encoding (- offset:vector-length tag:vector)))))
(let iter ((i len) (result* '()))
(if (= i 0)
(apply vector result*)
(iter (- i 1)
(cons (get-result
(mref encoding (- (* 8 i) tag:vector)))
result*))))))
(else (error 'get-result "unknown encoding ~s" encoding))))get-result是用来将编码转换为可读的Scheme值的.好了, 让我们开始呈现实际的例子.
> (compil
'(letrec ((enum (lambda (a b)
(if (> a b)
'()
(cons a (enum (+ a 1) b)))))
(map (lambda (proc lst)
(if (null? lst)
'()
(cons (proc (car lst))
(map proc (cdr lst)))))))
(map (lambda (x) (* x x)) (enum 1 20))))
'(letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(if (= lst.5 22)
22
(let ((pair.14 (+ (alloc 16) 1)))
(begin
(mset! pair.14 -1 ((mref proc.4 -2) proc.4 (mref lst.5 -1)))
(mset! pair.14 7 (map.1$8 (mref cp.10 6) proc.4 (mref lst.5 7)))
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(if (> a.2 b.3)
22
(let ((pair.15 (+ (alloc 16) 1)))
(begin
(mset! pair.15 -1 a.2)
(mset! pair.15 7 (enum.0$9 (mref cp.11 6) (+ a.2 8) b.3))
pair.15)))))
(t.7$12 (lambda (cp.13 x.6) (* x.6 (sra x.6 3)))))
(let ((map.1 (let ((proc.16 (+ (alloc 16) 2))) (begin (mset! proc.16 -2 map.1$8) proc.16)))
(enum.0 (let ((proc.17 (+ (alloc 16) 2))) (begin (mset! proc.17 -2 enum.0$9) proc.17))))
(begin
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(map.1$8
map.1
(let ((t.7 (let ((proc.18 (+ (alloc 8) 2))) (begin (mset! proc.18 -2 t.7$12) proc.18)))) t.7)
(enum.0$9 enum.0 8 160)))))
> (letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(if (= lst.5 22)
22
(let ((pair.14 (+ (alloc 16) 1)))
(begin
(mset! pair.14 -1 ((mref proc.4 -2) proc.4 (mref lst.5 -1)))
(mset! pair.14 7 (map.1$8 (mref cp.10 6) proc.4 (mref lst.5 7)))
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(if (> a.2 b.3)
22
(let ((pair.15 (+ (alloc 16) 1)))
(begin
(mset! pair.15 -1 a.2)
(mset! pair.15 7 (enum.0$9 (mref cp.11 6) (+ a.2 8) b.3))
pair.15)))))
(t.7$12 (lambda (cp.13 x.6) (* x.6 (sra x.6 3)))))
(let ((map.1 (let ((proc.16 (+ (alloc 16) 2))) (begin (mset! proc.16 -2 map.1$8) proc.16)))
(enum.0 (let ((proc.17 (+ (alloc 16) 2))) (begin (mset! proc.17 -2 enum.0$9) proc.17))))
(begin
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(map.1$8
map.1
(let ((t.7 (let ((proc.18 (+ (alloc 8) 2))) (begin (mset! proc.18 -2 t.7$12) proc.18)))) t.7)
(enum.0$9 enum.0 8 160)))))
361
> (get-result 361)
'(1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400)这是第一个例子.
> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'(letrec ((h.0$8
(lambda (cp.9 fact.4)
(let ((t.6 (let ((proc.18 (+ (alloc 16) 2))) (begin (mset! proc.18 -2 t.6$10) proc.18))))
(begin (mset! t.6 6 fact.4) t.6))))
(t.6$10
(lambda (cp.11 n.5)
(if (= n.5 0) 8 (* n.5 (sra ((mref (mref cp.11 6) -2) (mref cp.11 6) (- n.5 8)) 3)))))
(f.1$12
(lambda (cp.13 g.2)
(h.0$8
(mref cp.13 6)
(let ((t.7
(let ((proc.19 (+ (alloc 16) 2))) (begin (mset! proc.19 -2 t.7$14) proc.19))))
(begin (mset! t.7 6 g.2) t.7)))))
(t.7$14
(lambda (cp.15 x.3)
(let ((t.16 ((mref (mref cp.15 6) -2) (mref cp.15 6) (mref cp.15 6))))
((mref t.16 -2) t.16 x.3)))))
(let ((t.17
(let ((h.0 (let ((proc.20 (+ (alloc 8) 2))) (begin (mset! proc.20 -2 h.0$8) proc.20))))
(let ((f.1 (let ((proc.21 (+ (alloc 16) 2))) (begin (mset! proc.21 -2 f.1$12) proc.21))))
(begin (mset! f.1 6 h.0) (f.1$12 f.1 f.1))))))
((mref t.17 -2) t.17 80)))
> (letrec ((h.0$8
(lambda (cp.9 fact.4)
(let ((t.6 (let ((proc.18 (+ (alloc 16) 2))) (begin (mset! proc.18 -2 t.6$10) proc.18))))
(begin (mset! t.6 6 fact.4) t.6))))
(t.6$10
(lambda (cp.11 n.5)
(if (= n.5 0) 8 (* n.5 (sra ((mref (mref cp.11 6) -2) (mref cp.11 6) (- n.5 8)) 3)))))
(f.1$12
(lambda (cp.13 g.2)
(h.0$8
(mref cp.13 6)
(let ((t.7
(let ((proc.19 (+ (alloc 16) 2))) (begin (mset! proc.19 -2 t.7$14) proc.19))))
(begin (mset! t.7 6 g.2) t.7)))))
(t.7$14
(lambda (cp.15 x.3)
(let ((t.16 ((mref (mref cp.15 6) -2) (mref cp.15 6) (mref cp.15 6))))
((mref t.16 -2) t.16 x.3)))))
(let ((t.17
(let ((h.0 (let ((proc.20 (+ (alloc 8) 2))) (begin (mset! proc.20 -2 h.0$8) proc.20))))
(let ((f.1 (let ((proc.21 (+ (alloc 16) 2))) (begin (mset! proc.21 -2 f.1$12) proc.21))))
(begin (mset! f.1 6 h.0) (f.1$12 f.1 f.1))))))
((mref t.17 -2) t.17 80)))
29030400
> (get-result 29030400)
3628800这是第二个例子.
> (compil
'(let ((even? (void))
(odd? (void)))
(set! even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(set! odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1)))))
(even? 88)))
'(letrec ((t.6$8
(lambda (cp.9 n.2)
(if (= n.2 0)
14
(let ((t.10 (mref (mref cp.9 6) -3))) ((mref t.10 -2) t.10 (- n.2 8))))))
(t.7$11
(lambda (cp.12 n.3)
(if (= n.3 0)
6
(let ((t.13 (mref (mref cp.12 6) -3))) ((mref t.13 -2) t.13 (- n.3 8)))))))
(let ((t.5 30) (t.4 30))
(let ((odd?.1 (let ((box.15 (+ (alloc 8) 3))) (begin (mset! box.15 -3 t.5) box.15)))
(even?.0 (let ((box.16 (+ (alloc 8) 3))) (begin (mset! box.16 -3 t.4) box.16))))
(begin
(mset!
even?.0
-3
(let ((t.6 (let ((proc.17 (+ (alloc 16) 2))) (begin (mset! proc.17 -2 t.6$8) proc.17))))
(begin (mset! t.6 6 odd?.1) t.6)))
(mset!
odd?.1
-3
(let ((t.7 (let ((proc.18 (+ (alloc 16) 2))) (begin (mset! proc.18 -2 t.7$11) proc.18))))
(begin (mset! t.7 6 even?.0) t.7)))
(let ((t.14 (mref even?.0 -3))) ((mref t.14 -2) t.14 704))))))
> (letrec ((t.6$8
(lambda (cp.9 n.2)
(if (= n.2 0)
14
(let ((t.10 (mref (mref cp.9 6) -3))) ((mref t.10 -2) t.10 (- n.2 8))))))
(t.7$11
(lambda (cp.12 n.3)
(if (= n.3 0)
6
(let ((t.13 (mref (mref cp.12 6) -3))) ((mref t.13 -2) t.13 (- n.3 8)))))))
(let ((t.5 30) (t.4 30))
(let ((odd?.1 (let ((box.15 (+ (alloc 8) 3))) (begin (mset! box.15 -3 t.5) box.15)))
(even?.0 (let ((box.16 (+ (alloc 8) 3))) (begin (mset! box.16 -3 t.4) box.16))))
(begin
(mset!
even?.0
-3
(let ((t.6 (let ((proc.17 (+ (alloc 16) 2))) (begin (mset! proc.17 -2 t.6$8) proc.17))))
(begin (mset! t.6 6 odd?.1) t.6)))
(mset!
odd?.1
-3
(let ((t.7 (let ((proc.18 (+ (alloc 16) 2))) (begin (mset! proc.18 -2 t.7$11) proc.18))))
(begin (mset! t.7 6 even?.0) t.7)))
(let ((t.14 (mref even?.0 -3))) ((mref t.14 -2) t.14 704))))))
14
> (get-result 14)
#t这是第三个例子.
> (compil
'(let ((x 0) (y 1) (z 2))
(let ((counter (lambda ()
(set! x (+ x 1))
(set! z (+ z 2))
(cons x z))))
(counter)
(counter)
(counter))))
'(letrec ((counter.3$6
(lambda (cp.7)
(begin
(mset! (mref cp.7 6) -3 (+ (mref (mref cp.7 6) -3) 8))
(mset! (mref cp.7 14) -3 (+ (mref (mref cp.7 14) -3) 16))
(let ((pair.8 (+ (alloc 16) 1)))
(begin
(mset! pair.8 -1 (mref (mref cp.7 6) -3))
(mset! pair.8 7 (mref (mref cp.7 14) -3))
pair.8))))))
(let ((t.5 16) (y.1 8) (t.4 0))
(let ((z.2 (let ((box.9 (+ (alloc 8) 3))) (begin (mset! box.9 -3 t.5) box.9)))
(x.0 (let ((box.10 (+ (alloc 8) 3))) (begin (mset! box.10 -3 t.4) box.10))))
(let ((counter.3
(let ((proc.11 (+ (alloc 24) 2))) (begin (mset! proc.11 -2 counter.3$6) proc.11))))
(begin
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))))
> (letrec ((counter.3$6
(lambda (cp.7)
(begin
(mset! (mref cp.7 6) -3 (+ (mref (mref cp.7 6) -3) 8))
(mset! (mref cp.7 14) -3 (+ (mref (mref cp.7 14) -3) 16))
(let ((pair.8 (+ (alloc 16) 1)))
(begin
(mset! pair.8 -1 (mref (mref cp.7 6) -3))
(mset! pair.8 7 (mref (mref cp.7 14) -3))
pair.8))))))
(let ((t.5 16) (y.1 8) (t.4 0))
(let ((z.2 (let ((box.9 (+ (alloc 8) 3))) (begin (mset! box.9 -3 t.5) box.9)))
(x.0 (let ((box.10 (+ (alloc 8) 3))) (begin (mset! box.10 -3 t.4) box.10))))
(let ((counter.3
(let ((proc.11 (+ (alloc 24) 2))) (begin (mset! proc.11 -2 counter.3$6) proc.11))))
(begin
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))))
73
> (get-result 73)
'(3 . 8)这是第四个例子.
uncover-localsuncover-locals是比较简单的, 因为它只是搜集被let所绑定的变量. 存在着两种直接的实现策略, 一种是返回多值, 另一种是使用副作用. 我使用了前者, 而没有实现后者, 不过显然后者代码应该要简单很多.
这个pass的输出句法为
<program> ::= (letrec ((<label> (lambda (<uvar> <uvar>*) <body>))*) <body>)
<value> ::= <triv>
| (if <pred> <value> <value>)
| (begin <effect>* <value>)
| (let ((<uvar> <value>)*) <value>)
| (alloc <value>)
| (mref <value> <value>)
| (<binop> <value> <value>)
| (<value> <value> <value>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (let ((<uvar> <value>)*) <pred>)
| (<relop> <value> <value>)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (let ((<uvar> <value>)*) <effect>)
| (mset! <value> <value> <value>)
| (<value> <value> <value>*)
<body> ::= (locals (<uvar>*) <value>)
<triv> ::= <int> | <uvar> | <label>
<binop> ::= + | - | * | sra | logand
<relop> ::= = | < | > | <= | >=locals形式用于放置搜集到的变量. 实际上, 其余部分不应该发生任何变化.(define (uncover-locals program)
(define (make-begin exp* exp)
`(begin ,@exp* ,exp))
(define (If Context pred e1 e2 k)
(Pred
pred
(lambda (pred a*)
(Context
e1
(lambda (e1 b*)
(Context
e2
(lambda (e2 c*)
(k `(if ,pred ,e1 ,e2)
(append a* b* c*)))))))))
(define (Begin Context exp+ k)
(:begin exp+
(lambda (exp* exp)
(Effect*
exp*
(lambda (exp* a*)
(Context
exp
(lambda (exp b*)
(k (make-begin exp* exp)
(append a* b*)))))))))
(define (Leto Context bds body k)
(: bds
(lambda (x* e*)
(Value*
e*
(lambda (e* a*)
(Context
body
(lambda (body b*)
(k (Let x* e* body)
(append x* a* b*)))))))))
(define (Op k op . v*)
(Value* v* (lambda (v* a*)
(k (cons op v*) a*))))
(define (Value value k)
(match value
(,triv
(guard (not (pair? triv)))
(k triv '()))
((if ,pred ,v1 ,v2) (If Value pred v1 v2 k))
((begin . ,exp+) (Begin Value exp+ k))
((let ,bds ,body) (Leto Value bds body k))
((alloc ,v) (Op k 'alloc v))
((mref ,v1 ,v2) (Op k 'mref v1 v2))
((,binop ,v1 ,v2)
(guard (binop? binop))
(Op k binop v1 v2))
((,rator . ,rands) (Value* value k))))
(define (Pred pred k)
(match pred
((true) (k '(true) '()))
((false) (k '(false) '()))
((if ,p1 ,p2 ,p3) (If Pred p1 p2 p3 k))
((begin . ,exp+) (Begin Pred exp+ k))
((let ,bds ,body) (Leto Pred bds body k))
((,relop ,v1 ,v2)
(guard (relop? relop))
(Op k relop v1 v2))))
(define (Effect effect k)
(match effect
((nop) (k '(nop) '()))
((if ,pred ,e1 ,e2) (If Effect pred e1 e2 k))
((begin . ,exp+) (Begin Effect exp+ k))
((let ,bds ,body) (Leto Effect bds body k))
((mset! ,v1 ,v2 ,v3) (Op k 'mset! v1 v2 v3))
((,rator . ,rands) (Value* effect k))))
(define Value* (make-proc* Value append))
(define Effect* (make-proc* Effect append))
(define (make-body value)
(Value value
(lambda (value a*)
`(locals ,a* ,value))))
(match program
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(make-body body)))))
e*))
(body (make-body body)))
(Letrec x* e* body)))))))因为这次的代码没有任何难度, 我就直接放在这里了. 注意到我们使用了append而非U来合并变量集, 鉴于这些变量实际上只可能在let的左支里出现一次.
这次也没有例子, 因为我们感觉例子并不需要.
remove-let顾名思义, remove-let将所有的let都去除了, 转换为了等价的set!形式 这个pass在很大程度上依赖于parse-scheme所施行的变换, 不过就此方面其他绝大多数pass也是一样的.
鉴于我们之前已经在赋值变换中去除了set!形式, 所以说在remove-let之后, 对于每个变量也只会有单次赋值.
让我们先给出句法.
<program> ::= (letrec ((<label> (lambda (<uvar> <uvar>*) <body>))*) <body>)
<value> ::= <triv>
| (if <pred> <value> <value>)
| (begin <effect>* <value>)
| (alloc <value>)
| (mref <value> <value>)
| (<binop> <value> <value>)
| (<value> <value> <value>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (<relop> <value> <value>)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (set! <uvar> <value>)
| (mset! <value> <value> <value>)
| (<value> <value> <value>*)
<body> ::= (locals (<uvar>*) <value>)
<triv> ::= <int> | <uvar> | <label>
<binop> ::= + | - | * | sra | logand
<relop> ::= = | < | > | <= | >=let消失了, 而<effect>的产生式里多了一个set!形式.(define (remove-let program)
(define (If Context pred e1 e2)
`(if ,(Pred pred) ,(Context e1) ,(Context e2)))
(define (Begin Context exp+)
(:begin exp+
(lambda (exp* exp)
(let ((exp* (map Effect exp*))
(exp (Context exp)))
(make-begin exp* exp)))))
(define (Leto Context bds body)
(: bds
(lambda (x* e*)
(let ((e* (map Value e*))
(body (Context body)))
(make-begin
(map (lambda (x e)
`(set! ,x ,e))
x* e*)
body)))))
(define (Op op . v*)
(cons op (map Value v*)))
(define (Value value)
(match value
(,triv (guard (not (pair? triv))) triv)
((if ,pred ,v1 ,v2) (If Value pred v1 v2))
((begin . ,exp+) (Begin Value exp+))
((let ,bds ,body) (Leto Value bds body))
((alloc ,v) (Op 'alloc v))
((mref ,v1 ,v2) (Op 'mref v1 v2))
((,binop ,v1 ,v2)
(guard (binop? binop))
(Op binop v1 v2))
((,rator . ,rands) (map Value value))))
(define (Pred pred)
(match pred
((true) '(true))
((false) '(false))
((if ,p1 ,p2 ,p3) (If Pred p1 p2 p3))
((begin . ,exp+) (Begin Pred exp+))
((let ,bds ,body) (Leto Pred bds body))
((,relop ,v1 ,v2)
(guard (relop? relop))
(Op relop v1 v2))))
(define (Effect effect)
(match effect
((nop) '(nop))
((if ,pred ,e1 ,e2) (If Effect pred e1 e2))
((begin . ,exp+) (Begin Effect exp+))
((let ,bds ,body) (Leto Effect bds body))
((mset! ,v1 ,v2 ,v3) (Op 'mset! v1 v2 v3))
((,rator . ,rands) (map Value effect))))
(define (Body body)
(match body
((locals ,x* ,value)
`(locals ,x* ,(Value value)))))
(match program
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(Body body)))))
e*))
(body (Body body)))
(Letrec x* e* body)))))))这同样算不上困难, 所以说也没有必要添加什么注解.
让我们来看一些例子, 请注意我们将locals视为某种形式的绑定, 即
(define-syntax locals
(syntax-rules ()
((_ (x ...) exp)
(let ((x (void)) ...) exp))))> (compil
'(letrec ((enum (lambda (a b)
(if (> a b)
'()
(cons a (enum (+ a 1) b)))))
(map (lambda (proc lst)
(if (null? lst)
'()
(cons (proc (car lst))
(map proc (cdr lst)))))))
(map (lambda (x) (* x x)) (enum 1 20))))
'(letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(locals
(pair.14)
(if (= lst.5 22)
22
(begin
(set! pair.14 (+ (alloc 16) 1))
(mset! pair.14 -1 ((mref proc.4 -2) proc.4 (mref lst.5 -1)))
(mset! pair.14 7 (map.1$8 (mref cp.10 6) proc.4 (mref lst.5 7)))
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(locals
(pair.15)
(if (> a.2 b.3)
22
(begin
(set! pair.15 (+ (alloc 16) 1))
(mset! pair.15 -1 a.2)
(mset! pair.15 7 (enum.0$9 (mref cp.11 6) (+ a.2 8) b.3))
pair.15)))))
(t.7$12 (lambda (cp.13 x.6) (locals () (* x.6 (sra x.6 3))))))
(locals
(map.1 enum.0 proc.16 proc.17 t.7 proc.18)
(begin
(set! map.1 (begin (set! proc.16 (+ (alloc 16) 2)) (mset! proc.16 -2 map.1$8) proc.16))
(set! enum.0 (begin (set! proc.17 (+ (alloc 16) 2)) (mset! proc.17 -2 enum.0$9) proc.17))
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(map.1$8
map.1
(begin (set! t.7 (begin (set! proc.18 (+ (alloc 8) 2)) (mset! proc.18 -2 t.7$12) proc.18)) t.7)
(enum.0$9 enum.0 8 160)))))
> (letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(locals
(pair.14)
(if (= lst.5 22)
22
(begin
(set! pair.14 (+ (alloc 16) 1))
(mset! pair.14 -1 ((mref proc.4 -2) proc.4 (mref lst.5 -1)))
(mset! pair.14 7 (map.1$8 (mref cp.10 6) proc.4 (mref lst.5 7)))
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(locals
(pair.15)
(if (> a.2 b.3)
22
(begin
(set! pair.15 (+ (alloc 16) 1))
(mset! pair.15 -1 a.2)
(mset! pair.15 7 (enum.0$9 (mref cp.11 6) (+ a.2 8) b.3))
pair.15)))))
(t.7$12 (lambda (cp.13 x.6) (locals () (* x.6 (sra x.6 3))))))
(locals
(map.1 enum.0 proc.16 proc.17 t.7 proc.18)
(begin
(set! map.1 (begin (set! proc.16 (+ (alloc 16) 2)) (mset! proc.16 -2 map.1$8) proc.16))
(set! enum.0 (begin (set! proc.17 (+ (alloc 16) 2)) (mset! proc.17 -2 enum.0$9) proc.17))
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(map.1$8
map.1
(begin (set! t.7 (begin (set! proc.18 (+ (alloc 8) 2)) (mset! proc.18 -2 t.7$12) proc.18)) t.7)
(enum.0$9 enum.0 8 160)))))
361
> (get-result 361)
'(1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400)> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'(letrec ((h.0$8
(lambda (cp.9 fact.4)
(locals
(t.6 proc.18)
(begin
(set! t.6 (begin (set! proc.18 (+ (alloc 16) 2)) (mset! proc.18 -2 t.6$10) proc.18))
(mset! t.6 6 fact.4)
t.6))))
(t.6$10
(lambda (cp.11 n.5)
(locals
()
(if (= n.5 0) 8 (* n.5 (sra ((mref (mref cp.11 6) -2) (mref cp.11 6) (- n.5 8)) 3))))))
(f.1$12
(lambda (cp.13 g.2)
(locals
(t.7 proc.19)
(h.0$8
(mref cp.13 6)
(begin
(set! t.7 (begin (set! proc.19 (+ (alloc 16) 2)) (mset! proc.19 -2 t.7$14) proc.19))
(mset! t.7 6 g.2)
t.7)))))
(t.7$14
(lambda (cp.15 x.3)
(locals
(t.16)
(begin
(set! t.16 ((mref (mref cp.15 6) -2) (mref cp.15 6) (mref cp.15 6)))
((mref t.16 -2) t.16 x.3))))))
(locals
(t.17 h.0 proc.20 f.1 proc.21)
(begin
(set! t.17
(begin
(set! h.0 (begin (set! proc.20 (+ (alloc 8) 2)) (mset! proc.20 -2 h.0$8) proc.20))
(set! f.1 (begin (set! proc.21 (+ (alloc 16) 2)) (mset! proc.21 -2 f.1$12) proc.21))
(mset! f.1 6 h.0)
(f.1$12 f.1 f.1)))
((mref t.17 -2) t.17 80))))
> (letrec ((h.0$8
(lambda (cp.9 fact.4)
(locals
(t.6 proc.18)
(begin
(set! t.6 (begin (set! proc.18 (+ (alloc 16) 2)) (mset! proc.18 -2 t.6$10) proc.18))
(mset! t.6 6 fact.4)
t.6))))
(t.6$10
(lambda (cp.11 n.5)
(locals
()
(if (= n.5 0) 8 (* n.5 (sra ((mref (mref cp.11 6) -2) (mref cp.11 6) (- n.5 8)) 3))))))
(f.1$12
(lambda (cp.13 g.2)
(locals
(t.7 proc.19)
(h.0$8
(mref cp.13 6)
(begin
(set! t.7 (begin (set! proc.19 (+ (alloc 16) 2)) (mset! proc.19 -2 t.7$14) proc.19))
(mset! t.7 6 g.2)
t.7)))))
(t.7$14
(lambda (cp.15 x.3)
(locals
(t.16)
(begin
(set! t.16 ((mref (mref cp.15 6) -2) (mref cp.15 6) (mref cp.15 6)))
((mref t.16 -2) t.16 x.3))))))
(locals
(t.17 h.0 proc.20 f.1 proc.21)
(begin
(set! t.17
(begin
(set! h.0 (begin (set! proc.20 (+ (alloc 8) 2)) (mset! proc.20 -2 h.0$8) proc.20))
(set! f.1 (begin (set! proc.21 (+ (alloc 16) 2)) (mset! proc.21 -2 f.1$12) proc.21))
(mset! f.1 6 h.0)
(f.1$12 f.1 f.1)))
((mref t.17 -2) t.17 80))))
29030400
> (get-result 29030400)
3628800> (compil
'(let ((even? (void))
(odd? (void)))
(set! even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(set! odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1)))))
(even? 88)))
'(letrec ((t.6$8
(lambda (cp.9 n.2)
(locals
(t.10)
(if (= n.2 0)
14
(begin (set! t.10 (mref (mref cp.9 6) -3)) ((mref t.10 -2) t.10 (- n.2 8)))))))
(t.7$11
(lambda (cp.12 n.3)
(locals
(t.13)
(if (= n.3 0)
6
(begin (set! t.13 (mref (mref cp.12 6) -3)) ((mref t.13 -2) t.13 (- n.3 8))))))))
(locals
(t.5 t.4 odd?.1 even?.0 box.15 box.16 t.6 proc.17 t.7 proc.18 t.14)
(begin
(set! t.5 30)
(set! t.4 30)
(set! odd?.1 (begin (set! box.15 (+ (alloc 8) 3)) (mset! box.15 -3 t.5) box.15))
(set! even?.0 (begin (set! box.16 (+ (alloc 8) 3)) (mset! box.16 -3 t.4) box.16))
(mset!
even?.0
-3
(begin
(set! t.6 (begin (set! proc.17 (+ (alloc 16) 2)) (mset! proc.17 -2 t.6$8) proc.17))
(mset! t.6 6 odd?.1)
t.6))
(mset!
odd?.1
-3
(begin
(set! t.7 (begin (set! proc.18 (+ (alloc 16) 2)) (mset! proc.18 -2 t.7$11) proc.18))
(mset! t.7 6 even?.0)
t.7))
(set! t.14 (mref even?.0 -3))
((mref t.14 -2) t.14 704))))
> (letrec ((t.6$8
(lambda (cp.9 n.2)
(locals
(t.10)
(if (= n.2 0)
14
(begin (set! t.10 (mref (mref cp.9 6) -3)) ((mref t.10 -2) t.10 (- n.2 8)))))))
(t.7$11
(lambda (cp.12 n.3)
(locals
(t.13)
(if (= n.3 0)
6
(begin (set! t.13 (mref (mref cp.12 6) -3)) ((mref t.13 -2) t.13 (- n.3 8))))))))
(locals
(t.5 t.4 odd?.1 even?.0 box.15 box.16 t.6 proc.17 t.7 proc.18 t.14)
(begin
(set! t.5 30)
(set! t.4 30)
(set! odd?.1 (begin (set! box.15 (+ (alloc 8) 3)) (mset! box.15 -3 t.5) box.15))
(set! even?.0 (begin (set! box.16 (+ (alloc 8) 3)) (mset! box.16 -3 t.4) box.16))
(mset!
even?.0
-3
(begin
(set! t.6 (begin (set! proc.17 (+ (alloc 16) 2)) (mset! proc.17 -2 t.6$8) proc.17))
(mset! t.6 6 odd?.1)
t.6))
(mset!
odd?.1
-3
(begin
(set! t.7 (begin (set! proc.18 (+ (alloc 16) 2)) (mset! proc.18 -2 t.7$11) proc.18))
(mset! t.7 6 even?.0)
t.7))
(set! t.14 (mref even?.0 -3))
((mref t.14 -2) t.14 704))))
14
> (get-result 14)
#t> (compil
'(let ((x 0) (y 1) (z 2))
(let ((counter (lambda ()
(set! x (+ x 1))
(set! z (+ z 2))
(cons x z))))
(counter)
(counter)
(counter))))
'(letrec ((counter.3$6
(lambda (cp.7)
(locals
(pair.8)
(begin
(mset! (mref cp.7 6) -3 (+ (mref (mref cp.7 6) -3) 8))
(mset! (mref cp.7 14) -3 (+ (mref (mref cp.7 14) -3) 16))
(set! pair.8 (+ (alloc 16) 1))
(mset! pair.8 -1 (mref (mref cp.7 6) -3))
(mset! pair.8 7 (mref (mref cp.7 14) -3))
pair.8)))))
(locals
(t.5 y.1 t.4 z.2 x.0 box.9 box.10 counter.3 proc.11)
(begin
(set! t.5 16)
(set! y.1 8)
(set! t.4 0)
(set! z.2 (begin (set! box.9 (+ (alloc 8) 3)) (mset! box.9 -3 t.5) box.9))
(set! x.0 (begin (set! box.10 (+ (alloc 8) 3)) (mset! box.10 -3 t.4) box.10))
(set! counter.3 (begin (set! proc.11 (+ (alloc 24) 2)) (mset! proc.11 -2 counter.3$6) proc.11))
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))
> (letrec ((counter.3$6
(lambda (cp.7)
(locals
(pair.8)
(begin
(mset! (mref cp.7 6) -3 (+ (mref (mref cp.7 6) -3) 8))
(mset! (mref cp.7 14) -3 (+ (mref (mref cp.7 14) -3) 16))
(set! pair.8 (+ (alloc 16) 1))
(mset! pair.8 -1 (mref (mref cp.7 6) -3))
(mset! pair.8 7 (mref (mref cp.7 14) -3))
pair.8)))))
(locals
(t.5 y.1 t.4 z.2 x.0 box.9 box.10 counter.3 proc.11)
(begin
(set! t.5 16)
(set! y.1 8)
(set! t.4 0)
(set! z.2 (begin (set! box.9 (+ (alloc 8) 3)) (mset! box.9 -3 t.5) box.9))
(set! x.0 (begin (set! box.10 (+ (alloc 8) 3)) (mset! box.10 -3 t.4) box.10))
(set! counter.3 (begin (set! proc.11 (+ (alloc 24) 2)) (mset! proc.11 -2 counter.3$6) proc.11))
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))
73
> (get-result 73)
'(3 . 8)verify-uil顾名思义, verify-uil是一个验证pass. 然而, 我们所使用的句法从形式上说和前一个的输出不同. 实际上, 这里的输入句法是
<program> ::= (letrec ((<label> (lambda (<uvar> <uvar>*) <body>))*) <body>)
<value> ::= <triv>
| (if <pred> <value> <value>)
| (begin <effect>* <value>)
| (alloc <value>)
| (mref <value> <value>)
| (<binop> <value> <value>)
| (<value> <value> <value>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (<relop> <value> <value>)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (set! <uvar> <value>)
| (mset! <value> <value> <value>)
| (<value> <value> <value>*)
<tail> ::= <triv>
| (if <pred> <tail> <tail>)
| (begin <effect>* <tail>)
| (alloc <value>)
| (mref <value> <value>)
| (<binop> <value> <value>)
| (<value> <value> <value>*)
<body> ::= (locals (<uvar>*) <tail>)
<triv> ::= <int> | <uvar> | <label>
<binop> ::= + | - | * | sra | logand
<relop> ::= = | < | > | <= | >=<tail>. 当然, 熟悉Scheme的人不难看出<tail>其实就是出现在尾位置的<value>. 不过, 另外两种表达式本来就不可能出现在尾位置上. 从某种意义上说, 这暗示了在之后的pass里, <value>将要被消去. 至于verify-uil本身, 我认为没有什么好说的.(define (verify-uil program)
(define (triv? triv)
(or (int64? triv)
(uvar? triv)
(label? triv)))
(define (make-begin exp* exp)
`(begin ,@exp* ,exp))
(define (If Context pred e1 e2)
`(if ,(Pred pred) ,(Context e1) ,(Context e2)))
(define (Begin Context exp+)
(:begin exp+
(lambda (exp* exp)
(let ((exp* (map Effect exp*))
(exp (Context exp)))
(make-begin exp* exp)))))
(define (Op op . v*)
(cons op (map Value v*)))
(define (Value value)
(match value
(,triv
(guard (not (pair? triv)))
(if (triv? triv)
triv
(error 'verify-uil "unknown triv ~s" triv)))
((if ,pred ,v1 ,v2) (If Value pred v1 v2))
((begin . ,exp+) (Begin Value exp+))
((alloc ,v) (Op 'alloc v))
((mref ,v1 ,v2) (Op 'mref v1 v2))
((,binop ,v1 ,v2)
(guard (binop? binop))
(Op binop v1 v2))
((,rator ,rand . ,rands) (map Value value))))
(define (Pred pred)
(match pred
((true) '(true))
((false) '(false))
((if ,p1 ,p2 ,p3) (If Pred p1 p2 p3))
((begin . ,exp+) (Begin Pred exp+))
((,relop ,v1 ,v2)
(guard (relop? relop))
(Op relop v1 v2))))
(define (Effect effect)
(match effect
((nop) '(nop))
((if ,pred ,e1 ,e2) (If Effect pred e1 e2))
((begin . ,exp+) (Begin Effect exp+))
((set! ,x ,v)
(guard (uvar? x))
`(set! ,x ,(Value v)))
((mset! ,v1 ,v2 ,v3) (Op 'mset! v1 v2 v3))
((,rator ,rand . ,rands) (map Value effect))))
(define (Tail tail)
(match tail
(,triv
(guard (not (pair? triv)))
(if (triv? triv)
triv
(error 'verify-uil "unknown triv ~s" triv)))
((if ,pred ,t1 ,t2) (If Tail pred t1 t2))
((begin . ,exp+) (Begin Tail exp+))
((alloc ,v) (Op 'alloc v))
((mref ,v1 ,v2) (Op 'mref v1 v2))
((,binop ,v1 ,v2)
(guard (binop? binop))
(Op binop v1 v2))
((,rator ,rand . ,rands) (map Value tail))))
(define (Body body)
(match body
((locals ,x* ,tail)
`(locals ,x* ,(Tail tail)))))
(match program
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
(guard (pair? x*))
`(lambda ,x* ,(Body body)))))
e*))
(body (Body body)))
(Letrec x* e* body)))))))当然, 还要另外一种写法, 就是写成谓词的形式, 因为这只是一个验证步骤, 输入和输出应该是一模一样的.
不过, 实际上我们之后将会采取下列句法, 其只是对于之前的句法的小修饰, 旧句法所指称的AST集合是新句法所指称的AST集合的一个子集.
<program> ::= (letrec ((<label> (lambda (<uvar>*) <body>))*) <body>)
<value> ::= <triv>
| (if <pred> <value> <value>)
| (begin <effect>* <value>)
| (alloc <value>)
| (mref <value> <value>)
| (<binop> <value> <value>)
| (<value> <value>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (<relop> <value> <value>)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (set! <uvar> <value>)
| (mset! <value> <value> <value>)
| (<value> <value>*)
<tail> ::= <triv>
| (if <pred> <tail> <tail>)
| (begin <effect>* <tail>)
| (alloc <value>)
| (mref <value> <value>)
| (<binop> <value> <value>)
| (<value> <value>*)
<body> ::= (locals (<uvar>*) <tail>)
<triv> ::= <int> | <uvar> | <label>
<binop> ::= + | - | * | sra | logand
<relop> ::= = | < | > | <= | >=remove-complex-opera*顾名思义, remove-complex-opera*消除了原始应用和非原始应用中的复杂表达式. 何谓复杂? 只要不是<triv>, 那都是复杂的.
那么怎么消除应用中的复杂表达式呢? 其实就是通过set!引入新的绑定, 这让人想到所谓的ANF变换.
我们还是使用CPS来返回多值, 不过现在有两种不同的延续. 对于目的是得到<triv>的, 我们除了平凡表达式, 还需要返回set!绑定序列和引入的新变量 (后者locals形式需要的信息). 对于目的是得到值表达式, 谓词表达式, 副作用表达式以及尾表达式的, 我们返回表达式和新引入的变量即可, 无需绑定序列.
(define (remove-complex-opera* program)
(define (trivialize value k)
(match value
(,triv
(guard (not (pair? triv)))
(k triv '() '()))
((if ,pred ,v1 ,v2)
(If Value pred v1 v2
(lambda (i a*)
(define tmp (unique-symbol 'tmp))
(k tmp (cons tmp a*)
(list `(set! ,tmp ,i))))))
((begin . ,exp+)
(Begin Value exp+
(lambda (b a*)
(define tmp (unique-symbol 'tmp))
(k tmp (cons tmp a*)
(list `(set! ,tmp ,b))))))
((alloc ,v) (trivialize-op k 'alloc v))
((mref ,v1 ,v2) (trivialize-op k 'mref v1 v2))
((,binop ,v1 ,v2)
(guard (binop? binop))
(trivialize-op k binop v1 v2))
((,rator . ,rands)
(trivialize*
value
(lambda (triv* a* binding*)
(define tmp (unique-symbol 'tmp))
(k tmp (cons tmp a*)
`(,@binding*
(set! ,tmp ,triv*))))))))
(define (trivialize* value* k)
(if (null? value*)
(k '() '() '())
(trivialize
(car value*)
(lambda (triv a* binding*0)
(trivialize*
(cdr value*)
(lambda (triv* b* binding*1)
(k (cons triv triv*)
(append a* b*)
(append binding*0 binding*1))))))))
(define (trivialize-op k op . v*)
(trivialize*
v* (lambda (triv* a* binding*)
(define tmp (unique-symbol 'tmp))
(k tmp (cons tmp a*)
`(,@binding*
(set! ,tmp ,(cons op triv*)))))))
(define (Op k op . v*)
(trivialize*
v* (lambda (triv* a* binding*)
(k (make-begin binding* (cons op triv*)) a*))))
(define (If Context pred e1 e2 k)
(Pred
pred
(lambda (pred a*)
(Context
e1
(lambda (e1 b*)
(Context
e2
(lambda (e2 c*)
(k `(if ,pred ,e1 ,e2)
(append a* b* c*)))))))))
(define (Begin Context exp+ k)
(:begin exp+
(lambda (exp* exp)
(Effect*
exp*
(lambda (exp* a*)
(Context
exp
(lambda (exp b*)
(k (make-begin exp* exp)
(append a* b*)))))))))
(define (Value value k)
(match value
(,triv
(guard (not (pair? triv)))
(k triv '()))
((if ,pred ,v1 ,v2) (If Value pred v1 v2 k))
((begin . ,exp+) (Begin Value exp+ k))
((alloc ,v) (Op k 'alloc v))
((mref ,v1 ,v2) (Op k 'mref v1 v2))
((,binop ,v1 ,v2)
(guard (binop? binop))
(Op k binop v1 v2))
((,rator . ,rands)
(trivialize*
value
(lambda (triv* a* binding*)
(k (make-begin binding* triv*) a*))))))
(define (Pred pred k)
(match pred
((true) (k '(true) '()))
((false) (k '(false) '()))
((if ,p1 ,p2 ,p3) (If Pred p1 p2 p3 k))
((begin . ,exp+) (Begin Pred exp+ k))
((,relop ,v1 ,v2)
(guard (relop? relop))
(Op k relop v1 v2))))
(define (Effect effect k)
(match effect
((nop) (k '(nop) '()))
((if ,pred ,e1 ,e2) (If Effect pred e1 e2 k))
((begin . ,exp+) (Begin Effect exp+ k))
((set! ,x ,v)
(Value v (lambda (v a*)
(k `(set! ,x ,v) a*))))
((mset! ,v1 ,v2 ,v3) (Op k 'mset! v1 v2 v3))
((,rator . ,rands)
(trivialize*
effect
(lambda (triv* a* binding*)
(k (make-begin binding* triv*) a*))))))
(define (Tail tail k)
(match tail
(,triv
(guard (not (pair? triv)))
(k triv '()))
((if ,pred ,t1 ,t2) (If Tail pred t1 t2 k))
((begin . ,exp+) (Begin Tail exp+ k))
((alloc ,v) (Op k 'alloc v))
((mref ,v1 ,v2) (Op k 'mref v1 v2))
((,binop ,v1 ,v2)
(guard (binop? binop))
(Op k binop v1 v2))
((,rator . ,rands)
(trivialize*
tail
(lambda (triv* a* binding*)
(k (make-begin binding* triv*) a*))))))
(define Effect* (make-proc* Effect append))
(define (Body body)
(match body
((locals ,x* ,tail)
(Tail tail
(lambda (tail a*)
`(locals ,(append x* a*) ,tail))))))
(match program
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(Body body)))))
e*))
(body (Body body)))
(Letrec x* e* body)))))))从整体上来说, 这次的代码仍然是对应于各种非终结符的过程的交织. 从细节上来说, 我们需要小心地合并set!绑定, 避免出现求值顺序的错误. 当然了, 和ANF以及CPS变换一样, remove-complex-opera*强加了一种求值的顺序, 或者说使得求值顺序显式化.
以下是一些例子.
> (compil
'(let ((x 0) (y 1) (z 2))
(let ((counter (lambda ()
(set! x (+ x 1))
(set! z (+ z 2))
(cons x z))))
(counter)
(counter)
(counter))))
'(letrec ((counter.3$6
(lambda (cp.7)
(locals
(pair.8
tmp.12
tmp.15
tmp.14
tmp.13
tmp.16
tmp.19
tmp.18
tmp.17
tmp.20
tmp.22
tmp.21
tmp.24
tmp.23)
(begin
(set! tmp.12 (mref cp.7 6))
(set! tmp.13 (mref cp.7 6))
(set! tmp.14 (mref tmp.13 -3))
(set! tmp.15 (+ tmp.14 8))
(mset! tmp.12 -3 tmp.15)
(set! tmp.16 (mref cp.7 14))
(set! tmp.17 (mref cp.7 14))
(set! tmp.18 (mref tmp.17 -3))
(set! tmp.19 (+ tmp.18 16))
(mset! tmp.16 -3 tmp.19)
(set! pair.8 (begin (set! tmp.20 (alloc 16)) (+ tmp.20 1)))
(set! tmp.21 (mref cp.7 6))
(set! tmp.22 (mref tmp.21 -3))
(mset! pair.8 -1 tmp.22)
(set! tmp.23 (mref cp.7 14))
(set! tmp.24 (mref tmp.23 -3))
(mset! pair.8 7 tmp.24)
pair.8)))))
(locals
(t.5 y.1 t.4 z.2 x.0 box.9 box.10 counter.3 proc.11 tmp.25 tmp.26 tmp.27)
(begin
(set! t.5 16)
(set! y.1 8)
(set! t.4 0)
(set! z.2
(begin (set! box.9 (begin (set! tmp.25 (alloc 8)) (+ tmp.25 3))) (mset! box.9 -3 t.5) box.9))
(set! x.0
(begin
(set! box.10 (begin (set! tmp.26 (alloc 8)) (+ tmp.26 3)))
(mset! box.10 -3 t.4)
box.10))
(set! counter.3
(begin
(set! proc.11 (begin (set! tmp.27 (alloc 24)) (+ tmp.27 2)))
(mset! proc.11 -2 counter.3$6)
proc.11))
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))
> (letrec ((counter.3$6
(lambda (cp.7)
(locals
(pair.8
tmp.12
tmp.15
tmp.14
tmp.13
tmp.16
tmp.19
tmp.18
tmp.17
tmp.20
tmp.22
tmp.21
tmp.24
tmp.23)
(begin
(set! tmp.12 (mref cp.7 6))
(set! tmp.13 (mref cp.7 6))
(set! tmp.14 (mref tmp.13 -3))
(set! tmp.15 (+ tmp.14 8))
(mset! tmp.12 -3 tmp.15)
(set! tmp.16 (mref cp.7 14))
(set! tmp.17 (mref cp.7 14))
(set! tmp.18 (mref tmp.17 -3))
(set! tmp.19 (+ tmp.18 16))
(mset! tmp.16 -3 tmp.19)
(set! pair.8 (begin (set! tmp.20 (alloc 16)) (+ tmp.20 1)))
(set! tmp.21 (mref cp.7 6))
(set! tmp.22 (mref tmp.21 -3))
(mset! pair.8 -1 tmp.22)
(set! tmp.23 (mref cp.7 14))
(set! tmp.24 (mref tmp.23 -3))
(mset! pair.8 7 tmp.24)
pair.8)))))
(locals
(t.5 y.1 t.4 z.2 x.0 box.9 box.10 counter.3 proc.11 tmp.25 tmp.26 tmp.27)
(begin
(set! t.5 16)
(set! y.1 8)
(set! t.4 0)
(set! z.2
(begin (set! box.9 (begin (set! tmp.25 (alloc 8)) (+ tmp.25 3))) (mset! box.9 -3 t.5) box.9))
(set! x.0
(begin
(set! box.10 (begin (set! tmp.26 (alloc 8)) (+ tmp.26 3)))
(mset! box.10 -3 t.4)
box.10))
(set! counter.3
(begin
(set! proc.11 (begin (set! tmp.27 (alloc 24)) (+ tmp.27 2)))
(mset! proc.11 -2 counter.3$6)
proc.11))
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))
73
> (get-result 73)
'(3 . 8)> (compil
'(let ((even? (void))
(odd? (void)))
(set! even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(set! odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1)))))
(even? 88)))
'(letrec ((t.6$8
(lambda (cp.9 n.2)
(locals
(t.10 tmp.19 tmp.20 tmp.21)
(if (= n.2 0)
14
(begin
(set! t.10 (begin (set! tmp.19 (mref cp.9 6)) (mref tmp.19 -3)))
(set! tmp.20 (mref t.10 -2))
(set! tmp.21 (- n.2 8))
(tmp.20 t.10 tmp.21))))))
(t.7$11
(lambda (cp.12 n.3)
(locals
(t.13 tmp.22 tmp.23 tmp.24)
(if (= n.3 0)
6
(begin
(set! t.13 (begin (set! tmp.22 (mref cp.12 6)) (mref tmp.22 -3)))
(set! tmp.23 (mref t.13 -2))
(set! tmp.24 (- n.3 8))
(tmp.23 t.13 tmp.24)))))))
(locals
(t.5
t.4
odd?.1
even?.0
box.15
box.16
t.6
proc.17
t.7
proc.18
t.14
tmp.25
tmp.26
tmp.28
tmp.27
tmp.30
tmp.29
tmp.31)
(begin
(set! t.5 30)
(set! t.4 30)
(set! odd?.1
(begin
(set! box.15 (begin (set! tmp.25 (alloc 8)) (+ tmp.25 3)))
(mset! box.15 -3 t.5)
box.15))
(set! even?.0
(begin
(set! box.16 (begin (set! tmp.26 (alloc 8)) (+ tmp.26 3)))
(mset! box.16 -3 t.4)
box.16))
(set! tmp.28
(begin
(set! t.6
(begin
(set! proc.17 (begin (set! tmp.27 (alloc 16)) (+ tmp.27 2)))
(mset! proc.17 -2 t.6$8)
proc.17))
(mset! t.6 6 odd?.1)
t.6))
(mset! even?.0 -3 tmp.28)
(set! tmp.30
(begin
(set! t.7
(begin
(set! proc.18 (begin (set! tmp.29 (alloc 16)) (+ tmp.29 2)))
(mset! proc.18 -2 t.7$11)
proc.18))
(mset! t.7 6 even?.0)
t.7))
(mset! odd?.1 -3 tmp.30)
(set! t.14 (mref even?.0 -3))
(set! tmp.31 (mref t.14 -2))
(tmp.31 t.14 704))))
> (letrec ((t.6$8
(lambda (cp.9 n.2)
(locals
(t.10 tmp.19 tmp.20 tmp.21)
(if (= n.2 0)
14
(begin
(set! t.10 (begin (set! tmp.19 (mref cp.9 6)) (mref tmp.19 -3)))
(set! tmp.20 (mref t.10 -2))
(set! tmp.21 (- n.2 8))
(tmp.20 t.10 tmp.21))))))
(t.7$11
(lambda (cp.12 n.3)
(locals
(t.13 tmp.22 tmp.23 tmp.24)
(if (= n.3 0)
6
(begin
(set! t.13 (begin (set! tmp.22 (mref cp.12 6)) (mref tmp.22 -3)))
(set! tmp.23 (mref t.13 -2))
(set! tmp.24 (- n.3 8))
(tmp.23 t.13 tmp.24)))))))
(locals
(t.5
t.4
odd?.1
even?.0
box.15
box.16
t.6
proc.17
t.7
proc.18
t.14
tmp.25
tmp.26
tmp.28
tmp.27
tmp.30
tmp.29
tmp.31)
(begin
(set! t.5 30)
(set! t.4 30)
(set! odd?.1
(begin
(set! box.15 (begin (set! tmp.25 (alloc 8)) (+ tmp.25 3)))
(mset! box.15 -3 t.5)
box.15))
(set! even?.0
(begin
(set! box.16 (begin (set! tmp.26 (alloc 8)) (+ tmp.26 3)))
(mset! box.16 -3 t.4)
box.16))
(set! tmp.28
(begin
(set! t.6
(begin
(set! proc.17 (begin (set! tmp.27 (alloc 16)) (+ tmp.27 2)))
(mset! proc.17 -2 t.6$8)
proc.17))
(mset! t.6 6 odd?.1)
t.6))
(mset! even?.0 -3 tmp.28)
(set! tmp.30
(begin
(set! t.7
(begin
(set! proc.18 (begin (set! tmp.29 (alloc 16)) (+ tmp.29 2)))
(mset! proc.18 -2 t.7$11)
proc.18))
(mset! t.7 6 even?.0)
t.7))
(mset! odd?.1 -3 tmp.30)
(set! t.14 (mref even?.0 -3))
(set! tmp.31 (mref t.14 -2))
(tmp.31 t.14 704))))
14
> (get-result 14)
#t> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'(letrec ((h.0$8
(lambda (cp.9 fact.4)
(locals
(t.6 proc.18 tmp.22)
(begin
(set! t.6
(begin
(set! proc.18 (begin (set! tmp.22 (alloc 16)) (+ tmp.22 2)))
(mset! proc.18 -2 t.6$10)
proc.18))
(mset! t.6 6 fact.4)
t.6))))
(t.6$10
(lambda (cp.11 n.5)
(locals
(tmp.28 tmp.27 tmp.24 tmp.23 tmp.25 tmp.26)
(if (= n.5 0)
8
(begin
(set! tmp.23 (mref cp.11 6))
(set! tmp.24 (mref tmp.23 -2))
(set! tmp.25 (mref cp.11 6))
(set! tmp.26 (- n.5 8))
(set! tmp.27 (tmp.24 tmp.25 tmp.26))
(set! tmp.28 (sra tmp.27 3))
(* n.5 tmp.28))))))
(f.1$12
(lambda (cp.13 g.2)
(locals
(t.7 proc.19 tmp.29 tmp.31 tmp.30)
(begin
(set! tmp.29 (mref cp.13 6))
(set! tmp.31
(begin
(set! t.7
(begin
(set! proc.19 (begin (set! tmp.30 (alloc 16)) (+ tmp.30 2)))
(mset! proc.19 -2 t.7$14)
proc.19))
(mset! t.7 6 g.2)
t.7))
(h.0$8 tmp.29 tmp.31)))))
(t.7$14
(lambda (cp.15 x.3)
(locals
(t.16 tmp.33 tmp.32 tmp.34 tmp.35 tmp.36)
(begin
(set! t.16
(begin
(set! tmp.32 (mref cp.15 6))
(set! tmp.33 (mref tmp.32 -2))
(set! tmp.34 (mref cp.15 6))
(set! tmp.35 (mref cp.15 6))
(tmp.33 tmp.34 tmp.35)))
(set! tmp.36 (mref t.16 -2))
(tmp.36 t.16 x.3))))))
(locals
(t.17 h.0 proc.20 f.1 proc.21 tmp.37 tmp.38 tmp.39)
(begin
(set! t.17
(begin
(set! h.0
(begin
(set! proc.20 (begin (set! tmp.37 (alloc 8)) (+ tmp.37 2)))
(mset! proc.20 -2 h.0$8)
proc.20))
(set! f.1
(begin
(set! proc.21 (begin (set! tmp.38 (alloc 16)) (+ tmp.38 2)))
(mset! proc.21 -2 f.1$12)
proc.21))
(mset! f.1 6 h.0)
(f.1$12 f.1 f.1)))
(set! tmp.39 (mref t.17 -2))
(tmp.39 t.17 80))))
> (letrec ((h.0$8
(lambda (cp.9 fact.4)
(locals
(t.6 proc.18 tmp.22)
(begin
(set! t.6
(begin
(set! proc.18 (begin (set! tmp.22 (alloc 16)) (+ tmp.22 2)))
(mset! proc.18 -2 t.6$10)
proc.18))
(mset! t.6 6 fact.4)
t.6))))
(t.6$10
(lambda (cp.11 n.5)
(locals
(tmp.28 tmp.27 tmp.24 tmp.23 tmp.25 tmp.26)
(if (= n.5 0)
8
(begin
(set! tmp.23 (mref cp.11 6))
(set! tmp.24 (mref tmp.23 -2))
(set! tmp.25 (mref cp.11 6))
(set! tmp.26 (- n.5 8))
(set! tmp.27 (tmp.24 tmp.25 tmp.26))
(set! tmp.28 (sra tmp.27 3))
(* n.5 tmp.28))))))
(f.1$12
(lambda (cp.13 g.2)
(locals
(t.7 proc.19 tmp.29 tmp.31 tmp.30)
(begin
(set! tmp.29 (mref cp.13 6))
(set! tmp.31
(begin
(set! t.7
(begin
(set! proc.19 (begin (set! tmp.30 (alloc 16)) (+ tmp.30 2)))
(mset! proc.19 -2 t.7$14)
proc.19))
(mset! t.7 6 g.2)
t.7))
(h.0$8 tmp.29 tmp.31)))))
(t.7$14
(lambda (cp.15 x.3)
(locals
(t.16 tmp.33 tmp.32 tmp.34 tmp.35 tmp.36)
(begin
(set! t.16
(begin
(set! tmp.32 (mref cp.15 6))
(set! tmp.33 (mref tmp.32 -2))
(set! tmp.34 (mref cp.15 6))
(set! tmp.35 (mref cp.15 6))
(tmp.33 tmp.34 tmp.35)))
(set! tmp.36 (mref t.16 -2))
(tmp.36 t.16 x.3))))))
(locals
(t.17 h.0 proc.20 f.1 proc.21 tmp.37 tmp.38 tmp.39)
(begin
(set! t.17
(begin
(set! h.0
(begin
(set! proc.20 (begin (set! tmp.37 (alloc 8)) (+ tmp.37 2)))
(mset! proc.20 -2 h.0$8)
proc.20))
(set! f.1
(begin
(set! proc.21 (begin (set! tmp.38 (alloc 16)) (+ tmp.38 2)))
(mset! proc.21 -2 f.1$12)
proc.21))
(mset! f.1 6 h.0)
(f.1$12 f.1 f.1)))
(set! tmp.39 (mref t.17 -2))
(tmp.39 t.17 80))))
29030400
> (get-result 29030400)
3628800> (compil
'(letrec ((enum (lambda (a b)
(if (> a b)
'()
(cons a (enum (+ a 1) b)))))
(map (lambda (proc lst)
(if (null? lst)
'()
(cons (proc (car lst))
(map proc (cdr lst)))))))
(map (lambda (x) (* x x)) (enum 1 20))))
'(letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(locals
(pair.14 tmp.19 tmp.22 tmp.20 tmp.21 tmp.25 tmp.23 tmp.24)
(if (= lst.5 22)
22
(begin
(set! pair.14 (begin (set! tmp.19 (alloc 16)) (+ tmp.19 1)))
(set! tmp.20 (mref proc.4 -2))
(set! tmp.21 (mref lst.5 -1))
(set! tmp.22 (tmp.20 proc.4 tmp.21))
(mset! pair.14 -1 tmp.22)
(set! tmp.23 (mref cp.10 6))
(set! tmp.24 (mref lst.5 7))
(set! tmp.25 (map.1$8 tmp.23 proc.4 tmp.24))
(mset! pair.14 7 tmp.25)
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(locals
(pair.15 tmp.26 tmp.29 tmp.27 tmp.28)
(if (> a.2 b.3)
22
(begin
(set! pair.15 (begin (set! tmp.26 (alloc 16)) (+ tmp.26 1)))
(mset! pair.15 -1 a.2)
(set! tmp.27 (mref cp.11 6))
(set! tmp.28 (+ a.2 8))
(set! tmp.29 (enum.0$9 tmp.27 tmp.28 b.3))
(mset! pair.15 7 tmp.29)
pair.15)))))
(t.7$12
(lambda (cp.13 x.6) (locals (tmp.30) (begin (set! tmp.30 (sra x.6 3)) (* x.6 tmp.30))))))
(locals
(map.1 enum.0 proc.16 proc.17 t.7 proc.18 tmp.31 tmp.32 tmp.34 tmp.33 tmp.35)
(begin
(set! map.1
(begin
(set! proc.16 (begin (set! tmp.31 (alloc 16)) (+ tmp.31 2)))
(mset! proc.16 -2 map.1$8)
proc.16))
(set! enum.0
(begin
(set! proc.17 (begin (set! tmp.32 (alloc 16)) (+ tmp.32 2)))
(mset! proc.17 -2 enum.0$9)
proc.17))
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(set! tmp.34
(begin
(set! t.7
(begin
(set! proc.18 (begin (set! tmp.33 (alloc 8)) (+ tmp.33 2)))
(mset! proc.18 -2 t.7$12)
proc.18))
t.7))
(set! tmp.35 (enum.0$9 enum.0 8 160))
(map.1$8 map.1 tmp.34 tmp.35))))
> (letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(locals
(pair.14 tmp.19 tmp.22 tmp.20 tmp.21 tmp.25 tmp.23 tmp.24)
(if (= lst.5 22)
22
(begin
(set! pair.14 (begin (set! tmp.19 (alloc 16)) (+ tmp.19 1)))
(set! tmp.20 (mref proc.4 -2))
(set! tmp.21 (mref lst.5 -1))
(set! tmp.22 (tmp.20 proc.4 tmp.21))
(mset! pair.14 -1 tmp.22)
(set! tmp.23 (mref cp.10 6))
(set! tmp.24 (mref lst.5 7))
(set! tmp.25 (map.1$8 tmp.23 proc.4 tmp.24))
(mset! pair.14 7 tmp.25)
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(locals
(pair.15 tmp.26 tmp.29 tmp.27 tmp.28)
(if (> a.2 b.3)
22
(begin
(set! pair.15 (begin (set! tmp.26 (alloc 16)) (+ tmp.26 1)))
(mset! pair.15 -1 a.2)
(set! tmp.27 (mref cp.11 6))
(set! tmp.28 (+ a.2 8))
(set! tmp.29 (enum.0$9 tmp.27 tmp.28 b.3))
(mset! pair.15 7 tmp.29)
pair.15)))))
(t.7$12
(lambda (cp.13 x.6) (locals (tmp.30) (begin (set! tmp.30 (sra x.6 3)) (* x.6 tmp.30))))))
(locals
(map.1 enum.0 proc.16 proc.17 t.7 proc.18 tmp.31 tmp.32 tmp.34 tmp.33 tmp.35)
(begin
(set! map.1
(begin
(set! proc.16 (begin (set! tmp.31 (alloc 16)) (+ tmp.31 2)))
(mset! proc.16 -2 map.1$8)
proc.16))
(set! enum.0
(begin
(set! proc.17 (begin (set! tmp.32 (alloc 16)) (+ tmp.32 2)))
(mset! proc.17 -2 enum.0$9)
proc.17))
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(set! tmp.34
(begin
(set! t.7
(begin
(set! proc.18 (begin (set! tmp.33 (alloc 8)) (+ tmp.33 2)))
(mset! proc.18 -2 t.7$12)
proc.18))
t.7))
(set! tmp.35 (enum.0$9 enum.0 8 160))
(map.1$8 map.1 tmp.34 tmp.35))))
361
> (get-result 361)
'(1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400)最后我们给出句法.
<program> ::= (letrec ((<label> (lambda (<uvar>*) <body>))*) <body>)
<value> ::= <triv>
| (if <pred> <value> <value>)
| (begin <effect>* <value>)
| (alloc <triv>)
| (mref <triv> <triv>)
| (<binop> <triv> <triv>)
| (<triv> <triv>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (<relop> <triv> <triv>)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (set! <uvar> <value>)
| (mset! <triv> <triv> <triv>)
| (<triv> <triv>*)
<tail> ::= <triv>
| (if <pred> <tail> <tail>)
| (begin <effect>* <tail>)
| (alloc <triv>)
| (mref <triv> <triv>)
| (<binop> <triv> <triv>)
| (<triv> <triv>*)
<body> ::= (locals (<uvar>*) <tail>)
<triv> ::= <int> | <uvar> | <label>
<binop> ::= + | - | * | sra | logand
<relop> ::= = | < | > | <= | >=<value>的生存空间被极大压缩了, 只活在set!的右支里.flatten-set!flatten-set!将清理set!的右支, 以扫除<value>.
(define ((simplize-set! x) value)
(match value
((if ,pred ,v1 ,v2)
(If (simplize-set! x) pred v1 v2))
((begin . ,exp+)
(Begin (simplize-set! x) exp+))
(,simple (make-set! x simple))))从这部分代码中可以看到, 清理的策略也很简单, 只需要递归地处理if和begin.
(define (flatten-set! program)
(define (If Context pred e1 e2)
`(if ,(Pred pred) ,(Context e1) ,(Context e2)))
(define (Begin Context exp+)
(:begin exp+
(lambda (exp* exp)
(let ((exp* (map Effect exp*))
(exp (Context exp)))
(make-begin exp* exp)))))
(define (triv? x)
(not (pair? x)))
(define (simple? x)
(match x
(,triv (guard (triv? triv)) #t)
((alloc ,triv) (triv? triv))
((mref ,triv1 ,triv2)
(and (triv? triv1) (triv? triv2)))
((,binop ,triv1 ,triv2)
(guard (binop? binop))
(and (triv? triv1) (triv? triv2)))
((,rator . ,rands) (andmap triv? x))))
(define (make-set! x simple)
(unless (simple? simple)
(error 'flatten-set!
"~s should be simple!"
simple))
`(set! ,x ,simple))
(define ((simplize-set! x) value)
(match value
((if ,pred ,v1 ,v2)
(If (simplize-set! x) pred v1 v2))
((begin . ,exp+)
(Begin (simplize-set! x) exp+))
(,simple (make-set! x simple))))
(define (Tail tail)
(match tail
((if ,pred ,t1 ,t2) (If Tail pred t1 t2))
((begin . ,exp+) (Begin Tail exp+))
(,simple (guard (simple? simple)) simple)))
(define (Pred pred)
(match pred
((true) '(true))
((false) '(false))
((if ,p1 ,p2 ,p3) (If Pred p1 p2 p3))
((begin . ,exp+) (Begin Pred exp+))
((,relop ,triv1 ,triv2)
(guard (and (relop? relop)
(triv? triv1)
(triv? triv2)))
pred)))
(define (Effect effect)
(match effect
((nop) '(nop))
((if ,pred ,e1 ,e2) (If Effect pred e1 e2))
((begin . ,exp+) (Begin Effect exp+))
((set! ,x ,v) ((simplize-set! x) v))
((mset! ,triv1 ,triv2 ,triv3)
(guard (andmap triv? (cdr effect)))
effect)
((,rator . ,rands)
(guard (andmap triv? effect))
effect)))
(define (Body body)
(match body
((locals ,x* ,tail)
`(locals ,x* ,(Tail tail)))))
(match program
((letrec ,bds ,body)
(: bds
(lambda (x* e*)
(let ((e* (map (lambda (e)
(match e
((lambda ,x* ,body)
`(lambda ,x* ,(Body body)))))
e*))
(body (Body body)))
(Letrec x* e* body)))))))这是完整的代码.
<program> ::= (letrec ((<label> (lambda (<uvar>*) <body>))*) <body>)
<tail> ::= <triv>
| (if <pred> <tail> <tail>)
| (begin <effect>* <tail>)
| (alloc <triv>)
| (mref <triv> <triv>)
| (<binop> <triv> <triv>)
| (<triv> <triv>*)
<pred> ::= (true)
| (false)
| (if <pred> <pred> <pred>)
| (begin <effect>* <pred>)
| (<relop> <triv> <triv>)
<effect> ::= (nop)
| (if <pred> <effect> <effect>)
| (begin <effect>* <effect>)
| (set! <uvar> <simple>)
| (mset! <triv> <triv> <triv>)
| (<triv> <triv>*)
<simple> ::= <triv>
| (alloc <triv>)
| (mref <triv> <triv>)
| (<binop> <triv> <triv>)
| (<triv> <triv>*)
<body> ::= (locals (<uvar>*) <tail>)
<triv> ::= <int> | <uvar> | <label>
<binop> ::= + | - | * | sra | logand
<relop> ::= = | < | > | <= | >=这是输出语言的句法, 已经没有了<value>.
以下是一些例子.
> (compil
'(let ((x 0) (y 1) (z 2))
(let ((counter (lambda ()
(set! x (+ x 1))
(set! z (+ z 2))
(cons x z))))
(counter)
(counter)
(counter))))
'(letrec ((counter.3$6
(lambda (cp.7)
(locals
(pair.8
tmp.12
tmp.15
tmp.14
tmp.13
tmp.16
tmp.19
tmp.18
tmp.17
tmp.20
tmp.22
tmp.21
tmp.24
tmp.23)
(begin
(set! tmp.12 (mref cp.7 6))
(set! tmp.13 (mref cp.7 6))
(set! tmp.14 (mref tmp.13 -3))
(set! tmp.15 (+ tmp.14 8))
(mset! tmp.12 -3 tmp.15)
(set! tmp.16 (mref cp.7 14))
(set! tmp.17 (mref cp.7 14))
(set! tmp.18 (mref tmp.17 -3))
(set! tmp.19 (+ tmp.18 16))
(mset! tmp.16 -3 tmp.19)
(set! tmp.20 (alloc 16))
(set! pair.8 (+ tmp.20 1))
(set! tmp.21 (mref cp.7 6))
(set! tmp.22 (mref tmp.21 -3))
(mset! pair.8 -1 tmp.22)
(set! tmp.23 (mref cp.7 14))
(set! tmp.24 (mref tmp.23 -3))
(mset! pair.8 7 tmp.24)
pair.8)))))
(locals
(t.5 y.1 t.4 z.2 x.0 box.9 box.10 counter.3 proc.11 tmp.25 tmp.26 tmp.27)
(begin
(set! t.5 16)
(set! y.1 8)
(set! t.4 0)
(set! tmp.25 (alloc 8))
(set! box.9 (+ tmp.25 3))
(mset! box.9 -3 t.5)
(set! z.2 box.9)
(set! tmp.26 (alloc 8))
(set! box.10 (+ tmp.26 3))
(mset! box.10 -3 t.4)
(set! x.0 box.10)
(set! tmp.27 (alloc 24))
(set! proc.11 (+ tmp.27 2))
(mset! proc.11 -2 counter.3$6)
(set! counter.3 proc.11)
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))
> (letrec ((counter.3$6
(lambda (cp.7)
(locals
(pair.8
tmp.12
tmp.15
tmp.14
tmp.13
tmp.16
tmp.19
tmp.18
tmp.17
tmp.20
tmp.22
tmp.21
tmp.24
tmp.23)
(begin
(set! tmp.12 (mref cp.7 6))
(set! tmp.13 (mref cp.7 6))
(set! tmp.14 (mref tmp.13 -3))
(set! tmp.15 (+ tmp.14 8))
(mset! tmp.12 -3 tmp.15)
(set! tmp.16 (mref cp.7 14))
(set! tmp.17 (mref cp.7 14))
(set! tmp.18 (mref tmp.17 -3))
(set! tmp.19 (+ tmp.18 16))
(mset! tmp.16 -3 tmp.19)
(set! tmp.20 (alloc 16))
(set! pair.8 (+ tmp.20 1))
(set! tmp.21 (mref cp.7 6))
(set! tmp.22 (mref tmp.21 -3))
(mset! pair.8 -1 tmp.22)
(set! tmp.23 (mref cp.7 14))
(set! tmp.24 (mref tmp.23 -3))
(mset! pair.8 7 tmp.24)
pair.8)))))
(locals
(t.5 y.1 t.4 z.2 x.0 box.9 box.10 counter.3 proc.11 tmp.25 tmp.26 tmp.27)
(begin
(set! t.5 16)
(set! y.1 8)
(set! t.4 0)
(set! tmp.25 (alloc 8))
(set! box.9 (+ tmp.25 3))
(mset! box.9 -3 t.5)
(set! z.2 box.9)
(set! tmp.26 (alloc 8))
(set! box.10 (+ tmp.26 3))
(mset! box.10 -3 t.4)
(set! x.0 box.10)
(set! tmp.27 (alloc 24))
(set! proc.11 (+ tmp.27 2))
(mset! proc.11 -2 counter.3$6)
(set! counter.3 proc.11)
(mset! counter.3 6 x.0)
(mset! counter.3 14 z.2)
(counter.3$6 counter.3)
(counter.3$6 counter.3)
(counter.3$6 counter.3))))
73
> (get-result 73)
'(3 . 8)> (compil
'(let ((even? (void))
(odd? (void)))
(set! even? (lambda (n)
(if (= n 0)
#t
(odd? (- n 1)))))
(set! odd? (lambda (n)
(if (= n 0)
#f
(even? (- n 1)))))
(even? 88)))
'(letrec ((t.6$8
(lambda (cp.9 n.2)
(locals
(t.10 tmp.19 tmp.20 tmp.21)
(if (= n.2 0)
14
(begin
(set! tmp.19 (mref cp.9 6))
(set! t.10 (mref tmp.19 -3))
(set! tmp.20 (mref t.10 -2))
(set! tmp.21 (- n.2 8))
(tmp.20 t.10 tmp.21))))))
(t.7$11
(lambda (cp.12 n.3)
(locals
(t.13 tmp.22 tmp.23 tmp.24)
(if (= n.3 0)
6
(begin
(set! tmp.22 (mref cp.12 6))
(set! t.13 (mref tmp.22 -3))
(set! tmp.23 (mref t.13 -2))
(set! tmp.24 (- n.3 8))
(tmp.23 t.13 tmp.24)))))))
(locals
(t.5
t.4
odd?.1
even?.0
box.15
box.16
t.6
proc.17
t.7
proc.18
t.14
tmp.25
tmp.26
tmp.28
tmp.27
tmp.30
tmp.29
tmp.31)
(begin
(set! t.5 30)
(set! t.4 30)
(set! tmp.25 (alloc 8))
(set! box.15 (+ tmp.25 3))
(mset! box.15 -3 t.5)
(set! odd?.1 box.15)
(set! tmp.26 (alloc 8))
(set! box.16 (+ tmp.26 3))
(mset! box.16 -3 t.4)
(set! even?.0 box.16)
(set! tmp.27 (alloc 16))
(set! proc.17 (+ tmp.27 2))
(mset! proc.17 -2 t.6$8)
(set! t.6 proc.17)
(mset! t.6 6 odd?.1)
(set! tmp.28 t.6)
(mset! even?.0 -3 tmp.28)
(set! tmp.29 (alloc 16))
(set! proc.18 (+ tmp.29 2))
(mset! proc.18 -2 t.7$11)
(set! t.7 proc.18)
(mset! t.7 6 even?.0)
(set! tmp.30 t.7)
(mset! odd?.1 -3 tmp.30)
(set! t.14 (mref even?.0 -3))
(set! tmp.31 (mref t.14 -2))
(tmp.31 t.14 704))))
> (letrec ((t.6$8
(lambda (cp.9 n.2)
(locals
(t.10 tmp.19 tmp.20 tmp.21)
(if (= n.2 0)
14
(begin
(set! tmp.19 (mref cp.9 6))
(set! t.10 (mref tmp.19 -3))
(set! tmp.20 (mref t.10 -2))
(set! tmp.21 (- n.2 8))
(tmp.20 t.10 tmp.21))))))
(t.7$11
(lambda (cp.12 n.3)
(locals
(t.13 tmp.22 tmp.23 tmp.24)
(if (= n.3 0)
6
(begin
(set! tmp.22 (mref cp.12 6))
(set! t.13 (mref tmp.22 -3))
(set! tmp.23 (mref t.13 -2))
(set! tmp.24 (- n.3 8))
(tmp.23 t.13 tmp.24)))))))
(locals
(t.5
t.4
odd?.1
even?.0
box.15
box.16
t.6
proc.17
t.7
proc.18
t.14
tmp.25
tmp.26
tmp.28
tmp.27
tmp.30
tmp.29
tmp.31)
(begin
(set! t.5 30)
(set! t.4 30)
(set! tmp.25 (alloc 8))
(set! box.15 (+ tmp.25 3))
(mset! box.15 -3 t.5)
(set! odd?.1 box.15)
(set! tmp.26 (alloc 8))
(set! box.16 (+ tmp.26 3))
(mset! box.16 -3 t.4)
(set! even?.0 box.16)
(set! tmp.27 (alloc 16))
(set! proc.17 (+ tmp.27 2))
(mset! proc.17 -2 t.6$8)
(set! t.6 proc.17)
(mset! t.6 6 odd?.1)
(set! tmp.28 t.6)
(mset! even?.0 -3 tmp.28)
(set! tmp.29 (alloc 16))
(set! proc.18 (+ tmp.29 2))
(mset! proc.18 -2 t.7$11)
(set! t.7 proc.18)
(mset! t.7 6 even?.0)
(set! tmp.30 t.7)
(mset! odd?.1 -3 tmp.30)
(set! t.14 (mref even?.0 -3))
(set! tmp.31 (mref t.14 -2))
(tmp.31 t.14 704))))
14
> (get-result 14)
#t> (compil
'(((lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x))))))
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10))
'(letrec ((h.0$8
(lambda (cp.9 fact.4)
(locals
(t.6 proc.18 tmp.22)
(begin
(set! tmp.22 (alloc 16))
(set! proc.18 (+ tmp.22 2))
(mset! proc.18 -2 t.6$10)
(set! t.6 proc.18)
(mset! t.6 6 fact.4)
t.6))))
(t.6$10
(lambda (cp.11 n.5)
(locals
(tmp.28 tmp.27 tmp.24 tmp.23 tmp.25 tmp.26)
(if (= n.5 0)
8
(begin
(set! tmp.23 (mref cp.11 6))
(set! tmp.24 (mref tmp.23 -2))
(set! tmp.25 (mref cp.11 6))
(set! tmp.26 (- n.5 8))
(set! tmp.27 (tmp.24 tmp.25 tmp.26))
(set! tmp.28 (sra tmp.27 3))
(* n.5 tmp.28))))))
(f.1$12
(lambda (cp.13 g.2)
(locals
(t.7 proc.19 tmp.29 tmp.31 tmp.30)
(begin
(set! tmp.29 (mref cp.13 6))
(set! tmp.30 (alloc 16))
(set! proc.19 (+ tmp.30 2))
(mset! proc.19 -2 t.7$14)
(set! t.7 proc.19)
(mset! t.7 6 g.2)
(set! tmp.31 t.7)
(h.0$8 tmp.29 tmp.31)))))
(t.7$14
(lambda (cp.15 x.3)
(locals
(t.16 tmp.33 tmp.32 tmp.34 tmp.35 tmp.36)
(begin
(set! tmp.32 (mref cp.15 6))
(set! tmp.33 (mref tmp.32 -2))
(set! tmp.34 (mref cp.15 6))
(set! tmp.35 (mref cp.15 6))
(set! t.16 (tmp.33 tmp.34 tmp.35))
(set! tmp.36 (mref t.16 -2))
(tmp.36 t.16 x.3))))))
(locals
(t.17 h.0 proc.20 f.1 proc.21 tmp.37 tmp.38 tmp.39)
(begin
(set! tmp.37 (alloc 8))
(set! proc.20 (+ tmp.37 2))
(mset! proc.20 -2 h.0$8)
(set! h.0 proc.20)
(set! tmp.38 (alloc 16))
(set! proc.21 (+ tmp.38 2))
(mset! proc.21 -2 f.1$12)
(set! f.1 proc.21)
(mset! f.1 6 h.0)
(set! t.17 (f.1$12 f.1 f.1))
(set! tmp.39 (mref t.17 -2))
(tmp.39 t.17 80))))
> (letrec ((h.0$8
(lambda (cp.9 fact.4)
(locals
(t.6 proc.18 tmp.22)
(begin
(set! tmp.22 (alloc 16))
(set! proc.18 (+ tmp.22 2))
(mset! proc.18 -2 t.6$10)
(set! t.6 proc.18)
(mset! t.6 6 fact.4)
t.6))))
(t.6$10
(lambda (cp.11 n.5)
(locals
(tmp.28 tmp.27 tmp.24 tmp.23 tmp.25 tmp.26)
(if (= n.5 0)
8
(begin
(set! tmp.23 (mref cp.11 6))
(set! tmp.24 (mref tmp.23 -2))
(set! tmp.25 (mref cp.11 6))
(set! tmp.26 (- n.5 8))
(set! tmp.27 (tmp.24 tmp.25 tmp.26))
(set! tmp.28 (sra tmp.27 3))
(* n.5 tmp.28))))))
(f.1$12
(lambda (cp.13 g.2)
(locals
(t.7 proc.19 tmp.29 tmp.31 tmp.30)
(begin
(set! tmp.29 (mref cp.13 6))
(set! tmp.30 (alloc 16))
(set! proc.19 (+ tmp.30 2))
(mset! proc.19 -2 t.7$14)
(set! t.7 proc.19)
(mset! t.7 6 g.2)
(set! tmp.31 t.7)
(h.0$8 tmp.29 tmp.31)))))
(t.7$14
(lambda (cp.15 x.3)
(locals
(t.16 tmp.33 tmp.32 tmp.34 tmp.35 tmp.36)
(begin
(set! tmp.32 (mref cp.15 6))
(set! tmp.33 (mref tmp.32 -2))
(set! tmp.34 (mref cp.15 6))
(set! tmp.35 (mref cp.15 6))
(set! t.16 (tmp.33 tmp.34 tmp.35))
(set! tmp.36 (mref t.16 -2))
(tmp.36 t.16 x.3))))))
(locals
(t.17 h.0 proc.20 f.1 proc.21 tmp.37 tmp.38 tmp.39)
(begin
(set! tmp.37 (alloc 8))
(set! proc.20 (+ tmp.37 2))
(mset! proc.20 -2 h.0$8)
(set! h.0 proc.20)
(set! tmp.38 (alloc 16))
(set! proc.21 (+ tmp.38 2))
(mset! proc.21 -2 f.1$12)
(set! f.1 proc.21)
(mset! f.1 6 h.0)
(set! t.17 (f.1$12 f.1 f.1))
(set! tmp.39 (mref t.17 -2))
(tmp.39 t.17 80))))
29030400
> (get-result 29030400)
3628800> (compil
'(letrec ((enum (lambda (a b)
(if (> a b)
'()
(cons a (enum (+ a 1) b)))))
(map (lambda (proc lst)
(if (null? lst)
'()
(cons (proc (car lst))
(map proc (cdr lst)))))))
(map (lambda (x) (* x x)) (enum 1 20))))
'(letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(locals
(pair.14 tmp.19 tmp.22 tmp.20 tmp.21 tmp.25 tmp.23 tmp.24)
(if (= lst.5 22)
22
(begin
(set! tmp.19 (alloc 16))
(set! pair.14 (+ tmp.19 1))
(set! tmp.20 (mref proc.4 -2))
(set! tmp.21 (mref lst.5 -1))
(set! tmp.22 (tmp.20 proc.4 tmp.21))
(mset! pair.14 -1 tmp.22)
(set! tmp.23 (mref cp.10 6))
(set! tmp.24 (mref lst.5 7))
(set! tmp.25 (map.1$8 tmp.23 proc.4 tmp.24))
(mset! pair.14 7 tmp.25)
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(locals
(pair.15 tmp.26 tmp.29 tmp.27 tmp.28)
(if (> a.2 b.3)
22
(begin
(set! tmp.26 (alloc 16))
(set! pair.15 (+ tmp.26 1))
(mset! pair.15 -1 a.2)
(set! tmp.27 (mref cp.11 6))
(set! tmp.28 (+ a.2 8))
(set! tmp.29 (enum.0$9 tmp.27 tmp.28 b.3))
(mset! pair.15 7 tmp.29)
pair.15)))))
(t.7$12
(lambda (cp.13 x.6) (locals (tmp.30) (begin (set! tmp.30 (sra x.6 3)) (* x.6 tmp.30))))))
(locals
(map.1 enum.0 proc.16 proc.17 t.7 proc.18 tmp.31 tmp.32 tmp.34 tmp.33 tmp.35)
(begin
(set! tmp.31 (alloc 16))
(set! proc.16 (+ tmp.31 2))
(mset! proc.16 -2 map.1$8)
(set! map.1 proc.16)
(set! tmp.32 (alloc 16))
(set! proc.17 (+ tmp.32 2))
(mset! proc.17 -2 enum.0$9)
(set! enum.0 proc.17)
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(set! tmp.33 (alloc 8))
(set! proc.18 (+ tmp.33 2))
(mset! proc.18 -2 t.7$12)
(set! t.7 proc.18)
(set! tmp.34 t.7)
(set! tmp.35 (enum.0$9 enum.0 8 160))
(map.1$8 map.1 tmp.34 tmp.35))))
> (letrec ((map.1$8
(lambda (cp.10 proc.4 lst.5)
(locals
(pair.14 tmp.19 tmp.22 tmp.20 tmp.21 tmp.25 tmp.23 tmp.24)
(if (= lst.5 22)
22
(begin
(set! tmp.19 (alloc 16))
(set! pair.14 (+ tmp.19 1))
(set! tmp.20 (mref proc.4 -2))
(set! tmp.21 (mref lst.5 -1))
(set! tmp.22 (tmp.20 proc.4 tmp.21))
(mset! pair.14 -1 tmp.22)
(set! tmp.23 (mref cp.10 6))
(set! tmp.24 (mref lst.5 7))
(set! tmp.25 (map.1$8 tmp.23 proc.4 tmp.24))
(mset! pair.14 7 tmp.25)
pair.14)))))
(enum.0$9
(lambda (cp.11 a.2 b.3)
(locals
(pair.15 tmp.26 tmp.29 tmp.27 tmp.28)
(if (> a.2 b.3)
22
(begin
(set! tmp.26 (alloc 16))
(set! pair.15 (+ tmp.26 1))
(mset! pair.15 -1 a.2)
(set! tmp.27 (mref cp.11 6))
(set! tmp.28 (+ a.2 8))
(set! tmp.29 (enum.0$9 tmp.27 tmp.28 b.3))
(mset! pair.15 7 tmp.29)
pair.15)))))
(t.7$12
(lambda (cp.13 x.6) (locals (tmp.30) (begin (set! tmp.30 (sra x.6 3)) (* x.6 tmp.30))))))
(locals
(map.1 enum.0 proc.16 proc.17 t.7 proc.18 tmp.31 tmp.32 tmp.34 tmp.33 tmp.35)
(begin
(set! tmp.31 (alloc 16))
(set! proc.16 (+ tmp.31 2))
(mset! proc.16 -2 map.1$8)
(set! map.1 proc.16)
(set! tmp.32 (alloc 16))
(set! proc.17 (+ tmp.32 2))
(mset! proc.17 -2 enum.0$9)
(set! enum.0 proc.17)
(mset! map.1 6 map.1)
(mset! enum.0 6 enum.0)
(set! tmp.33 (alloc 8))
(set! proc.18 (+ tmp.33 2))
(mset! proc.18 -2 t.7$12)
(set! t.7 proc.18)
(set! tmp.34 t.7)
(set! tmp.35 (enum.0$9 enum.0 8 160))
(map.1$8 map.1 tmp.34 tmp.35))))
361
> (get-result 361)
'(1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400)impose-calling-conventionsexpose-allocation-pointerA variable or register is in use, or live, at any given point, if the variable’s value might yet be needed by the program. In general, this is an undecidable property, so we conservatively assume that the variable is live if we cannot prove that it is not live. The traditional conservative approximation, which we use, is that a variable is live at a given point if any reference to the variable occurs along any flow of control from the given point before the variable is killed (overwritten) by an intervening assignment to the variable.
一个变量或者寄存器在某个给定点在使用中或者说活着, 如果变量(或者寄存器)的值还可能(之后)要被程序使用. 在一般情况下, 这是一个不可判定性质, 所以说我们保守地认为变量(或者寄存器)是活着的, 如果我们无法证明它不是活着的. 我们所使用的传统保守近似是, 一个变量(或者寄存器)在给定点活着, 如果从给定点起在这个变量被某个介入的赋值杀死 (覆写) 之前沿着任意的控制流出现了对于这个变量(或者寄存器)的引用.