玩弄Lisp系列第一弹:从王垠的40行CPS变换说起
为什么要写这个?
Continuation对于每一个lisper来说都不陌生,CPS相对麻烦一点,而CPS变换可能就相当麻烦了.
我 第一次接触Continuation是在Paul Graham的On Lisp一书中,当时看到那种神奇的能力真的是不明觉厉,后来我开始学习Scheme,我发现Scheme真的是一个比Common Lisp更值得学习的语言,我发现我在学习Scheme过程中取得的进步是学习Common Lisp时所不能比的,尤其是在学习EOPL一书过程中,我用多种方式实现了Continuation,对其有了近乎本质性的理解.所以现在回过头来看看 On Lisp中那坑爹的"Continuation",我只能觉得幼稚,看着那坑爹的"bind=",我只能说"这也算Continuation?"
第一次看到王垠的CPS变换时,我还不怎么了解Continuation,所以那代码对我来说就是天书.但现在情况已经不同了,再次看到这代码时,我能清楚地感觉到自己的进步,因此写一下这个作为我学习Lisp一年三个月的总决.
正文
这里我假设读者已经知道Continuation和CPS是怎么回事,不明白的可以先去看EOPL(Essentials of Programming Languages).
这里我将使用Racket实现CPS变换,因此很多细节都会和王垠的代码不同,但基本思想是一样的.
首先来看看这个cps函数
(define cps
(lambda (sexp ctx)
...))
这里的sexp就是要处理的输入,我们先严格地定义一下
sexp ::= self-evaluate ;例如数字,布尔值
| symbol(不能是k) ;符号,也可以叫变量名
| (quote anything) ;引用形式,大家因该很熟悉
| (if sexp sexp sexp) ;if语句
| (lambda (arg) sexp) ;lambda表达式
| (sexp sexp) ;过程的调用
self-evaluate ::= number | boolean
我们把cps函数的输出叫做cps-exp,对CPS有了解的话我们不难发现对应sexp的cps-exp应该是长这个样子的
cps-exp ::= simple-exp
| (k simple-exp)
| (simple-exp simple-exp k-exp)
| (if simple-exp cps-exp cps-exp)
k-exp ::= (lambda (var) cps-exp)
simple-exp ::= self-evaluate | symbol | (quote anything)
| (lambda (arg k) cps-exp)
这样一来cps函数就是要实现(sexp -> cps-exp)这样的变换,
而那个ctx参数的类型则是(simple-exp -> cps-exp).
ctx 代表了evaluation context,例如在(list (a b) 1)中, (a b)的evalution context就是(list [] 1), []在这里就表示(a b)的结果要填入的洞,写成cps就是(a b (lambda (v) (list v 1))).
所以continuation是evaluation context的一种表示方式.不过在这里ctx不能当作continuation(所以也不叫作k),因为它并不总是处于尾调用的位置.
弄 清楚这个ctx是做什么的,想出要用到这个ctx就是算法中在最难的一步(尽管不用也可以,就像cl-cont那样,但是想要生成最简的结果就比较麻烦 了,cl-cont生成的代码冗余度非常大,不过在现代Common Lisp编译器的优化能力下似乎没有什么影响),但既然我们现在已经弄清楚这些东西的类型,那么要实现这个变换已经是手到擒来的了.
首先考虑前面三种情况
sexp ::= self-evaluate ;例如数字,布尔值
| symbol ;符号,也可以叫变量名
| (quote anything) ;引用形式,大家因该很熟悉
注意到
cps-exp ::= simple-exp
simple-exp ::= self-evaluate | symbol | (quote anything)
这个sexp直接对应simple-exp,
实际上我们不用做任何事,但是要记清楚simple-exp不能直接返回,因为(simple-exp -> cps-exp)由ctx完成,所以我们把sexp传递给ctx.
(define cps
(lambda (sexp ctx)
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,thing) (ctx sexp)])))
大家应该看出来了如果我们要(cps 1 _) => 1,那我们要在 _ 填入的就是identity函数,即
(define id (lambda (v) v))
下面开始考虑过程的调用
sexp ::= (sexp sexp)
对应的cps-exp是
cps-exp ::= (simple-exp simple-exp k-exp)
k-exp ::= (lambda (var) cps-exp)
simple-exp ::= self-evaluate | symbol | (quote anything)
那么对应的代码应该是长这样子的:
[`(,rator ,rand) ...]
因为rator和rand都是sexp,因此都必须递归调用cps函数对他们进行处理,而ctx参数就对应简化后的simple-exp
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
...))))]
由于
cps-exp ::= (simple-exp simple-exp k-exp)
结果很自然就是
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
`(,simple-rator ,simple-rand ...)))))]
我们再来看看这个...中的k-exp是什么东西,由于
k-exp ::= (lambda (var) cps-exp)
所以
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
`(,simple-rator ,simple-rand
(lambda (var) ...))))))]
我们来看一下, ...中应该填入一个cps-exp,而rator,rand已经进行过变换了,没有需要做cps变换的部分的,不能用cps函数得到cps-exp了,剩下的能产生cps-exp的就只有ctx了,那ctx的参数又是什么呢
看看这个例子,
(a (b c)) -> (b c (lambda (var) (a var (lambda (var) var))))
很明显我们不应该再做多余的事,ctx的参数就是'var,多余的事就交给ctx来完成.
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
`(,simple-rator ,simple-rand
(lambda (var) ,(ctx 'var)))))))]
但是注意!如果就这样结束,我们在处理((a b) (c d))这样的式子时,将会出现(a b (lambda (var) (c d (lambda (var) (var var)))))这样的结果,这肯定是有问题的.
我们可以利用gensym来生成不同的名字.
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))))))]
下面加入lambda表达式
sexp ::= (lambda (arg) sexp)
对应的cps-exp是
cps-exp ::= simple-exp
| (k simple-exp)
| (simple-exp simple-exp k-exp)
simple-exp ::= (lambda (arg k) cps-exp)
所以
[`(lambda (,arg) ,sexp) ...]
外面这层(lambda (arg k) ...)是一个simple-exp,所以把它交给ctx
[`(lambda (,arg) ,sexpe)
(ctx `(lambda (,arg k) ...))]
而(lambda (arg) sexp)中的sexp必须用cps函数递归地变换
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp ...)))]
我们再来看几个例子
((lambda (a) a) 1) => ((lambda (a k) (k a)) 1)
(lambda (a) (f (g a))) => (lambda (a k) (g a (lambda (v) (f v (lambda (v) (k v))))))
lambda表达式里面的过程不管多么复杂,最后的结果都要用k来返回,所以
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp (lambda (v) `(k ,v)))))]
而(k simple-exp)也正是CPS程序中经常看到的语句
我们可以把这个ctx记下来,叫做ctx0
(define ctx0
(lambda (v)
`(k ,v)))
最后
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp ctx0)))]
下面我们再加入if表达式
[`(if ,test ,then ,else) ...]
注意到
sexp ::= (if sexp sexp sexp)
cps-exp ::= (if simple-exp cps-exp cps-exp)
经过前面的尝试,现在这个变换关系已经很明显了
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))))]
至此,这个程序的骨架已经完成,我们把他们组装起来.
#lang racket
(define self-evaluate?
(lambda (thing)
(or (number? thing) (boolean? thing))))
(define id
(lambda (v) v))
(define ctx0
(lambda (v)
`(k ,v)))
(define cps
(lambda (sexp ctx)
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,anything) (ctx sexp)]
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))))]
[`(lambda (,arg) ,sexp) (ctx `(lambda (,arg k) ,(cps sexp ctx0)))]
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))))))])))
下面我们可以对其进行改进,以便于生成更简洁易读的结果
首先我们看
> (cps '(lambda (v) (f a)) id)
'(lambda (v k) (f a (lambda (var) (k var))))
很明显,这个(lambda (var) (k var))可以做一个beta-归约变成k,此时ctx是ctx0,
所以
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(if (eq? ctx ctx0)
`(,simple-rator ,simple-rand k)
(let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var)))))))))]
下面开始加入一些原语,也就是接受单一参数,不接受k参数的过程,像zero?这样
增加定义
simple-exp |= (primitive-rator simple-exp)
先定义一些这样的过程
(define primitive-rator?
(lambda (x)
(memq x '(add1 sub1 zero? car cdr))))
这样(car v) => (car v), (f (car x)) => (f (car x) (lambda (var) var)),不需要k,
我们要在[`(,rator ,rand) ...]里处理这种情况
显然最终结果`(,simple-rator ,simple-rand)是一个simple-exp,对于一个simple-exp我们只需直接交给ctx
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(cond [(primitive-rator? simple-rator)
(ctx `(,simple-rator ,simple-rand))] ;就是这样
[(eq? ctx ctx0)
`(,simple-rator ,simple-rand k)]
[else (let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))])))))]
同理,如果要再加入一些二元操作符作为原语
[`(,op ,a ,b) (cps a
(lambda (a)
(cps b
(lambda (b)
(ctx `(,op ,a ,b))))))]
还有一个情况就是
> (cps '(f (if a b c)) id)
'(if a (f b (lambda (v61460) (v61460)) (f c (lambda (v61461) v61461))))
注意到这里的(f _ (lambda (var) var))出现了两次,为了减少重复,我们可以把它变成
(let ([k (lambda (v) (f v (lambda (v) v)))])
(if a (k b) (k c)))
追加定义
cps-exp |= (let ([k k-exp])
cps-exp)
不过当ctx是ctx0时,结果会
(let ((k (lambda (v) (k v))))
(if a (k b) (k c)))
没有必要
当ctx是id时
(let ((k (lambda (v) v))) (if a (k b) (k c)))
也没有必要
所以最终结果就是
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
(if (memq ctx `(,ctx0 ,id))
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))
`(let ([k (lambda (v) ,(ctx 'v))])
(if ,simple-test
,(cps then ctx0)
,(cps else ctx0))))))]
这样基本上就等同于王垠的算法了.如果再弄个大过程包装起来,就一样了.
最终得到的代码就是
#lang racket
(define self-evaluate?
(lambda (thing)
(or (number? thing) (boolean? thing))))
(define id
(lambda (v) v))
(define ctx0
(lambda (v)
`(k ,v)))
(define primitive-rator?
(lambda (x)
(memq x '(add1 sub1 zero? car cdr))))
(define cps
(lambda (sexp ctx)
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,thing) (ctx sexp)]
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
(if (memq ctx `(,ctx0 ,id))
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))
`(let ([k (lambda (v) ,(ctx 'v))])
(if ,simple-test
,(cps then ctx0)
,(cps else ctx0))))))]
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp ctx0)))]
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(cond [(primitive-rator? simple-rator)
(ctx `(,simple-rator ,simple-rand))]
[(eq? ctx ctx0)
`(,simple-rator ,simple-rand k)]
[else (let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))])))))]
[`(,op ,a ,b) (cps a
(lambda (a)
(cps b
(lambda (b)
(ctx `(,op ,a ,b))))))])))
我们掌握了这个ctx的用法之后,可以把它应用到许多的场合,例如对lambda演算的ANF变换
(define anf
(lambda (lc-exp)
(define var? symbol?)
(define val?
(lambda (v)
(match v
[(? var?) #t]
[`(lambda (,x) ,bd) #t]
[_ #f])))
(define id (lambda (x) x))
(define anf1
(lambda (lc-exp ctx)
(match lc-exp
[(? var?) (ctx lc-exp)]
[`(lambda (,arg) ,lc-exp) (ctx `(lambda (,arg) ,(anf1 lc-exp id)))]
[`(,rator ,rand)
(anf1 rator
(lambda (simple-rator)
(anf1 rand
(lambda (simple-rand)
(if (val? simple-rator)
(if (val? simple-rand)
(ctx `(,simple-rator ,simple-rand))
(let ([rand-var (gensym "rand")])
`(let ([,rand-var ,simple-rand])
,(ctx `(,simple-rator ,rand-var)))))
(let ([rator-var (gensym "rator")])
`(let ([,rator-var ,simple-rator])
,(anf1 `(,rator-var ,simple-rand) ctx))))))))])))
(anf1 lc-exp id)))
示例:
> (anf '(f (lambda (a) (f (b a)))))
'(f (lambda (a) (let ((rand526 (b a))) (f rand526))))
相信大家已经能很容易看懂了
Continuation对于每一个lisper来说都不陌生,CPS相对麻烦一点,而CPS变换可能就相当麻烦了.
我 第一次接触Continuation是在Paul Graham的On Lisp一书中,当时看到那种神奇的能力真的是不明觉厉,后来我开始学习Scheme,我发现Scheme真的是一个比Common Lisp更值得学习的语言,我发现我在学习Scheme过程中取得的进步是学习Common Lisp时所不能比的,尤其是在学习EOPL一书过程中,我用多种方式实现了Continuation,对其有了近乎本质性的理解.所以现在回过头来看看 On Lisp中那坑爹的"Continuation",我只能觉得幼稚,看着那坑爹的"bind=",我只能说"这也算Continuation?"
第一次看到王垠的CPS变换时,我还不怎么了解Continuation,所以那代码对我来说就是天书.但现在情况已经不同了,再次看到这代码时,我能清楚地感觉到自己的进步,因此写一下这个作为我学习Lisp一年三个月的总决.
正文
这里我假设读者已经知道Continuation和CPS是怎么回事,不明白的可以先去看EOPL(Essentials of Programming Languages).
这里我将使用Racket实现CPS变换,因此很多细节都会和王垠的代码不同,但基本思想是一样的.
首先来看看这个cps函数
(define cps
(lambda (sexp ctx)
...))
这里的sexp就是要处理的输入,我们先严格地定义一下
sexp ::= self-evaluate ;例如数字,布尔值
| symbol(不能是k) ;符号,也可以叫变量名
| (quote anything) ;引用形式,大家因该很熟悉
| (if sexp sexp sexp) ;if语句
| (lambda (arg) sexp) ;lambda表达式
| (sexp sexp) ;过程的调用
self-evaluate ::= number | boolean
我们把cps函数的输出叫做cps-exp,对CPS有了解的话我们不难发现对应sexp的cps-exp应该是长这个样子的
cps-exp ::= simple-exp
| (k simple-exp)
| (simple-exp simple-exp k-exp)
| (if simple-exp cps-exp cps-exp)
k-exp ::= (lambda (var) cps-exp)
simple-exp ::= self-evaluate | symbol | (quote anything)
| (lambda (arg k) cps-exp)
这样一来cps函数就是要实现(sexp -> cps-exp)这样的变换,
而那个ctx参数的类型则是(simple-exp -> cps-exp).
ctx 代表了evaluation context,例如在(list (a b) 1)中, (a b)的evalution context就是(list [] 1), []在这里就表示(a b)的结果要填入的洞,写成cps就是(a b (lambda (v) (list v 1))).
所以continuation是evaluation context的一种表示方式.不过在这里ctx不能当作continuation(所以也不叫作k),因为它并不总是处于尾调用的位置.
弄 清楚这个ctx是做什么的,想出要用到这个ctx就是算法中在最难的一步(尽管不用也可以,就像cl-cont那样,但是想要生成最简的结果就比较麻烦 了,cl-cont生成的代码冗余度非常大,不过在现代Common Lisp编译器的优化能力下似乎没有什么影响),但既然我们现在已经弄清楚这些东西的类型,那么要实现这个变换已经是手到擒来的了.
首先考虑前面三种情况
sexp ::= self-evaluate ;例如数字,布尔值
| symbol ;符号,也可以叫变量名
| (quote anything) ;引用形式,大家因该很熟悉
注意到
cps-exp ::= simple-exp
simple-exp ::= self-evaluate | symbol | (quote anything)
这个sexp直接对应simple-exp,
实际上我们不用做任何事,但是要记清楚simple-exp不能直接返回,因为(simple-exp -> cps-exp)由ctx完成,所以我们把sexp传递给ctx.
(define cps
(lambda (sexp ctx)
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,thing) (ctx sexp)])))
大家应该看出来了如果我们要(cps 1 _) => 1,那我们要在 _ 填入的就是identity函数,即
(define id (lambda (v) v))
下面开始考虑过程的调用
sexp ::= (sexp sexp)
对应的cps-exp是
cps-exp ::= (simple-exp simple-exp k-exp)
k-exp ::= (lambda (var) cps-exp)
simple-exp ::= self-evaluate | symbol | (quote anything)
那么对应的代码应该是长这样子的:
[`(,rator ,rand) ...]
因为rator和rand都是sexp,因此都必须递归调用cps函数对他们进行处理,而ctx参数就对应简化后的simple-exp
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
...))))]
由于
cps-exp ::= (simple-exp simple-exp k-exp)
结果很自然就是
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
`(,simple-rator ,simple-rand ...)))))]
我们再来看看这个...中的k-exp是什么东西,由于
k-exp ::= (lambda (var) cps-exp)
所以
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
`(,simple-rator ,simple-rand
(lambda (var) ...))))))]
我们来看一下, ...中应该填入一个cps-exp,而rator,rand已经进行过变换了,没有需要做cps变换的部分的,不能用cps函数得到cps-exp了,剩下的能产生cps-exp的就只有ctx了,那ctx的参数又是什么呢
看看这个例子,
(a (b c)) -> (b c (lambda (var) (a var (lambda (var) var))))
很明显我们不应该再做多余的事,ctx的参数就是'var,多余的事就交给ctx来完成.
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
`(,simple-rator ,simple-rand
(lambda (var) ,(ctx 'var)))))))]
但是注意!如果就这样结束,我们在处理((a b) (c d))这样的式子时,将会出现(a b (lambda (var) (c d (lambda (var) (var var)))))这样的结果,这肯定是有问题的.
我们可以利用gensym来生成不同的名字.
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))))))]
下面加入lambda表达式
sexp ::= (lambda (arg) sexp)
对应的cps-exp是
cps-exp ::= simple-exp
| (k simple-exp)
| (simple-exp simple-exp k-exp)
simple-exp ::= (lambda (arg k) cps-exp)
所以
[`(lambda (,arg) ,sexp) ...]
外面这层(lambda (arg k) ...)是一个simple-exp,所以把它交给ctx
[`(lambda (,arg) ,sexpe)
(ctx `(lambda (,arg k) ...))]
而(lambda (arg) sexp)中的sexp必须用cps函数递归地变换
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp ...)))]
我们再来看几个例子
((lambda (a) a) 1) => ((lambda (a k) (k a)) 1)
(lambda (a) (f (g a))) => (lambda (a k) (g a (lambda (v) (f v (lambda (v) (k v))))))
lambda表达式里面的过程不管多么复杂,最后的结果都要用k来返回,所以
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp (lambda (v) `(k ,v)))))]
而(k simple-exp)也正是CPS程序中经常看到的语句
我们可以把这个ctx记下来,叫做ctx0
(define ctx0
(lambda (v)
`(k ,v)))
最后
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp ctx0)))]
下面我们再加入if表达式
[`(if ,test ,then ,else) ...]
注意到
sexp ::= (if sexp sexp sexp)
cps-exp ::= (if simple-exp cps-exp cps-exp)
经过前面的尝试,现在这个变换关系已经很明显了
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))))]
至此,这个程序的骨架已经完成,我们把他们组装起来.
#lang racket
(define self-evaluate?
(lambda (thing)
(or (number? thing) (boolean? thing))))
(define id
(lambda (v) v))
(define ctx0
(lambda (v)
`(k ,v)))
(define cps
(lambda (sexp ctx)
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,anything) (ctx sexp)]
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))))]
[`(lambda (,arg) ,sexp) (ctx `(lambda (,arg k) ,(cps sexp ctx0)))]
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))))))])))
下面我们可以对其进行改进,以便于生成更简洁易读的结果
首先我们看
> (cps '(lambda (v) (f a)) id)
'(lambda (v k) (f a (lambda (var) (k var))))
很明显,这个(lambda (var) (k var))可以做一个beta-归约变成k,此时ctx是ctx0,
所以
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(if (eq? ctx ctx0)
`(,simple-rator ,simple-rand k)
(let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var)))))))))]
下面开始加入一些原语,也就是接受单一参数,不接受k参数的过程,像zero?这样
增加定义
simple-exp |= (primitive-rator simple-exp)
先定义一些这样的过程
(define primitive-rator?
(lambda (x)
(memq x '(add1 sub1 zero? car cdr))))
这样(car v) => (car v), (f (car x)) => (f (car x) (lambda (var) var)),不需要k,
我们要在[`(,rator ,rand) ...]里处理这种情况
显然最终结果`(,simple-rator ,simple-rand)是一个simple-exp,对于一个simple-exp我们只需直接交给ctx
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(cond [(primitive-rator? simple-rator)
(ctx `(,simple-rator ,simple-rand))] ;就是这样
[(eq? ctx ctx0)
`(,simple-rator ,simple-rand k)]
[else (let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))])))))]
同理,如果要再加入一些二元操作符作为原语
[`(,op ,a ,b) (cps a
(lambda (a)
(cps b
(lambda (b)
(ctx `(,op ,a ,b))))))]
还有一个情况就是
> (cps '(f (if a b c)) id)
'(if a (f b (lambda (v61460) (v61460)) (f c (lambda (v61461) v61461))))
注意到这里的(f _ (lambda (var) var))出现了两次,为了减少重复,我们可以把它变成
(let ([k (lambda (v) (f v (lambda (v) v)))])
(if a (k b) (k c)))
追加定义
cps-exp |= (let ([k k-exp])
cps-exp)
不过当ctx是ctx0时,结果会
(let ((k (lambda (v) (k v))))
(if a (k b) (k c)))
没有必要
当ctx是id时
(let ((k (lambda (v) v))) (if a (k b) (k c)))
也没有必要
所以最终结果就是
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
(if (memq ctx `(,ctx0 ,id))
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))
`(let ([k (lambda (v) ,(ctx 'v))])
(if ,simple-test
,(cps then ctx0)
,(cps else ctx0))))))]
这样基本上就等同于王垠的算法了.如果再弄个大过程包装起来,就一样了.
最终得到的代码就是
#lang racket
(define self-evaluate?
(lambda (thing)
(or (number? thing) (boolean? thing))))
(define id
(lambda (v) v))
(define ctx0
(lambda (v)
`(k ,v)))
(define primitive-rator?
(lambda (x)
(memq x '(add1 sub1 zero? car cdr))))
(define cps
(lambda (sexp ctx)
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,thing) (ctx sexp)]
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
(if (memq ctx `(,ctx0 ,id))
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))
`(let ([k (lambda (v) ,(ctx 'v))])
(if ,simple-test
,(cps then ctx0)
,(cps else ctx0))))))]
[`(lambda (,arg) ,sexp)
(ctx `(lambda (,arg k) ,(cps sexp ctx0)))]
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(cond [(primitive-rator? simple-rator)
(ctx `(,simple-rator ,simple-rand))]
[(eq? ctx ctx0)
`(,simple-rator ,simple-rand k)]
[else (let ([var (gensym)])
`(,simple-rator ,simple-rand
(lambda (,var) ,(ctx var))))])))))]
[`(,op ,a ,b) (cps a
(lambda (a)
(cps b
(lambda (b)
(ctx `(,op ,a ,b))))))])))
我们掌握了这个ctx的用法之后,可以把它应用到许多的场合,例如对lambda演算的ANF变换
(define anf
(lambda (lc-exp)
(define var? symbol?)
(define val?
(lambda (v)
(match v
[(? var?) #t]
[`(lambda (,x) ,bd) #t]
[_ #f])))
(define id (lambda (x) x))
(define anf1
(lambda (lc-exp ctx)
(match lc-exp
[(? var?) (ctx lc-exp)]
[`(lambda (,arg) ,lc-exp) (ctx `(lambda (,arg) ,(anf1 lc-exp id)))]
[`(,rator ,rand)
(anf1 rator
(lambda (simple-rator)
(anf1 rand
(lambda (simple-rand)
(if (val? simple-rator)
(if (val? simple-rand)
(ctx `(,simple-rator ,simple-rand))
(let ([rand-var (gensym "rand")])
`(let ([,rand-var ,simple-rand])
,(ctx `(,simple-rator ,rand-var)))))
(let ([rator-var (gensym "rator")])
`(let ([,rator-var ,simple-rator])
,(anf1 `(,rator-var ,simple-rand) ctx))))))))])))
(anf1 lc-exp id)))
示例:
> (anf '(f (lambda (a) (f (b a)))))
'(f (lambda (a) (let ((rand526 (b a))) (f rand526))))
相信大家已经能很容易看懂了
闲得无聊弄了这么个玩意，原理和前面的CPS变换一模一样，不重复说明了。
#lang racket
(require "cps.rkt")
(define lookup
(lambda (s env)
(cond [(assq s env) => cdr]
[else s])))
(define ext
(lambda (k v env)
(cons (cons k v) env)))
(define env0 '())
(define expand-k
(lambda (sexp k-exp env ctx)
(match k-exp
['k (ctx sexp)]
[`(lambda (,v) ,cps-exp)
(uncps cps-exp (ext v sexp env) ctx)])))
(define uncps
(lambda (cps-exp [env env0] [ctx id])
(match cps-exp
;;simple-exp
[(? self-evaluate? self) (ctx self)]
[(? symbol? sym) (ctx (lookup sym env))]
[`(quote ,x) (ctx cps-exp)]
[`(lambda (,a k) ,cps-exp) (ctx `(lambda (,a) ,(uncps cps-exp env id)))]
[`(,(? unary-op? rator) ,simp-rand)
(uncps simp-rand env
(lambda (rand)
(ctx `(,rator ,rand))))]
[`(,(? bin-op? rator) ,simp-v1 ,simp-v2)
(uncps simp-v1 env
(lambda (v1)
(uncps simp-v2 env
(lambda (v2)
(ctx `(,rator ,v1 ,v2))))))]
;;cps-exp
[`(if ,simp-test ,cps-then ,cps-else)
(uncps simp-test env
(lambda (test)
`(if ,test
,(uncps cps-then env ctx)
,(uncps cps-else env ctx))))]
[`(let ([k ,k-exp]) ,e)
(expand-k (uncps e env id) k-exp env ctx)]
[`(k ,simp) (uncps simp env ctx)]
[`(,simp-rator ,simp-rand ,k-exp)
(uncps simp-rator env
(lambda (rator)
(uncps simp-rand env
(lambda (rand)
(expand-k `(,rator ,rand) k-exp env ctx)))))])))
修改了一点的CPS变换代码：
#lang racket
(provide cps self-evaluate? id bin-op? unary-op?)
(define self-evaluate?
(lambda (thing)
(or (number? thing) (boolean? thing))))
(define id
(lambda (v) v))
(define ctx0
(lambda (v)
`(k ,v)))
(define unary-op?
(lambda (x)
(memq x '(add1 sub1 zero? car cdr))))
(define bin-op?
(lambda (x)
(memq x '(cons + - * / < > = <= >=))))
(define cps
(lambda (sexp [ctx id])
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,thing) (ctx sexp)]
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
(if (memq ctx `(,ctx0 ,id))
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))
`(let ([k (lambda (v) ,(ctx 'v))])
(if ,simple-test
,(cps then ctx0)
,(cps else ctx0))))))]
[`(lambda (,a) ,e)
(ctx `(lambda (,a k) ,(cps e ctx0)))]
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(cond [(unary-op? simple-rator)
(ctx `(,simple-rator ,simple-rand))]
[(eq? ctx ctx0)
(list simple-rator simple-rand 'k)]
[else
(let ([v (gensym "v")])
(list simple-rator simple-rand
`(lambda (,v)
,(ctx v))))])))))]
[`(,(? bin-op? op) ,a ,b) (cps a
(lambda (a)
(cps b
(lambda (b)
(ctx `(,op ,a ,b))))))])))
然后是抄来的测试案例：
(define test
(lambda (sexp)
(equal? (uncps (cps sexp)) sexp)))
(define test-all
(lambda ()
(andmap test
'(
x
(lambda (x) x)
(lambda (x) (x 1))
(if (f x) a b)
(if x (f a) b)
(lambda (x) (if (f x) a b))
(lambda (x) (if (if x (f a) b) c d))
(lambda (x) (if (if x (zero? a) b) c d))
(lambda (x) (if t (if x (f a) b) c))
(lambda (x) (if (if t (if x (f a) b) c) e w))
(lambda (x) (h (if x (f a) b)))
(lambda (x) ((if x (f g) h) c))
(((f a) (g b)) ((f c) (g d)))
(lambda (n)
((lambda (fact)
((fact fact) n))
(lambda (fact)
(lambda (n)
(if (zero? n)
1
(* n ((fact fact) (sub1 n))))))))))))
测试通过：
> (test-all)
#t
#lang racket
(require "cps.rkt")
(define lookup
(lambda (s env)
(cond [(assq s env) => cdr]
[else s])))
(define ext
(lambda (k v env)
(cons (cons k v) env)))
(define env0 '())
(define expand-k
(lambda (sexp k-exp env ctx)
(match k-exp
['k (ctx sexp)]
[`(lambda (,v) ,cps-exp)
(uncps cps-exp (ext v sexp env) ctx)])))
(define uncps
(lambda (cps-exp [env env0] [ctx id])
(match cps-exp
;;simple-exp
[(? self-evaluate? self) (ctx self)]
[(? symbol? sym) (ctx (lookup sym env))]
[`(quote ,x) (ctx cps-exp)]
[`(lambda (,a k) ,cps-exp) (ctx `(lambda (,a) ,(uncps cps-exp env id)))]
[`(,(? unary-op? rator) ,simp-rand)
(uncps simp-rand env
(lambda (rand)
(ctx `(,rator ,rand))))]
[`(,(? bin-op? rator) ,simp-v1 ,simp-v2)
(uncps simp-v1 env
(lambda (v1)
(uncps simp-v2 env
(lambda (v2)
(ctx `(,rator ,v1 ,v2))))))]
;;cps-exp
[`(if ,simp-test ,cps-then ,cps-else)
(uncps simp-test env
(lambda (test)
`(if ,test
,(uncps cps-then env ctx)
,(uncps cps-else env ctx))))]
[`(let ([k ,k-exp]) ,e)
(expand-k (uncps e env id) k-exp env ctx)]
[`(k ,simp) (uncps simp env ctx)]
[`(,simp-rator ,simp-rand ,k-exp)
(uncps simp-rator env
(lambda (rator)
(uncps simp-rand env
(lambda (rand)
(expand-k `(,rator ,rand) k-exp env ctx)))))])))
修改了一点的CPS变换代码：
#lang racket
(provide cps self-evaluate? id bin-op? unary-op?)
(define self-evaluate?
(lambda (thing)
(or (number? thing) (boolean? thing))))
(define id
(lambda (v) v))
(define ctx0
(lambda (v)
`(k ,v)))
(define unary-op?
(lambda (x)
(memq x '(add1 sub1 zero? car cdr))))
(define bin-op?
(lambda (x)
(memq x '(cons + - * / < > = <= >=))))
(define cps
(lambda (sexp [ctx id])
(match sexp
[(? self-evaluate?) (ctx sexp)]
[(? symbol?) (ctx sexp)]
[`(quote ,thing) (ctx sexp)]
[`(if ,test ,then ,else) (cps test
(lambda (simple-test)
(if (memq ctx `(,ctx0 ,id))
`(if ,simple-test
,(cps then ctx)
,(cps else ctx))
`(let ([k (lambda (v) ,(ctx 'v))])
(if ,simple-test
,(cps then ctx0)
,(cps else ctx0))))))]
[`(lambda (,a) ,e)
(ctx `(lambda (,a k) ,(cps e ctx0)))]
[`(,rator ,rand) (cps rator
(lambda (simple-rator)
(cps rand
(lambda (simple-rand)
(cond [(unary-op? simple-rator)
(ctx `(,simple-rator ,simple-rand))]
[(eq? ctx ctx0)
(list simple-rator simple-rand 'k)]
[else
(let ([v (gensym "v")])
(list simple-rator simple-rand
`(lambda (,v)
,(ctx v))))])))))]
[`(,(? bin-op? op) ,a ,b) (cps a
(lambda (a)
(cps b
(lambda (b)
(ctx `(,op ,a ,b))))))])))
然后是抄来的测试案例：
(define test
(lambda (sexp)
(equal? (uncps (cps sexp)) sexp)))
(define test-all
(lambda ()
(andmap test
'(
x
(lambda (x) x)
(lambda (x) (x 1))
(if (f x) a b)
(if x (f a) b)
(lambda (x) (if (f x) a b))
(lambda (x) (if (if x (f a) b) c d))
(lambda (x) (if (if x (zero? a) b) c d))
(lambda (x) (if t (if x (f a) b) c))
(lambda (x) (if (if t (if x (f a) b) c) e w))
(lambda (x) (h (if x (f a) b)))
(lambda (x) ((if x (f g) h) c))
(((f a) (g b)) ((f c) (g d)))
(lambda (n)
((lambda (fact)
((fact fact) n))
(lambda (fact)
(lambda (n)
(if (zero? n)
1
(* n ((fact fact) (sub1 n))))))))))))
测试通过：
> (test-all)
#t
*****************************************************
就是將一段代碼轉換爲等價的 Continuation Passing Style。這東西不好解釋，推薦去看這本書： Essentials of Programming Languages （搞 scheme 的都應該認識本書的作者， Daniel P Friedman，這人也是王珢在 Indiana 大學的導師）
他自己以前说过:自动的CPS变换. 用伪C代码解释一个:
比如, 变换前的:
int sum(int* arr, int len){
if(len <= 0) return 0; else return arr[0] + sum(arr+1, len-1);
}
调用: print(sum([1,2,3,4], 4)) //输出 10;
变换后的:
void sum_cps(int sum, int* arr, int len, void (callback*)(int)){
if(len <= 0) callback(sum);
else sum_cps(sum + arr[0], arr+1, len-1, callback);
}
调用:(sum_cps, 0, [1,2,3,4], 4, print);
这样变换以后, 自动变成尾递归. sum 每次递归调用需要把arr[0] 压栈, len大时会堆栈溢出, 而sum_cps,需要的栈为0, 不会堆栈溢出.
递归调用是FP的根本, 所以自动实现这种变换意义很大.
比如, 变换前的:
int sum(int* arr, int len){
if(len <= 0) return 0; else return arr[0] + sum(arr+1, len-1);
}
调用: print(sum([1,2,3,4], 4)) //输出 10;
变换后的:
void sum_cps(int sum, int* arr, int len, void (callback*)(int)){
if(len <= 0) callback(sum);
else sum_cps(sum + arr[0], arr+1, len-1, callback);
}
调用:(sum_cps, 0, [1,2,3,4], 4, print);
这样变换以后, 自动变成尾递归. sum 每次递归调用需要把arr[0] 压栈, len大时会堆栈溢出, 而sum_cps,需要的栈为0, 不会堆栈溢出.
递归调用是FP的根本, 所以自动实现这种变换意义很大.
CPS的基本思想是将普通函数的return转换为调用另一个函数（即这个函数的continuation），由于函数永远都不会返回，我们也就不需要调用栈。举例来说呢，Chicken Scheme这样的编译器就会利用CPS来消除调用栈。
另外，如果一个程序写成了CPS形式的话，call/cc这个special form可以用一个普通函数来实现：
(lambda (f k) (f (lambda (v k0) (k v)) k))
由于call/cc一直是解释器性能优化的一个难点，不难理解CPS转换对于现代函数式语言的编译器、解释器的重要意义了。
另外，如果一个程序写成了CPS形式的话，call/cc这个special form可以用一个普通函数来实现：
(lambda (f k) (f (lambda (v k0) (k v)) k))
由于call/cc一直是解释器性能优化的一个难点，不难理解CPS转换对于现代函数式语言的编译器、解释器的重要意义了。
************************************************************
http://www.cppblog.com/vczh/
http://zhuanlan.zhihu.com/dummydigit
****************************************
=============== End