blob: 0c857076afa500ca6f8dab1aa6ca65ca7e91c5ae (
plain) (
blame)
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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
(define-library (csc cps)
(export
ir1->ir2)
(import (only (csc gensym) gensym)
(only (csc hash-map)
insert
make-map
merge)
(only (csc ir1)
call-arguments
call-procedure
call?
constant?
define-syntax?
if-alternate
if-consequent
if-test
if?
lambda-body
lambda-case-alternate
lambda-case-arguments
lambda-case-body
lambda-case-gensyms
lambda-case-rest
lambda?
letrec-expression
letrec-gensyms
letrec-names
letrec-values
letrec?
lexical-ref?
lexical-set-expression
lexical-set-ref
lexical-set?
library-define-expression
library-define-ref
library-define?
library-ref?
make-call
make-constant
make-lambda
make-lambda-case
make-lexical-ref
make-lexical-set
make-sequence
sequence-head
sequence-tail
sequence?)
(only (csc ir2)
make-atom
make-branch
make-call-closure
make-closure
make-kargs
make-klabel
make-ktail
make-lambda-args
make-update)
(only (csc loop)
loop
return)
(scheme base))
(begin
(define (new-ref)
(make-lexical-ref 'generated-symbol (gensym)))
(define (to-cps expr continuation add-continuation)
(cond
((or (constant? expr)
(lexical-ref? expr)
(library-ref? expr))
(make-atom expr continuation))
((lexical-set? expr)
(let ((ref (new-ref)))
(to-cps
(lexical-set-expression expr)
(add-continuation
(make-kargs (list ref)
(make-update (lexical-set-ref expr) ref continuation)))
add-continuation)))
((library-define? expr)
(let ((ref (new-ref)))
(to-cps
(library-define-expression expr)
(add-continuation
(make-kargs (list ref)
(make-update (library-define-ref expr) ref continuation)))
add-continuation)))
((define-syntax? expr)
; no-op
(make-atom (make-constant #f) continuation))
((if? expr)
(let* ((true-id (add-continuation
(make-klabel
(to-cps (if-consequent expr) continuation add-continuation))))
(false-id (add-continuation
(make-klabel
(to-cps (if-alternate expr) continuation add-continuation))))
(test-ref (new-ref))
(branch-id (add-continuation
(make-kargs (list test-ref)
(make-branch test-ref true-id false-id)))))
(to-cps (if-test expr) branch-id add-continuation)))
((call? expr)
; Technically the order of evaluation is unspecified. We evaluate
; expressions left to right.
(loop with terms = (cons (call-procedure expr) (call-arguments expr))
with temps = (map (lambda (x) (new-ref)) terms)
with expr = (make-call-closure (car temps) (cdr temps) continuation)
for term in (reverse terms)
for temp in (reverse temps)
do (set! expr (to-cps term
(add-continuation
(make-kargs (list temp) expr))
add-continuation))
finally (return expr)))
((sequence? expr)
(to-cps
(sequence-head expr)
(add-continuation
(make-klabel
(to-cps (sequence-tail expr) continuation add-continuation)))
add-continuation))
((lambda? expr)
(make-closure
(loop with tail = (add-continuation (make-ktail))
for lambda-case = (lambda-body expr) then (lambda-case-alternate lambda-case)
while lambda-case
collect (let ((args (lambda-case-arguments lambda-case))
(rest (lambda-case-rest lambda-case)))
(make-lambda-args
(length args)
(not (not rest))
(add-continuation
(make-kargs (map make-lexical-ref
(append args (list rest))
(lambda-case-gensyms lambda-case))
(to-cps (lambda-case-body lambda-case) tail add-continuation))))))
continuation))
((letrec? expr)
; We re-write a letrec into a corresponding lambda form.
(let ((names (letrec-names expr))
(gensyms (letrec-gensyms expr)))
(to-cps
(make-call
(make-lambda
(make-lambda-case
names
#f
gensyms
(make-sequence
(loop for name in names
for gensym in gensyms
for value in (letrec-values expr)
for set = (make-lexical-set (make-lexical-ref name gensym) value)
for body = set then (make-sequence body set)
finally (return body))
(letrec-expression expr))
#f))
(map (lambda (x) (make-constant #f)) names))
continuation
add-continuation)))
(else (error "unexpected type in to-cps" expr))))
; Returns a map from integers to CPS continuations.
; By convention the continuation at key 0 is the entrypoint.
(define (ir1->ir2 program)
(define current-continuation-id 0)
(define soup (make-map (lambda (x) x) <))
(define (add-continuation continuation)
(set! current-continuation-id (+ 1 current-continuation-id))
(set! soup (insert soup
current-continuation-id
continuation))
current-continuation-id)
(define ktail (add-continuation (make-ktail)))
(define entrypoint (to-cps program ktail add-continuation))
(insert soup 0 (make-klabel entrypoint)))))
|
