CPS，控制上下文与四十行代码的传说

· · 科技·工程

光剑系列的第七作！

前六作：

朱约（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 变换

一个例子

先看下面这段代码：

(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) 的变换结果。

怎么办？我们似乎陷入了死胡同。

为了解决这个问题，我们首先需要知道正确的变换是什么。

((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 能看得更清楚：

(f g (lambda (v0) (r h (lambda (v1) (v0 v1 k)))))

知道了正确的变换形式，那么如何修正程序的错误呢？

其实错误的本质很简单：就是 identity 占位符的问题。我们企图用它“原封不动地返回一个表达式变换后的形式”，然后构建新代码，但这一步里其实已经用到了“返回”这个隐式控制流。

但是表达式变换后的值不捕获是不行的。如何捕获？

很简单，利用续延。就像 call/cc 的形式是“包裹一个表达式，将捕获的续延作为参数传递进去”一样，我们也在续延中构建一个 lambda，将表达式作为它的参数捕获，之后再搞事情。

那么正确的代码就很简单了：

#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 份极其类似的代码（终于理解于梓文说的“接下来会有很多重复的代码”是什么意思了，果然实践出真知）

并且由于代码太过冗长，我们构造了一些过程抽象。

#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 入手。这是一个具有挑战的特性：我们之前的函数调用相当于人肉特判了控制流，现在我们要找到通解。

一开始就去掉冗余有点困难，所以我们先从最原始的，有冗余的版本入手。

多参函数应用怎么做呢？

(cps `(,r0 ,r1 ,r2 ...) k) = 
(cps r0 `(lambda (,v0) ,(cps r1 `(lambda (,v1) ...))))

简单来说，“从左到右，对操作符和各操作数依次求值，最后应用”。不过现在是用续延实现。

看上去不是很好实现。人肉做不太现实，考虑递归。 边界：一个操作数。我们维护一个环境，代表之前遇到的一切参数名。

这时把所有参数名依次放进列表里，再加上续延 k 就行了。

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

伪代码大概就是上面那样。

#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 类即可：当前处理的参数是否是一个函数应用。如果不是，就内联进去而不使用续延绑定。

#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）即可。

也就是在模式匹配中加入这个分支：

[`(define ,id ,exp)
  `(define ,id ,(cps1 exp 'identity '()))]

但是你发现了吗？控制流在这里又断掉了。define 很特殊，它不返回任何值，也不是一个有函数调用的动作。它只不过是创建一个绑定，实在不应该出现在控制流里。

我没有什么好办法来修复它。不过用一个 begin 把 define 和续延调用包起来有用。

[`(define ,id ,exp)
  `(begin (define ,id ,(cps1 exp 'identity '())) (,k #f))]

为了统一 define 和其他表达式的处理，我们给续延传递了一个没有任何意义的值充当占位符。

完整代码：

#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 特殊形式和普通的函数调用几乎一模一样。不过，它不会将操作符求值之后应用于操作数，而是保留最后一个表达式的值，将前面其他表达式的返回值都丢弃。

这样就可以处理有多个表达式的函数体。

#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 中没有无用的东西不是转换器的责任，而是程序员的义务。

下一步，支持内建函数。

#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。

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

这样我们的变换器终于可以对开头的那个例子工作了。

> (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 形式。看上去像这样：

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

[`(call/cc ,exp) (list exp k)]

在模式匹配中加入这个分支即可。原理自行思考。

（BTW，我的 racket 代码用洛谷的 cpp 的高亮都比用 racket 高亮好看。洛谷根本没有（不支持） racket 高亮。）