光剑系列的第七作！
前六作：
朱约（juyo）/瓦帕德（vaapad）是光剑七式的最后一技。很高兴我们的“光剑”终于抵达了这里！不过也许会有续集。
[此处应有温杜的图片]
一点说明#
我更新了工具，本文使用 racket（scheme 的一种实现和变体）完成。这些代码大多可以直接挪用在 scheme 中，但是 match 除外，请使用自己的模式匹配库。我也转载了一个简单的模式匹配库：https://www.luogu.com.cn/article/4kw6oewn
注意使用 #lang racket。
发现有不少 racket 的在线环境，懒得下 racket 的话可以直接用。给一个：https://onecompiler.com/racket
在前作中，我们提到过“call/cc”也即“call-with-current-continuation”的存在。它可以捕获当前的“续延”（coutinuation）并将它作为一个一等公民值。
续延代表程序的“计算上下文”，也即“我们接下来要做什么？”调用一个续延，可以让我们瞬间跳回续延被捕获的那个时间点，还原环境（包括堆和栈，不过那是具体的内存模型。环境是更抽象的“数据上下文”。）以及更重要的，“计算”。
看上去真是神秘又强大（事实上，从 call/cc 和条件判断，我们可以造出其余的所有控制流。）。我们的第五作实现了一个 scheme 子集的解释器，但是也没有实现这个功能。
那么，这个操作是如何实现的呢？“剩下的计算”是如何被表示的呢？这就是我们今天要探讨的话题。
CPS 变换#
一个例子#
先看下面这段代码：
1
2
3
4
5
6
| (define (fact-cps n k)
(if (= n 0)
(k 1)
(fact-cps
(- n 1)
(lambda (v) (k (* v n))))))
|
从名字就可以看出，这是一个计算阶乘的函数。不过它看上去非常的不同寻常。
那个叫做“k”的参数是什么东西？它在干什么？
事实上，这个“k”就是一个外部传入的续延。它代表“当前函数执行完毕后，还要进行哪些操作”。
现在让我们来看看代码。条件判断很寻常。
递归终止条件是第一个用到 k 的地方。这里，我们向 k 传递了一个参数 1.
在正常的代码中，这里本来应该是向上层返回 1. 那么，(k 1) 是什么意思呢？
自然是“返回 1”。不过这里不是隐式的返回，而是显式的续延调用。我们向续延 k 传递了一个值，表示当前函数的返回值。
第二个分支是另一个用到续延的地方。这里其实纯粹是对第一个分支的适配：在正常的递归阶乘中，我们应当“返回 (* n (fact (- n 1)))”，但是在这个特殊的阶乘函数中，我们会将计算结果传递给一个续延。
那么我们要做的是什么？是“计算出 n-1 的阶乘的值，然后乘以 n，再传递给续延”。
第一步是算出 n-1 的阶乘。这可以通过一个对 fact-cps 的递归调用搞定。不过这次调用需要给出续延。所以我们来需要确定续延是什么。
在算出 n-1 的阶乘之后，我们需要将它乘以 n，然后传递给外层续延 k 来返回。所以，“接下来要做的事情”就是“乘以 n，然后传递给 k”。写成代码，就是 (lambda (v) (k (* n v)))，也就是 fact-cps 做的。这样我们就理解了这个代码。
我们在干什么#
上面的代码，正如它的名称，是“CPS”（coutinuation passing style）的。这是一种特殊的代码风格，我们不再使用隐式的函数返回等控制流，而是显式的调用续延。函数不再返回。
它有什么用？#
CPS 将控制流显式化了，变成了一个普通的函数“续延”。这就使得 call/cc 一类的对续延的操作成为可能。事实上，call/cc 只需要直接捕获当前续延即可。
CPS 将控制流显式化之后，可以方便很多控制流上的分析和优化的进行。它是各种 FP 语言编译器广泛使用的 IR。
同时，CPS 之后的代码全都是尾调用的，这可以避免栈溢出（不过注意，调用栈被作为控制流的一部分存储到了续延里，所以会消耗堆内存）。
在理论上，将“控制上下文”显式的提取出来，是一个很优雅的东西。这展示了过程和数据的等价性。环境是数据的上下文，可以被显式提取，续延就是计算的上下文，也可以被提取。
自动 CPS 变换#
没有自己动手的光剑是没有灵魂的！让我们来写一些东西，对接收到的代码片段自动进行 CPS 变换。
让我们从最简单的地方入手：lambda calculus。只有函数抽象和函数应用两种语法，函数都有且仅有一个参数。
这样我们只需要处理函数抽象表达式，函数应用表达式和标识符原子三种情况。
提示：下面的内容请尽量自己动手完成而不是仅仅看我的说明。动手得到的理解远比观摩更加深刻。我用了好几个小时才写出了正确的代码，这个习题没有那么简单。
进行一些分类讨论。首先考虑函数应用。
(f a) 应当怎样处理呢？
首先，我们应该先对 a 进行 CPS 变换。不过，这里需要提供续延，我们要知道算出来 a 之后要干什么。
要干什么？要将 f 应用于 a，然后返回。返回等价于调用外部续延 k。所以，a 的续延就是 (lambda (v) (k (f v))。但这里的 f 也需要进行 CPS 变换。它的续延是什么呢？什么都不是。我们拿到 f 的值之后仅仅是用它造出 a 的续延罢了。所以我用了一个占位符 identity 代表恒等变换（这个函数在 racket 里是有定义的）
这样可能产生一些冗余的恒等变换，所以我们写了 wrap 函数，多加了一些逻辑来去掉它们。
第二个 case 是函数抽象。这里请注意不要犯唐：lambda 是函数抽象，它最终的返回值不能直接传递给它定义处的续延！否则，每次调用这个函数都会直接跳回它定义的时间点，这简直不堪设想。
正确的做法是，在函数后面多加一个参数代表续延，在调用时把调用时的续延传进去，然后在里面用这个续延。
另一个问题：lambda 的抽象得到的是一个值。它就像其他普通的值一样，需要被传递给当前续延。不要忘记这点。
第三个 case 是原子（标识符）。这个应该随便写。不用我说了。
大功告成！
……等等。
真的吗？
似乎有什么东西不对。
想想函数应用的过程？
我们把参数传进了一个包含操作符的续延中。
这会有什么问题？
求值顺序。求值顺序反了。续延作为一个函数会延迟求值。于是，参数就会比操作符先求值。
在纯的 lambda 中，这问题不大。但是，如果引入副作用，这就不好弄了。
于是你可能会尝试修正。不过先别急，如果你修正之后的代码里面出现了形如 ((lambda (f1) (k (f1 x))) f) 这样的东西，那么恭喜你，你又掉进了一个大坑。
这个坑很简单：上面的代码根本不是 CPS 形式！
CPS 要求所有函数调用都是尾调用，一个隐含的要求是，函数参数必须都是原子。因为如果一个函数调用被放在参数上，根据应用序求值的规则，它就会在主调用之前先求值，并将返回值递给主调用。这里，“返回值”是重点，它是我们不希望的隐式控制流。
而上面，我们正是“计算 (f1 x) 的返回值，然后传递给 k”，而不是由 f1 自己调用 k。
正确的做法是什么呢？想想我们上面的 fact-cps 函数。它多了一个接受续延的参数。并且在函数内部需要返回时由函数自己（而不是隐式控制流）调用续延。
那么可能就比较好做了。(f a) 的正确变换形式是 (f a k)。
于是我们修正代码。我们该做什么呢？首先对 f 进行 CPS 变换，将 k 作为续延加一个参数进去。然后对 a 进行 CPS，续延是 identity（原封不动返回），传递给 (lambda (v1) (f v1 k)) 这样的表达式。
似乎很对，也能正确处理 ((f g) a)。
不过很可惜。你会发现 (f (g a)) 的变换中出现了 (g a identity) 这样的东西！
为什么！我们都在 wrap 中去掉了 identity，为什么它会出现！
原因很简单，因为这个 identity 并不是被包裹上去的，而是作为续延加进参数里的，它根本就没有经过 wrap 的过程。
你可能会想我们把上面的过程反一下就行了。但事实上你反过来之后 ((f g) a) 又会出问题。这两个形式你只能写对一个。
让问题暴露的更明显些。
试试这个：(cps '((f g) (r h)) 'k)
问题在于“续延的循环定义”！(f g) 这个值，对它进行 CPS 时要知道它“接下来要做的事”。而这个事是“应用于 (r h) 的 CPS 形式，并以 k 作为续延”。这就要对 (r h) 进行 CPS，又要知道 (r h) 的续延，这个续延又要用到 (f g) 的变换结果。
怎么办？我们似乎陷入了死胡同。
为了解决这个问题，我们首先需要知道正确的变换是什么。
1
2
3
4
5
6
7
8
9
10
| ((lambda (v1151)
((lambda (v1152) (v1151 v1152
(lambda (v1147)
((lambda (v1149)
((lambda (v1150)
(v1149 v1150 (lambda (v1148) (v1147 v1148 k))))
h))
r))))
g))
f)
|
看上去很难绷，但实际上很容易理解。它先进行了 (f g) 这一步，然后将一个东西（(lambda (v1147) ...)）扔进去作为续延，捕获返回值（绑定在 v1147 上），然后再算 (r h)，用一个续延捕获返回值，最后计算 ((f g) (r h))，并传入 k 作为续延，收集返回值。
上面的代码由自动变换器生成，带有一些冗余。进行一些 beta reduction 能看得更清楚：
1
| (f g (lambda (v0) (r h (lambda (v1) (v0 v1 k)))))
|
知道了正确的变换形式，那么如何修正程序的错误呢？
其实错误的本质很简单：就是 identity 占位符的问题。我们企图用它“原封不动地返回一个表达式变换后的形式”，然后构建新代码，但这一步里其实已经用到了“返回”这个隐式控制流。
但是表达式变换后的值不捕获是不行的。如何捕获？
很简单，利用续延。就像 call/cc 的形式是“包裹一个表达式，将捕获的续延作为参数传递进去”一样，我们也在续延中构建一个 lambda，将表达式作为它的参数捕获，之后再搞事情。
那么正确的代码就很简单了：
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
| #lang racket
(define (atom? x) (not (pair? x)))
(define wrap list)
(define (cps exp k)
(match exp
[`(lambda (,bind) ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda (,bind ,c) ,(cps body c)))])
(wrap k res))]
[`(,exp1 ,exp2)
(let ([c1 (gensym 'v)]
[c2 (gensym 'v)])
(let ([res (cps exp1 `(lambda (,c1) ,(cps exp2 `(lambda (,c2) (,c1 ,c2 ,k)))))])
res))]
[x #:when (atom? x) (wrap k x)]))
|
（由于不再使用 identity 占位符，wrap 可以直接定义为 list 而省去多余的检查）
当然，它生成的代码还有冗余。就像上面那个例子一样，出现了好多个不需要的 lambda。其实等价于 let（let 脱糖之后就是那个样子），也就是说我们给一些变量起了不必要的别名。
下一步就是去除这些冗余。
我们发现，所有的冗余都是在函数应用这一步产生的。它产生了一些可以被 beta-reducation 消除的类似于 let 的模式。
为什么呢？因为我们给什么东西都传了一个续延进去用来捕获它的“返回值”。对于函数应用的模式，这是必要的。但是对于函数抽象和原子值，就会变成无用的别名（因为它们是自求值的）。这时可以直接用 identity 捕获它们的值，然后嵌入进去，就相当于一个 beta-reducation。
变换之后做规约也是可以的，但是会变得更麻烦。不如在变换途中解决掉。
这里我们需要分类讨论 exp1 和 exp2 是否是自求值的。于是就有 4 种情况，需要复制粘贴 4 份极其类似的代码（终于理解于梓文说的“接下来会有很多重复的代码”是什么意思了，果然实践出真知）
并且由于代码太过冗长，我们构造了一些过程抽象。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
| #lang racket
(define (atom? x) (not (pair? x)))
(define (wrap k exp)
(if (eq? k 'identity)
exp
(list k exp)))
(define (is-app-exp? exp)
(match exp
[`(,exp1 ,exp2) #t]
[else #f]))
(define (calc-res exp1 exp2 c1 c2 k)
(if (is-app-exp? exp1)
(if (is-app-exp? exp2)
(cps
exp1
`(lambda (,c1)
,(cps
exp2
`(lambda (,c2) (,c1 ,c2 ,k)))))
(cps
exp1
`(lambda (,c1)
(,c1 ,(cps
exp2
'identity) ,k))))
(if (is-app-exp? exp2)
(cps exp2 `(lambda (,c2) (,(cps exp1 'identity) c2 k)))
`(,(cps exp1 'identity) ,(cps exp2 'identity) ,k))))
(define (cps exp k)
(match exp
[`(lambda (,bind) ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda (,bind ,c) ,(cps body c)))])
(wrap k res))]
[`(,exp1 ,exp2)
(let ([c1 (gensym 'v)]
[c2 (gensym 'v)])
(calc-res exp1 exp2 c1 c2 k))]
[x #:when (atom? x) (wrap k x)]))
#|
> (displayln (cps '((f g) (r h)) 'k))
(f g (lambda (v1149) (r h (lambda (v1150) (v1149 v1150 k)))))
> (displayln (cps '(lambda (f) (lambda (g) ((f g) (r h)))) 'k))
(k (lambda (f k1147) (k1147 (lambda (g k1148) (f g (lambda (v1149) (r h (lambda (v1150) (v1149 v1150 k1148)))))))))
|#
|
生成的代码可读性感觉好多了。
这样，我们就成功的造出了 lc-exp 的 CPS 变换器。接下来，我们可以为它添加更多功能：define，多参数 lambda，原生数据类型，内建函数，等等。
我们先从多参 lambda 入手。这是一个具有挑战的特性：我们之前的函数调用相当于人肉特判了控制流，现在我们要找到通解。
一开始就去掉冗余有点困难，所以我们先从最原始的，有冗余的版本入手。
多参函数应用怎么做呢？
1
2
| (cps `(,r0 ,r1 ,r2 ...) k) =
(cps r0 `(lambda (,v0) ,(cps r1 `(lambda (,v1) ...))))
|
简单来说，“从左到右，对操作符和各操作数依次求值，最后应用”。不过现在是用续延实现。
看上去不是很好实现。人肉做不太现实，考虑递归。
边界：一个操作数。我们维护一个环境，代表之前遇到的一切参数名。
这时把所有参数名依次放进列表里，再加上续延 k 就行了。
1
2
3
4
5
| (cps `(,r0 . ,rest) k env) =
(cps r0 `(lambda (,v0) ,(cps rest k (cons v0 env))))
(cps `(,f) k env) =
(cps f `(lambda (,v) ,(reverse (cons k (cons v env)) '())
|
伪代码大概就是上面那样。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
| #lang racket
(define (atom? x) (not (pair? x)))
(define wrap list)
(define (cps1 exp k env)
(match exp
[`(lambda ,bind ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda ,(append bind (list c)) ,(cps1 body c '())))])
(wrap k res))]
[`(,exp)
(let ([c1 (gensym 'v)])
(cps1 exp `(lambda (,c1) ,(reverse (cons k (cons c1 env)))) '()))]
[`(,exp1 . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(cps1 exp1 `(lambda (,c1) ,(cps1 rest k (cons c1 env))) '()))]
[x #:when (atom? x) (wrap k x)]))
(define (cps exp) (cps1 exp 'ctx0 '()))
|
实现出来就是这样。
下一步考虑复现去冗余。这里不再需要分 4 类讨论了，只需要分 2 类即可：当前处理的参数是否是一个函数应用。如果不是，就内联进去而不使用续延绑定。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
| #lang racket
(define (atom? x) (not (pair? x)))
(define (wrap k exp)
(if (eq? k 'identity)
exp
(list k exp)))
(define keywords '(lambda))
(define (is-app-exp? exp)
(not (or (atom? exp) (member (car exp) keywords))))
(define (cps1 exp k env)
(match exp
[`(lambda ,bind ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda ,(append bind (list c)) ,(cps1 body c '())))])
(wrap k res))]
[`(,exp)
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp)
(cps1 exp `(lambda (,c1) ,(reverse (cons k (cons c1 env)))) '())
(reverse (cons k (cons (cps1 exp 'identity '()) env)))))]
[`(,exp1 . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp1)
(cps1 exp1 `(lambda (,c1) ,(cps1 rest k (cons c1 env))) '())
(cps1 rest k (cons (cps1 exp1 'identity '()) env))))]
[x #:when (atom? x) (wrap k x)]))
(define (cps exp) (cps1 exp 'ctx0 '()))
|
真成四十行代码了
这是一个不错的成果。接下来，让我们考虑加入对 define 语法的支持。
这不难。一个 define 语句不返回任何值，所以它内部不会调用外部的续延。所以，只需要对要绑定的值进行 CPS 变换（续延为 identity）即可。
也就是在模式匹配中加入这个分支：
1
2
| [`(define ,id ,exp)
`(define ,id ,(cps1 exp 'identity '()))]
|
但是你发现了吗？控制流在这里又断掉了。define 很特殊，它不返回任何值，也不是一个有函数调用的动作。它只不过是创建一个绑定，实在不应该出现在控制流里。
我没有什么好办法来修复它。不过用一个 begin 把 define 和续延调用包起来有用。
1
2
| [`(define ,id ,exp)
`(begin (define ,id ,(cps1 exp 'identity '())) (,k #f))]
|
为了统一 define 和其他表达式的处理，我们给续延传递了一个没有任何意义的值充当占位符。
完整代码：
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
| #lang racket
(define (atom? x) (not (pair? x)))
(define (wrap k exp)
(if (eq? k 'identity)
exp
(list k exp)))
(define keywords '(lambda define))
(define (is-app-exp? exp)
(not (or (atom? exp) (member (car exp) keywords))))
(define (cps1 exp k env)
(match exp
[`(define ,id ,exp)
`(begin (define ,id ,(cps1 exp 'identity '())) (,k #f))]
[`(lambda ,bind ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda ,(append bind (list c)) ,(cps1 body c '())))])
(wrap k res))]
[`(,exp)
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp)
(cps1 exp `(lambda (,c1) ,(reverse (cons k (cons c1 env)))) '())
(reverse (cons k (cons (cps1 exp 'identity '()) env)))))]
[`(,exp1 . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp1)
(cps1 exp1 `(lambda (,c1) ,(cps1 rest k (cons c1 env))) '())
(cps1 rest k (cons (cps1 exp1 'identity '()) env))))]
[x #:when (atom? x) (wrap k x)]))
(define (cps exp) (cps1 exp 'ctx0 '()))
|
我们的 CPS 变换器还有一个严重的限制：整个程序只能有一个函数，整个函数只能有一个表达式作为函数体。这是非常不好的。
解决这个限制，我们只需要引入 begin 特殊形式。
begin 特殊形式和普通的函数调用几乎一模一样。不过，它不会将操作符求值之后应用于操作数，而是保留最后一个表达式的值，将前面其他表达式的返回值都丢弃。
这样就可以处理有多个表达式的函数体。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
| #lang racket
(define (atom? x) (not (pair? x)))
(define (wrap k exp)
(if (eq? k 'identity)
exp
(list k exp)))
(define keywords '(lambda define begin))
(define (is-app-exp? exp)
(not (or (atom? exp) (member (car exp) keywords))))
(define (cps1 exp k arg-acc)
(match exp
[`(define ,id ,exp)
`(begin (define ,id ,(cps1 exp 'identity '())) (,k #f))]
[`(lambda ,bind . ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda ,(append bind (list c)) ,(cps1 (cons 'begin body) c '())))])
(wrap k res))]
[`(begin ,exp)
(cps1 exp k '())]
[`(begin ,exp . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(cps1 exp `(lambda (,c1) ,(cps1 (cons 'begin rest) k '())) '()))]
[`(,exp)
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp)
(cps1 exp `(lambda (,c1) ,(reverse (cons k (cons c1 arg-acc)))) '())
(reverse (cons k (cons (cps1 exp 'identity '()) arg-acc)))))]
[`(,exp1 . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp1)
(cps1 exp1 `(lambda (,c1) ,(cps1 rest k (cons c1 arg-acc))) '())
(cps1 rest k (cons (cps1 exp1 'identity '()) arg-acc))))]
[x #:when (atom? x) (wrap k x)]))
(define (cps exp) (cps1 exp 'ctx0 '()))
|
你注意到它在处理 begin 时会产生一些看似可以约减的代码（比如 ((lambda (x) y) z)）。但是那些代码约减不了，约减之后某些变量就不会出现了，它们代表的副作用就不会被执行，进而我们的 begin 就没用了。
当然你会说单个符号没有副作用。然而谁会闲的没事把它们放进 begin 去呢？保证 begin 中没有无用的东西不是转换器的责任，而是程序员的义务。
下一步，支持内建函数。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
| #lang racket
(define (atom? x) (not (pair? x)))
(define intrinsics (hash '+ #t '- #t '* #t '/ #t 'cons #t 'car #t 'cdr #t)) ; 内建函数列表，可以自行添加
(define (is-intrinsic? op) (hash-has-key? intrinsics op))
(define (wrap k exp)
(if (eq? k 'identity)
exp
(list k exp)))
(define keywords '(lambda define begin))
(define (is-app-exp? exp)
(not (or (atom? exp) (member (car exp) keywords))))
(define (cps1 exp k arg-acc)
(match exp
[`(define ,id ,exp)
`(begin (define ,id ,(cps1 exp 'identity '())) (,k #f))]
[`(lambda ,bind . ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda ,(append bind (list c)) ,(cps1 (cons 'begin body) c '())))])
(wrap k res))]
[`(begin ,exp)
(cps1 exp k '())]
[`(begin ,exp . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(cps1 exp `(lambda (,c1) ,(cps1 (cons 'begin rest) k '())) '()))]
[`(,intrin . ,rest) #:when (is-intrinsic? intrin)
(wrap k (cons intrin (map (lambda (x) (cps1 x 'identity '())) rest)))]
[`(,exp)
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp)
(cps1 exp `(lambda (,c1) ,(reverse (cons k (cons c1 arg-acc)))) '())
(reverse (cons k (cons (cps1 exp 'identity '()) arg-acc)))))]
[`(,exp1 . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp1)
(cps1 exp1 `(lambda (,c1) ,(cps1 rest k (cons c1 arg-acc))) '())
(cps1 rest k (cons (cps1 exp1 'identity '()) arg-acc))))]
[x #:when (atom? x) (wrap k x)]))
(define (cps exp) (cps1 exp 'ctx0 '()))
|
加入 if 和 quote。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
| #lang racket
(define (atom? x) (not (pair? x)))
(define intrinsics (hash '+ #t '- #t '* #t '/ #t 'cons #t 'car #t 'cdr #t 'null? #t '= #t '< #t '> #t '<= #t '>= #t))
(define (is-intrinsic? op) (hash-has-key? intrinsics op))
(define (wrap k exp)
(if (eq? k 'identity)
exp
(list k exp)))
(define keywords '(lambda define begin quote))
(define (is-app-exp? exp)
(not (or (atom? exp) (member (car exp) keywords) (is-intrinsic? (car exp)))))
(define (cps1 exp k arg-acc #:intr? [flag-intr #f])
(match exp
[`(define ,id ,exp)
`(begin (define ,id ,(cps1 exp 'identity '())) (,k #f))]
[`(lambda ,bind . ,body)
(let ([res (let ([c (gensym 'k)])
`(lambda ,(append bind (list c)) ,(cps1 (cons 'begin body) c '())))])
(wrap k res))]
[`(begin ,exp)
(cps1 exp k '())]
[`(begin ,exp . ,rest) #:when (not (null? rest))
(let ([c1 (gensym 'v)])
(cps1 exp `(lambda (,c1) ,(cps1 (cons 'begin rest) k '())) '()))]
[`(if ,condition ,then-c ,else-c)
(let ([c (gensym 'v)])
(if (is-app-exp? condition)
(cps1 condition `(lambda (,c) (if ,c ,(cps1 then-c k '()) ,(cps1 else-c k '()))) '())
`(if ,(cps1 condition 'identity '()) ,(cps1 then-c k '()) ,(cps1 else-c k '()))))]
[`(,intrin . ,rest) #:when (is-intrinsic? intrin)
(cps1 rest k '() #:intr? intrin)]
[`(,exp) #:when flag-intr
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp)
(cps1 exp `(lambda (,c1) ,(wrap k (cons flag-intr (reverse (cons c1 arg-acc))))) '())
(wrap k (cons flag-intr (reverse (cons (cps1 exp 'identity '()) arg-acc))))))]
[`(,exp1 . ,rest) #:when (and flag-intr (not (null? rest)))
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp1)
(cps1 exp1 `(lambda (,c1) ,(cps1 rest k (cons c1 arg-acc) #:intr? flag-intr)) '())
(cps1 rest k (cons (cps1 exp1 'identity '()) arg-acc) #:intr? flag-intr)))]
[`(,exp) #:when (is-app-exp? (list exp))
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp)
(cps1 exp `(lambda (,c1) ,(reverse (cons k (cons c1 arg-acc)))) '())
(reverse (cons k (cons (cps1 exp 'identity '()) arg-acc)))))]
[`(,exp1 . ,rest) #:when (and (is-app-exp? exp) (not (null? rest)))
(let ([c1 (gensym 'v)])
(if (is-app-exp? exp1)
(cps1 exp1 `(lambda (,c1) ,(cps1 rest k (cons c1 arg-acc))) '())
(cps1 rest k (cons (cps1 exp1 'identity '()) arg-acc))))]
[x #:when (or (atom? x) (eq? (car x) 'quote)) (wrap k x)]))
(define (cps exp) (cps1 exp 'ctx0 '()))
|
这样我们的变换器终于可以对开头的那个例子工作了。
1
2
3
4
5
6
7
8
| > (displayln (cps
'(define fact
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1))))))))
(begin (define fact (lambda (n k1211) (if (= n 0) (k1211 1) (fact (- n 1) (lambda (v1216) (k1211 (* n v1216))))))) (ctx0 #f))
|
（生成的代码基本上已经是人类可读的了。和开头给出的手工代码几乎一样）
如果你对 (define (fact n) ...) 变换，变换器会出错。因为我们没有让它支持函数定义的这个语法糖。但是将 lambda 绑定到变量也是等价的。
你也许注意到了，这版代码里面多出了许多奇怪的东西。其实这些东西不属于这版代码，它们是在修上版代码留下的 BUG：上一版代码引入 intrinsics 时，对它们与普通函数调用的适配做的有问题，变换出来的代码不是 CPS 形式。看上去像这样：
1
2
3
4
5
6
7
8
9
10
11
| (begin
(define fact
(lambda (n k1207)
((lambda (v1208)
(if v1208
(k1207 1)
(k1207
(* n
((lambda (v1210) (fact v1210 identity))
(- n 1))))))
(= n 0)))) (ctx0 #f))
|
有问题的地方在 (k1207 (* n ((lambda (v1210) (fact v1210 identity))，也就是原始代码的 (* (fact (- n 1))) 这一行。出的问题和我们最早处理普通函数应用时遇到的如出一辙。解决方案也一模一样，几乎就是复制了普通函数应用的代码。
从这些经历我们发现，似乎只要一试图用 identity 捕获一个表达式的“原始值”，变换器就会出锅（产生非 CPS 形式的代码）。真是个深刻的教训。
我们的旅程就到这里结束了。最后的彩蛋是 call/cc：
1
| [`(call/cc ,exp) (list exp k)]
|
在模式匹配中加入这个分支即可。原理自行思考。
（BTW，我的 racket 代码用洛谷的 cpp 的高亮都比用 racket 高亮好看。洛谷根本没有（不支持）racket 高亮。）