P423笔记

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的后端.

作业15: parse-scheme

这次作业仅需要完成parse-scheme, 目的主要是将最初的源语言规约为更加紧凑的形式, 并对于输入进行一些简单的验证, 排除一些基本的错误. 当然, 顺便进行一下$\alpha$变换, 使得变量名唯一, 这是之后诸多分析和变换的基础.

虽然概念上没有什么复杂的地方, 但是写起来有许多细节问题, 导致我当初写得非常难受, 似乎也犯了不少错误. 不过, 最终我的代码和主流也稍微有所不同, 因为我试图解决一类常见但也经常不被注意到的问题, 就是绑定可以引入名字和关键词相同的变量, 这时的处理我选择和一般的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

我现在意识到我几年前写的每个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))))

(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^, 这反映了两者在语义上的不同.

让我们来看几个例子. 注意, 变量的编号并不重要, 应该$\alpha$等价地阅读.

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

作业14: convert-complex-datum

这次作业需要编写多个pass, 不过先让我们来完成convert-complex-datum. 这个pass的目的在于将复杂的<datum>转换为简单的<immediate>, 其中<immediate>的句法为

<immediate> ::= ()
             |  <boolean>
             |  <fixnum>

'(#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))

既然在一开始就分配这些常量, 我们需要在执行的过程中记录一些绑定. 这些绑定可以随着执行过程一起传递, 也可以定义一个全局变量, 通过赋值来积累这些绑定. 在这里更多是一种口味问题, 我认为没有明显的优劣, 两种风格我都尝试过.

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

作业14: 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>*)

编写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)))))

作业14: purify-letrec

老实说, 我并不真正理解purify-letrec. 但是, 既然它将要做的事情描述得很明确, 只是写一写没有多大问题.

letrec的问题在于它太灵活了, 其实对它稍作限制, 也不会影响任何常见程序的表达. 不过, 既然Scheme的原则就是消除限制, 那么我就不得不严肃一点思考怎么处理letrec.

如果一个Scheme实现不提供letrec, 那么我们可以通过宏来实现letrec, 其中最简单但也最低效的转换方式是将

(letrec ((x e) ...) body)

(let ((x (void)) ...)
  (let ((t e) ...)
    (set! x t)
    ...
    body))

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 letrec expression and no applications unless nested within lambda expressions. The latter constraint prevents simple expressions from reaching a call to call/cc if we ever add call/cc to our language. Of course, at that time we would also rule out primitive calls to call/cc itself. It would also make sense to disallow letrec expressions, to prevent this pass from becoming nonlinear, and to disallow other expressions, such as lambda expressions, to reduce the cost of the simple check. 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的绑定划分为了

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

(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也是.

作业14: convert-assignments

convert-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))))

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

作业13: optimize-direct-call

optimize-direct-call是一个简单的优化步骤, 所以它不会改变句法. 它的想法也非常简单, 就是将

((lambda (x ...) body) e ...)

(let ((x e) ...) body)

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

作业13: remove-anonymous-lambda

顾名思义, remove-anonymous-lambda是为了消除匿名的lambda. 所谓的匿名lambda, 指的是没有直接出现在let或者letrec右支的lambda. 对于藏在右支而非直接出现的情况, 当然也应该视为匿名的.

对于匿名lambda的处理是很简单的, 即为其赋一个名字而已. 换言之, 匿名的

(lambda (x ...) body)

(letrec ((t (lambda (x ...) body))) 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)))

作业13: sanitize-binding-forms

sanitize-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)

作业12: 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)))

作业12: convert-closures

顾名思义, convert-closures进行闭包变换, 不过实际上它只是闭包变换的第一步, 而或许uncover-free应该算作闭包变换的第零步.