blob: cf4a26d32b49aa92f68cd8a0dff103929f0eb4c4 (
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
(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-arguments
lambda-body
lambda-rest
lambda?
letrec-expression
letrec-gensyms
letrec-in-order?
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-lexical-ref
make-lexical-set
make-sequence
sequence-head
sequence-tail
sequence?)
(only (csc ir2)
make-apply
make-atom
make-branch
make-call-closure
make-closure
make-fix
make-kargs
make-klabel
make-ktail
make-update)
(only (csc loop)
loop
return)
(scheme base))
(begin
(define (new-ref)
(make-lexical-ref 'generated-symbol (gensym)))
(define (collect-functions-and-variables expr)
(loop for name in (letrec-names expr)
for gensym in (letrec-gensyms expr)
for value in (letrec-values expr)
if (lambda? value)
collect (let ((continuation (new-ref)))
(make-closure
(make-lexical-ref name gensym)
(cons continuation (lambda-arguments value))
(lambda-rest value)
(ir1->ir2
(lambda-body value)
(lambda (z)
(make-apply continuation (list z))))))
into functions
else
collect (make-lexical-ref name gensym) into variable-names
and collect value into variable-values
finally (return (values functions variable-names variable-values))))
(define (ir1->ir2 expr continuation)
(cond
((or (constant? expr)
(lexical-ref? expr)
(library-ref? expr))
(continuation expr))
((lexical-set? expr)
(ir1->ir2
(lexical-set-expression expr)
(lambda (val)
(make-update (lexical-set-ref expr) val (continuation (make-constant #f))))))
((library-define? expr)
(ir1->ir2
(library-define-expression expr)
(lambda (val)
(make-update (library-define-ref expr) val (continuation (make-constant #f))))))
((define-syntax? expr)
; no-op
(continuation (make-constant #f)))
((if? expr)
(ir1->ir2
(if-test expr)
(lambda (val)
(define continuation-ref (new-ref))
(define result-ref (new-ref))
(make-fix
(list (make-closure continuation-ref (list result-ref) #f
(continuation result-ref)))
(make-branch val
(ir1->ir2
(if-consequent expr)
(lambda (result)
(make-apply continuation-ref (list result))))
(ir1->ir2
(if-alternate expr)
(lambda (result)
(make-apply continuation-ref (list result)))))))))
((call? expr)
(let ((return-address (new-ref))
(result (new-ref)))
(make-fix
(list (make-closure return-address (list result) #f (continuation result)))
(ir1->ir2
(call-procedure expr)
(lambda (f)
; Technically the order of evaluation is unspecified.
; We evaluate expressions left to right.
;
; I would use the loop macro, but it mutates the loop
; variables which plays badly with building a lambda.
(let loop ((args (reverse (call-arguments expr)))
(exprs (lambda (vals)
(make-apply f (cons return-address (reverse vals))))))
(if (null? args)
(exprs '())
(loop (cdr args)
(lambda (vals)
(ir1->ir2
(car args)
(lambda (val)
(exprs (cons val vals)))))))))))))
((sequence? expr)
(ir1->ir2
(sequence-head expr)
(lambda (x)
(ir1->ir2
(sequence-tail expr)
continuation))))
((lambda? expr)
(let ((f (new-ref))
(k (new-ref)))
(make-fix
(list
(make-closure f (cons k (lambda-arguments expr)) (lambda-rest expr)
(ir1->ir2
(lambda-body expr)
(lambda (ret)
(make-apply k (list ret))))))
(continuation f))))
((letrec? expr)
(let-values (((functions variable-names variable-values) (collect-functions-and-variables expr)))
(make-fix functions
(ir1->ir2
; We re-write a letrec into a corresponding lambda form.
(if (letrec-in-order? expr)
(loop for name in (reverse variable-names)
for value in (reverse variable-values)
for expr = (make-call
(make-lambda
(list name)
#f
(letrec-expression expr))
(list value))
then (make-call
(make-lambda
(list name)
#f
expr)
(list value))
finally (return expr))
(make-call
(make-lambda
variable-names
#f
(letrec-expression expr))
variable-values))
continuation))))
(else (error "unexpected type in ir1->ir2" expr))))))
|
