-
Notifications
You must be signed in to change notification settings - Fork 28
/
cps.ss
131 lines (97 loc) · 3.32 KB
/
cps.ss
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
;; A simple CPS transformer which does proper tail-call and does not
;; duplicate contexts for if-expressions.
;; author: Yin Wang
(load "pmatch.scm")
(define cps
(lambda (exp)
(letrec
([trivial? (lambda (x) (memq x '(zero? add1 sub1)))]
[id (lambda (v) v)]
[ctx0 (lambda (v) `(k ,v))] ; tail context
[fv (let ([n -1])
(lambda ()
(set! n (+ 1 n))
(string->symbol (string-append "v" (number->string n)))))]
[cps1
(lambda (exp ctx)
(pmatch exp
[,x (guard (not (pair? x))) (ctx x)]
[(if ,test ,conseq ,alt)
(cps1 test
(lambda (t)
(cond
[(memq ctx (list ctx0 id))
`(if ,t ,(cps1 conseq ctx) ,(cps1 alt ctx))]
[else
(let ([u (fv)])
`(let ([k (lambda (,u) ,(ctx u))])
(if ,t ,(cps1 conseq ctx0) ,(cps1 alt ctx0))))])))]
[(lambda (,x) ,body)
(ctx `(lambda (,x k) ,(cps1 body ctx0)))]
[(,op ,a ,b)
(cps1 a (lambda (v1)
(cps1 b (lambda (v2)
(ctx `(,op ,v1 ,v2))))))]
[(,rator ,rand)
(cps1 rator
(lambda (r)
(cps1 rand
(lambda (d)
(cond
[(trivial? r) (ctx `(,r ,d))]
[(eq? ctx ctx0) `(,r ,d k)] ; tail call
[else
(let ([u (fv)])
`(,r ,d (lambda (,u) ,(ctx u))))])))))]))])
(cps1 exp id))))
;;; tests
;; var
(cps 'x)
(cps '(lambda (x) x))
(cps '(lambda (x) (x 1)))
;; no lambda (will generate identity functions to return to the toplevel)
(cps '(if (f x) a b))
(cps '(if x (f a) b))
;; if stand-alone (tail)
(cps '(lambda (x) (if (f x) a b)))
;; if inside if-test (non-tail)
(cps '(lambda (x) (if (if x (f a) b) c d)))
;; both branches are trivial, should do some more optimizations
(cps '(lambda (x) (if (if x (zero? a) b) c d)))
;; if inside if-branch (tail)
(cps '(lambda (x) (if t (if x (f a) b) c)))
;; if inside if-branch, but again inside another if-test (non-tail)
(cps '(lambda (x) (if (if t (if x (f a) b) c) e w)))
;; if as operand (non-tail)
(cps '(lambda (x) (h (if x (f a) b))))
;; if as operator (non-tail)
(cps '(lambda (x) ((if x (f g) h) c)))
;; why we need more than two names
(cps '(((f a) (g b)) ((f c) (g d))))
;; factorial
(define fact-cps
(cps
'(lambda (n)
((lambda (fact)
((fact fact) n))
(lambda (fact)
(lambda (n)
(if (zero? n)
1
(* n ((fact fact) (sub1 n))))))))))
;; print out CPSed function
(pretty-print fact-cps)
;; =>
;; '(lambda (n k)
;; ((lambda (fact k) (fact fact (lambda (v0) (v0 n k))))
;; (lambda (fact k)
;; (k
;; (lambda (n k)
;; (if (zero? n)
;; (k 1)
;; (fact
;; fact
;; (lambda (v1) (v1 (sub1 n) (lambda (v2) (k (* n v2))))))))))
;; k))
((eval fact-cps) 5 (lambda (v) v))
;; => 120