自动CPS变换
1 前言
我最一开始听到 CPS 变换这个词是在王垠的博客里
(请求不要喷我)，就是那篇他第一次宣传他的40行代码的文章。
我当时什么都看不懂，所以没太注意，不过我也正在学程序语言方面的东西，
不久我就在 EOPL 和 The Little Schemer 里面又见到了 CPS。
我有点不服气，知道了 CPS 不过就是这么个东西，
于是我也开始想自己重造王垠40行代码，然后我很惊讶地也花了
刚好一个星期写了出来，而且还基本上跟他的一模一样……
(注意，我不是引战)
毕竟可能每个人有自己的思考方式，我在这里只是分享一下我自己的思路，
我写出这个 CPS 程序的经历。当然为了显得我稍微强一点的样子，
我把中间许多非常蠢的错误都省略了。
其实我也不知道我怎么就把这段代码写出来了。
我写出这个程序以后，又去看了那篇经典论文
Representing Control，
这里有一个更友好一点的版本
How to compile with continuations，
发现我的思路和他的完全不同，我反倒觉得我的思路很清楚，
他的思路我要绕个弯才能看懂，虽然实质上是一样的。
这篇文章不涉及什么是 CPS 变换，CPS 变换入门请参考 The Little Schemer，
我直接就开始写 cps 函数了，我们的目标就是王垠的那40行代码，
我也把我自己的程序的变量名什么的都改成了跟那段代码一样的格式，方便对照，
当然也有一些地方不一样，懒得改了。
我采用 Racket 语言，就是因为用起来方便一些。就这样了。
2 简单的CPS变换
其实一个正确的CPS变换程序，只要学过一点点写解释器的人都会写，
所以我就不细讲了，只是提供一个回忆，你如果要看下去的话最好是这个会自己写。
我们先只考虑λ-calculus的语法，就只有3个分支，变量，λ，函数调用。
先把最简单，没有经过优化的程序写出来。
主要的函数是cps1，它有两个参数expr和ctx，
expr就是一个s-expression，
ctx是当前的context，是一个symbol或‘(λ…)，
比如(cps1 ‘(f x) ‘(λ (x) x))的值为
‘(f x (λ (x) x))。所以(cps expr)函数
就是(cps1 expr ‘id)或(cps1 expr ‘(λ (x) x))，
我暂且用前者。
(define (cps expr) (define (atom? x) (not (pair? x))) (define n -1) (define (fv) (set! n (add1 n)) (string->symbol (string-append “v” (number->string n)))) (define (cps1 expr ctx) ….) (cps1 expr ‘id))
(define (cps1 expr ctx) (match expr [(? atom? expr) ….] [`(λ(,x) ,body) ….] [`(,rator ,rand) ….]))
或一个原始类型(比如123)时，
我们就直接把它返回，比方说，
(cps1 ‘x ‘k) ==> ‘(k x) (cps1 ‘x ‘(λ(x) ….)) ==> ‘((λ(x) ….) x)
[(? atom? expr) `(,ctx ,expr)]
只是先递归进函数体内，把函数体进行CPS变换。
每个λ的continuation都为‘k，比如，
(cps1 ‘(λ(x) x) ‘id) ==> ‘(id (λ(x k) (k x)))
[`(λ(,x) ,body) `(,ctx (λ(,x k) ,(cps1 body ‘k)))]
然后调用，举个例子，在我们最终要完成的代码里，应该大致是这样的，
(cps1 ‘((f a) (g b)) ‘id) ==> ‘(f a (λ(v0) (g b (λ(v1) (v0 v1 id)))))
v1是(g b)的结果，然后调用。
(cps1 ‘(f x) ‘id) ==> ‘((λ(v0) ((λ(v1) (v0 v1 id)) x)) f) <=> ‘(let ([v0 f]) (let ([v1 x]) (v0 v1 id)))
[`(,rator ,rand) (define v-rator (fv)) (define v-rand (fv)) (cps1 rator `(λ (,v-rator) ,(cps1 rand `(λ (,v-rand) (,v-rator ,v-rand ,ctx)))))]
(cps ‘((f a) (g b))) ==> ‘((λ (v4) ((λ (v5) (v4 v5 (λ (v0) ((λ (v2) ((λ (v3) (v2 v3 (λ (v1) (v0 v1 id)))) b)) g)))) a)) f)
不过算作是个很好的开头吧。
3 最简CPS输出
其实下面才开始真正的任务，上面一节只是因为，
市面上的程序都是分好几个函数，我要把它们合在一起。
上面的程序的问题就在于，当ctx是‘(λ (v) …v…)，
而且expr是一个‘x之类时，输出应该为
‘…x…而不是‘((λ (v) …v…) x)，
照λ-calculus的术语说就是产生了一个beta-redex。
我们来观察一下现在我们的CPS程序的3个分支产生的ctx
case 1:如果是一个atom，就产生`(,ctx ,expr)，这时ctx在函数的位置。
case 2:如果是λ表达式，ctx也在函数的位置。
case 3:但如果是函数调用，这时ctx在参数的位置((vf vx ctx))
很显然，在参数位置时ctx是不可能被化简的，因为结果必须是
(vf vx k/id)或(vf vx (λ (v?) ???))
的形式。而在函数位置时是有可能化简的，当它是λ函数的时候。
为了化简，我们把`(λ (v?) ???)
的quasiquote直接去掉，改成一个函数
(λ (v?) `???)，调用它就相当于直接把函数体里面的
v?替换掉了，比如
;; 原来的输出 ‘((λ(v0) (f v0)) x) ;; 现在变成 ((λ(v) `(f ,v)) x) ==> `(f ,x)
第二，如果ctx是‘k/id，
就改成(λ (out) `(k/id ,out))
因为总共就两种情况:ctx在函数位置和参数位置。
我们不妨把cps1函数的ctx参数改成两个，
一个叫ctx-f在函数位置，一个叫ctx-a在参数位置。
;; ctx-f : symbol -> s-exp
;; ctx-a : s-exp(define (cps1 expr ctx-f ctx-a) (match expr ….)) (cps1 expr (λ(out) out) ‘id)
(λ (out) out)就是id这个函数。因为原来的slideshow
‘id可以看成是`(λ (v?) v?)，所以化简后
就变成了(λ (out) out)
[(? atom?) (ctx-f expr)] [`(λ(,x) ,body) (ctx-f `(λ(,x k) ,(cps1 body (λ(out) `(k ,out)) ‘k)))]
其中有大量重复的代码，但是不管怎么说，先把代码写出来才是正道
(以下代码会需要一点耐心)
[`(,rator ,rand) (define v-rator (fv)) (define v-rand (fv)) (cps1 rator (λ(out-rator) (cps1 rand (λ(out-rand) `(,out-rator ,out-rand ,ctx-a)) `(λ(,v-rand) (,out-rator ,v-rand ,ctx-a)))) `(λ(,v-rator) ,(cps1 rand (λ(out-rand) `(,v-rator ,out-rand ,ctx-a)) `(λ(,v-rand) (,v-rator ,v-rand ,ctx-a)))))]
跟前面的结果对照一下就会看出明显区别了。
它不但可以处理beta-redex，还能正确处理尾递归。
这段代码应该也不难理解，只是分别讨论了函数和参数分别处于函数位置和参数位置的情况。
大致思路就是，首先，cps1要根据rator和rand
是否为一个atom来决定如何输出，其次，我们不愿意在递归进去之前就判断一次，
递归进去之后又要match expr(开头提到的那篇论文的方法就有这个问题)。
所以我们把现在的状态分成了两个参数，也一起递归进去。
它有唯一一个但很好修复的缺陷，就是v-rator和v-rand
定义地太早了，所以有时候会出现vn不连续的情况，
如果不嫌麻烦的话可以在每次第一次出现v-?的地方再
(let ([v-? (fv)]) ….)，当然这个代码看起来就……
另外，做出了下面一道习题后也会很好修复这个缺陷。
在判断出不是atom以后用‘vn调用ctx-f，
把它转换成ctx-a，这其实更接近王垠的版本。
甚至还有一个写法，就是利用多返回值，再返回一个布尔值表示当前的选择，
这个方法看起来会有些麻烦。就不提了。
(cps ‘(f x)) ==> (cps1 ‘f ctx-f ctx-a) ==> (ctx-f ‘f) ==> (cps1 ‘x …. ….)where[out-rator=‘f] ==> `(,out-rator ,out-rand id)where[out-rator=‘f out-rand=‘x] ==> ‘(f x id)
(cps ‘((f a) b)) ==> (cps1 ‘(f a) ctx-f ctx-a) ==> `(f a ,ctx-a)where[ctx-a=‘(λ(v0) (v0 b id))] ==> ‘(f a (λ(v0) (v0 b id)))
现在可以来看一下这段代码对我们有什么启发。
所谓的continuation-passing style多用一个参数k来告诉
我们要调用的函数当前的状态是什么，就是这个函数运行完了以后
应该干什么。但这里的cps函数也有一个参数ctx，
它也表示一个状态，它表示的是现在的状态，让更深层递归的函数能得知一些外部信息。
很多时候我们发现就传一个死的数据(比如第一个版本里的ctx)
是不够的，不但递归进去的函数需要这个数据，而这个数据也要随着当前的情况而变化。
在简单的情况下我们可以传好几个参数，或者一个对象进去，里面的函数
选择性地使用这些数据。但是在支持高阶函数的语言里很多时候方便很多，
因为我们可以传一个函数进去。
其中ctx是这样的，
这种模式更广泛的应用之处在于ctx的参数不是一个用来选择的符号，
而是一个连续数值或对象的时候。我一下子想不出实际的例子，
有了我会补充。
习题:请扩展这个程序以支持多参数的λ和函数调用。
令我惊讶的是，支持多参数就不用分4类讨论了!
因为只要分两类讨论，依次遍历整个列表就可以，
不用区分函数和参数，所以代码反倒简单多了。
推荐做一下这个习题。
4 简化 cps1 函数
这一节，我们把ctx-f和ctx-a合并成一个ctx
观察所有产生的ctx-f/a参数，总结一下总共有这些:
1. λ (out) `(k ,out)
2. ‘k
3. λ (out) …. `(…. ,out ….)
4. `(λ (,vn) …. (…. ,vn ….))
如果要只传一个参数的话，我们会发现，由2可以推出1,
因为我们只要给它包一个λ就可以了。
由3可以推出4，如果3是ctx，4就是
`(λ (,vn) ,(ctx vn))
问题就在于，13是一个形式的，24是一个形式的，
我们要选择的就是只传13还是只传24.
我们发现，13是两个固定的值，而24里面是有一堆省略号的，
也就是说，如果采用一点类似作弊的策略，从1也可以推出2，
只要判断ctx是否等于(λ (out) `(k ,out))。
但是无论如何也不可能从任意的4推出3(当然你如果使用eval
的话，我就没话说了，按理来说是可以的，你可以自己尝试一下，
成功了记得偷偷告诉我一声。
于是，我们决定采用13型的ctx。
就是把ctx-f转成ctx-a
只要改为(ctx-f->a ctx-f)就可以了。
因为能这样直接转化，所以也没有必要传两个ctx参数了，
我们在需要用到ctx-a时现转化就可以，于是，我们最终得到了这样的代码。
(define (cps1 expr ctx) (match expr [(? atom? expr) (ctx expr)] [`(λ(,x) ,body) (ctx `(λ(,x k) ,(cps1 body ctx1)))] [`(,rator ,rand) (cps1 rator (λ (out-rator) (cps1 rand (λ (out-rand) `(,out-rator ,out-rand ,(ctx-f->a ctx))))))]))
如果对照一下王垠的CPS变换的最后几行，你会发现我的这个版本甚至更清晰一些，
因为我用ctx-f->a这个函数避免了`(,out-rator ,out-rand ….)
这样重复的代码，并把判断也放进了这个辅助函数中。
你现在可以自己随意试验这个程序了。
下面我们对它进行一些扩展，先增加多参数的λ和函数调用，
然后是原生的几个函数(比如+,–,zero?等)，
最后添加if语句。
5 多参数和原生函数
都已经到这一步了，支持多参数其实很简单。
[(? atom? expr) (ctx expr)]
[`(λ ,args ,body) (ctx `(λ(,@args k) ,(cps1 body ctx1)))]
[_ ; else : expr = ‘(,rator . ,rands) (let recur ([exprs expr] [acc ‘()]) (if (null? exprs) `(,@acc ,(ctx-f->a ctx)) (cps1 (car exprs) (λ(v) (recur (cdr exprs) `(,@acc ,v))))))]
思路就是这样，首先最后返回值肯定是
(cps1 (car exprs) (λ (v) ….))
然后省略号要填的是，递归遍历(cdr exprs)，所以结构必须是这样的，
(let recur ([exprs expr]) (cps1 (car exprs) ; when exprs is not null (λ (v) (recur (cdr exprs)) (process-v))))
我们需要把之前所有的v : v1 v2 v3 ….收集起来，
返回`(,v1 ,v2 ,v3 …. ,vn ,(ctx-f->a ctx))，
因此再多一个变量acc，用来收集这些v。
这个程序就完成了。你可以自己试验一下确保它正确。
(cps ‘(+ x y)) ;; instead of (+ x y id) ==> ‘(+ x y) (cps ‘(+ (f x) y)) ==> ‘(f x (λ(v0) (+ v0 y))) (cps ‘(+ (* x y) z)) ==> ‘(+ (* x y) z) ;; when used as higher order procedure (cps ‘(((λ(m) +) n) ; returns + x y)) ==> ‘((λ(m k) (k +)) n (λ(v0) (v0 x y id)))
[_ (let recur ([exprs expr] [acc ‘()]) (if (null? exprs) (if (trivial? (car acc)) …. `(,@acc ,(ctx-f->a ctx))) (cps1 (car exprs) (λ(v) (recur (cdr exprs) `(,@acc ,v))))))]
6 if语句
比如，
(cps ‘(λ(x) (if a b (f c)))) ==> ‘(λ(x k) (if a (k b) (f c k)))
[`(if ,test ,conseq ,alt) (cps1 test (λ(t) `(if ,t ,(cps1 conseq ctx) ,(cps1 alt ctx))))]
结果发现，这里的ctx是会被翻倍的。
(cps ‘(λ(x) (f (if a b c)))) ==> ‘(λ (x k) (if a (f b k) (f c k)))
(cps ‘(λ(x) (f (g (h (if a b c)))))) ==> ‘(λ (x k) (if a (h b (λ (v0) (g v0 (λ (v1) (f v1 k))))) (h c (λ (v2) (g v2 (λ (v3) (f v3 k))))))) (cps ‘(λ(x) (if (if a b c) d e))) ==> ‘(λ (x k) (if a (if b (k d) (k e)) (if c (k d) (k e))))
第一个例子里面，(h b/c ….)就只有b和c不同，
后面完全一样，第二个例子也是这样。
(cps ‘(λ(x) (f (if a b c)))) ==> ‘(λ(x k) (let ([k (λ(v0) (f v0 k))]) (if a (k b) (k c)))) (cps ‘(λ(x) (if (if a b c) d e))) ==> ‘(λ(x k) (let ([k (λ(v0) (if v0 (k d) (k e)))]) (if a (k b) (k c))))
[`(if ,test ,conseq ,alt) (define (if-body ctx) (cps1 test (λ(t) `(if ,t ,(cps1 conseq ctx) ,(cps1 alt ctx))))) (if (ctx1? ctx) (if-body ctx) `(let ([k ,(ctx-f->a ctx)]) ,(if-body ctx1)))]
(cps ‘(if a b c)) ==> ‘(let ([k (λ(v0) v0)]) (if a (k b) (k c)))
(define (cps expr) …. (cps1 expr id))
感觉不爽的话，可以这么改一下，
(define (ctx-f->a ctx) (cond [(ctx1? ctx) ‘k] [(id? ctx) ‘id] [else (define v (fv)) `(λ(,v) ,(ctx v))])) ;; 话说这里用 case 语句会更舒服一点的…
7 总结
这么多代码看下来，其实你会发现，就只有几个关键点，
只要想到了，其实也没有多难。我自己想这个程序的时候，手头上没有电脑，
我是写在纸上的(好痛苦啊)，但是放到电脑上测试，一次性就全是对的，
毕竟不是很大的工程，也没有各种复杂的角角落落需要考虑，思路还是很简单的。
这个程序还有升级空间，就是 begin 和 set! 语句，提示一下，
东西越来越复杂的时候，可能不得不回归到第3节中的方式，把各种 ctx 拆开，
否则处理 set! 的时候会产生一堆嵌套的 begin 语句。
另外，如果是Common Lisp里的那种有返回值的赋值语句，处理起来会简单一些，
因为可以简单地看作一个表达式。
最后就随便说说，其实这段代码也没有特别的高级，只是自己写出来了，那就开心一下就好。
代码里倒是有几个挺特别的想法值得学习。
没得写了，就打个广告吧，本文章用 scribble 生成，
不过用它只是因为，它是唯一一个支持racket代码高亮的……
文笔不好请见谅，有任何错误或写的不好的地方欢迎指出。
(define (cps expr) (define (atom? x) (not (pair? x))) (define n -1) (define (fv) (set! n (add1 n)) (string->symbol (string-append “v” (number->string n)))) (define ctx1 (λ(out) `(k ,out))) (define (ctx1? ctx) (eq? ctx ctx1)) (define (ctx-f->a ctx) (if (ctx1? ctx) ‘k (let ([v (fv)]) `(λ(,v) ,(ctx v))))) (define (trivial? x) (memq x ‘(zero? add1 sub1 + – * /))) (define id (λ(x) x)) (define (id? x) (eq? x id)) (define (cps1 expr ctx) (match expr [(? atom?) (ctx expr)] [`(if ,test ,conseq ,alt) (define (if-body ctx) (cps1 test (λ(t) `(if ,t ,(cps1 conseq ctx) ,(cps1 alt ctx))))) (if (or (ctx1? ctx) (id? ctx)) (if-body ctx) `(let ([k ,(ctx-f->a ctx)]) ,(if-body ctx1)))] [`(λ ,args ,body) (ctx `(λ(,@args k) ,(cps1 body ctx1)))] [_ (let recur ([exprs expr] [acc ‘()]) (if (null? exprs) (if (trivial? (car acc)) (ctx acc) `(,@acc ,(ctx-f->a ctx))) (cps1 (car exprs) (λ(v) (recur (cdr exprs) `(,@acc ,v))))))])) (cps1 expr id))