CPS 王垠

2025-10-28

CPS 王垠

摘要: CPS.scm ,pmatch.scm

Stat

 1;; A simple CPS transformer which does proper tail-call and does not  
 2;; duplicate contexts for if-expressions.  
 3  
 4;; author: Yin Wang ([email protected])  
 5  
 6  
 7(load "pmatch.scm")  
 8  
 9  
10(define cps  
11(lambda (exp)  
12(letrec  
13([trivial? (lambda (x) (memq x '(zero? add1 sub1)))]  
14[id (lambda (v) v)]  
15[ctx0 (lambda (v) `(k ,v))] ; tail context  
16[fv (let ([n -1])  
17(lambda ()  
18(set! n (+ 1 n))  
19(string->symbol (string-append "v" (number->string n)))))]  
20[cps1  
21(lambda (exp ctx)  
22(pmatch exp  
23[,x (guard (not (pair? x))) (ctx x)]  
24[(if ,test ,conseq ,alt)  
25(cps1 test  
26(lambda (t)  
27(cond  
28[(memq ctx (list ctx0 id))  
29`(if ,t ,(cps1 conseq ctx) ,(cps1 alt ctx))]  
30[else  
31(let ([u (fv)])  
32`(let ([k (lambda (,u) ,(ctx u))])  
33(if ,t ,(cps1 conseq ctx0) ,(cps1 alt ctx0))))])))]  
34[(lambda (,x) ,body)  
35(ctx `(lambda (,x k) ,(cps1 body ctx0)))]  
36[(,op ,a ,b)  
37(cps1 a (lambda (v1)  
38(cps1 b (lambda (v2)  
39(ctx `(,op ,v1 ,v2))))))]  
40[(,rator ,rand)  
41(cps1 rator  
42(lambda (r)  
43(cps1 rand  
44(lambda (d)  
45(cond  
46[(trivial? r) (ctx `(,r ,d))]  
47[(eq? ctx ctx0) `(,r ,d k)] ; tail call  
48[else  
49(let ([u (fv)])  
50`(,r ,d (lambda (,u) ,(ctx u))))])))))]))])  
51(cps1 exp id))))%  

 1(define-syntax pmatch  
 2(syntax-rules (else guard)  
 3((_ (rator rand ...) cs ...)  
 4(let ((v (rator rand ...)))  
 5(pmatch v cs ...)))  
 6((_ v) (error 'pmatch "failed: ~s" v))  
 7((_ v (else e0 e ...)) (begin e0 e ...))  
 8((_ v (pat (guard g ...) e0 e ...) cs ...)  
 9(let ((fk (lambda () (pmatch v cs ...))))  
10(ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk))))  
11((_ v (pat e0 e ...) cs ...)  
12(let ((fk (lambda () (pmatch v cs ...))))  
13(ppat v pat (begin e0 e ...) (fk))))))  
14  
15(define-syntax ppat  
16(syntax-rules (_ quote unquote)  
17((_ v _ kt kf) kt)  
18((_ v () kt kf) (if (null? v) kt kf))  
19((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf))  
20((_ v (unquote var) kt kf) (let ((var v)) kt))  
21((_ v (x . y) kt kf)  
22(if (pair? v)  
23(let ((vx (car v)) (vy (cdr v)))  
24(ppat vx x (ppat vy y kt kf) kf))  
25kf))  
26((_ v lit kt kf) (if (equal? v (quote lit)) kt kf))))  
27

test

 1;;; tests  
 2  
 3;; var  
 4(cps 'x)  
 5(cps '(lambda (x) x))  
 6(cps '(lambda (x) (x 1)))  
 7  
 8  
 9;; no lambda (will generate identity functions to return to the toplevel)  
10(cps '(if (f x) a b))  
11(cps '(if x (f a) b))  
12  
13  
14;; if stand-alone (tail)  
15(cps '(lambda (x) (if (f x) a b)))  
16  
17  
18;; if inside if-test (non-tail)  
19(cps '(lambda (x) (if (if x (f a) b) c d)))  
20  
21  
22;; both branches are trivial, should do some more optimizations  
23(cps '(lambda (x) (if (if x (zero? a) b) c d)))  
24  
25  
26;; if inside if-branch (tail)  
27(cps '(lambda (x) (if t (if x (f a) b) c)))  
28  
29  
30;; if inside if-branch, but again inside another if-test (non-tail)  
31(cps '(lambda (x) (if (if t (if x (f a) b) c) e w)))  
32  
33  
34;; if as operand (non-tail)  
35(cps '(lambda (x) (h (if x (f a) b))))  
36  
37  
38;; if as operator (non-tail)  
39(cps '(lambda (x) ((if x (f g) h) c)))  
40  
41  
42;; why we need more than two names  
43(cps '(((f a) (g b)) ((f c) (g d))))  
44  
45  
46  
47;; factorial  
48(define fact-cps  
49(cps  
50'(lambda (n)  
51((lambda (fact)  
52((fact fact) n))  
53(lambda (fact)  
54(lambda (n)  
55(if (zero? n)  
561  
57(* n ((fact fact) (sub1 n))))))))))  
58  
59;; print out CPSed function  
60(pretty-print fact-cps)  
61;; =>  
62;; '(lambda (n k)  
63;; ((lambda (fact k) (fact fact (lambda (v0) (v0 n k))))  
64;; (lambda (fact k)  
65;; (k  
66;; (lambda (n k)  
67;; (if (zero? n)  
68;; (k 1)  
69;; (fact  
70;; fact  
71;; (lambda (v1) (v1 (sub1 n) (lambda (v2) (k (* n v2))))))))))  
72;; k))  
73  
74  
75((eval fact-cps) 5 (lambda (v) v))  
76;; => 120

大佬的代码解析

Loading image...
Please wait a moment
Loading image...
Please wait a moment