blob: b6decbb47ff169c0316cc170c8c32f64cb658f5f (
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
|
(define-library (csc cps)
(export
ir1->ir2)
(import (scheme base)
(only (csc gensym) gensym)
(only (csc hash-map)
insert
make-map
merge)
(only (csc ir1)
%call
%define-syntax
%if
%lambda
%letrec
%lexical-set
%library-define
%sequence
call?
constant?
if?
lambda?
letrec?
lexical-ref?
lexical-set?
library-define?
library-ref?
make-call
make-constant
make-lambda
make-lexical-ref
make-lexical-set
make-sequence
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)
(only (csc match) match))
(begin
(define (new-ref)
(make-lexical-ref 'generated-symbol (gensym)))
(define (collect-functions-and-variables expr)
(match expr
((% %letrec _ names gensyms vals _)
(loop for name in names
for gensym in gensyms
for value in vals
if (lambda? value)
collect (match value
((% %lambda args rest body)
(define continuation (new-ref))
(make-closure
(make-lexical-ref name gensym)
(cons continuation args)
rest
(ir1->ir2
body
(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)
(match expr
(_ (when (or (constant? expr)
(lexical-ref? expr)
(library-ref? expr)))
(continuation expr))
((% %lexical-set ref arg)
(ir1->ir2
arg
(lambda (val)
(make-update ref val (continuation (make-constant #f))))))
((% %library-define ref arg)
(ir1->ir2
arg
(lambda (val)
(make-update ref val (continuation (make-constant #f))))))
((% %define-syntax _ _)
; no-op
(continuation (make-constant #f)))
((% %if test consequent alternate)
(ir1->ir2
test
(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
consequent
(lambda (result)
(make-apply continuation-ref (list result))))
(ir1->ir2
alternate
(lambda (result)
(make-apply continuation-ref (list result)))))))))
((% %call proc args)
(define return-address (new-ref))
(define result (new-ref))
(make-fix
(list (make-closure return-address (list result) #f (continuation result)))
(ir1->ir2
proc
(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 args))
(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 head tail)
(ir1->ir2
head
(lambda (x)
(ir1->ir2
tail
continuation))))
((% %lambda args rest body)
(define f (new-ref))
(define k (new-ref))
(make-fix
(list
(make-closure f (cons k args) rest
(ir1->ir2
body
(lambda (ret)
(make-apply k (list ret))))))
(continuation f)))
((% %letrec in-order? _ _ _ body)
(define-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 in-order?
(loop for name in (reverse variable-names)
for value in (reverse variable-values)
for expr = (make-call
(make-lambda
(list name)
#f
body)
(list value))
then (make-call
(make-lambda
(list name)
#f
expr)
(list value))
finally (return expr))
(make-call
(make-lambda
variable-names
#f
body)
variable-values))
continuation)))
(_ (error "unexpected type in ir1->ir2" expr))))))
|
