Commit | Line | Data |
---|---|---|
811d10f5 AW |
1 | ;;; TREE-IL -> GLIL compiler |
2 | ||
a5bbb22e | 3 | ;; Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc. |
811d10f5 | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
811d10f5 AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language tree-il compile-glil) | |
22 | #:use-module (system base syntax) | |
66d3e9a3 | 23 | #:use-module (system base pmatch) |
4b856371 | 24 | #:use-module (system base message) |
cf10678f | 25 | #:use-module (ice-9 receive) |
811d10f5 | 26 | #:use-module (language glil) |
60ed31d2 | 27 | #:use-module (system vm instruction) |
811d10f5 | 28 | #:use-module (language tree-il) |
073bb617 | 29 | #:use-module (language tree-il optimize) |
cf10678f | 30 | #:use-module (language tree-il analyze) |
48b1db75 | 31 | #:use-module ((srfi srfi-1) #:select (filter-map)) |
811d10f5 AW |
32 | #:export (compile-glil)) |
33 | ||
073bb617 | 34 | ;; allocation: |
66d3e9a3 | 35 | ;; sym -> {lambda -> address} |
8a4ca0ea AW |
36 | ;; lambda -> (labels . free-locs) |
37 | ;; lambda-case -> (gensym . nlocs) | |
66d3e9a3 | 38 | ;; |
8a4ca0ea AW |
39 | ;; address ::= (local? boxed? . index) |
40 | ;; labels ::= ((sym . lambda) ...) | |
66d3e9a3 AW |
41 | ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) |
42 | ;; free variable addresses are relative to parent proc. | |
073bb617 | 43 | |
a1a482e0 AW |
44 | (define *comp-module* (make-fluid)) |
45 | ||
4b856371 | 46 | (define %warning-passes |
48b1db75 | 47 | `((unused-variable . ,unused-variable-analysis) |
bcae9a98 | 48 | (unused-toplevel . ,unused-toplevel-analysis) |
ae03cf1f LC |
49 | (unbound-variable . ,unbound-variable-analysis) |
50 | (arity-mismatch . ,arity-analysis))) | |
4b856371 | 51 | |
811d10f5 | 52 | (define (compile-glil x e opts) |
4b856371 LC |
53 | (define warnings |
54 | (or (and=> (memq #:warnings opts) cadr) | |
55 | '())) | |
56 | ||
43eb8aca | 57 | ;; Go through the warning passes. |
48b1db75 LC |
58 | (let ((analyses (filter-map (lambda (kind) |
59 | (assoc-ref %warning-passes kind)) | |
60 | warnings))) | |
61 | (analyze-tree analyses x e)) | |
aaae0d5a | 62 | |
8a4ca0ea | 63 | (let* ((x (make-lambda (tree-il-src x) '() |
1e2a8edb | 64 | (make-lambda-case #f '() #f #f #f '() '() x #f))) |
aaae0d5a AW |
65 | (x (optimize! x e opts)) |
66 | (allocation (analyze-lexicals x))) | |
4b856371 | 67 | |
f95f82f8 | 68 | (with-fluid* *comp-module* e |
a1a482e0 | 69 | (lambda () |
9b29d607 | 70 | (values (flatten-lambda x #f allocation) |
f95f82f8 | 71 | e |
a1a482e0 | 72 | e))))) |
811d10f5 AW |
73 | |
74 | \f | |
811d10f5 | 75 | |
112edbae AW |
76 | (define *primcall-ops* (make-hash-table)) |
77 | (for-each | |
78 | (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) | |
79 | '(((eq? . 2) . eq?) | |
80 | ((eqv? . 2) . eqv?) | |
81 | ((equal? . 2) . equal?) | |
82 | ((= . 2) . ee?) | |
83 | ((< . 2) . lt?) | |
84 | ((> . 2) . gt?) | |
85 | ((<= . 2) . le?) | |
86 | ((>= . 2) . ge?) | |
87 | ((+ . 2) . add) | |
88 | ((- . 2) . sub) | |
7382f23e AW |
89 | ((1+ . 1) . add1) |
90 | ((1- . 1) . sub1) | |
112edbae AW |
91 | ((* . 2) . mul) |
92 | ((/ . 2) . div) | |
93 | ((quotient . 2) . quo) | |
94 | ((remainder . 2) . rem) | |
95 | ((modulo . 2) . mod) | |
b10d9330 AW |
96 | ((ash . 2) . ash) |
97 | ((logand . 2) . logand) | |
98 | ((logior . 2) . logior) | |
99 | ((logxor . 2) . logxor) | |
112edbae AW |
100 | ((not . 1) . not) |
101 | ((pair? . 1) . pair?) | |
102 | ((cons . 2) . cons) | |
103 | ((car . 1) . car) | |
104 | ((cdr . 1) . cdr) | |
105 | ((set-car! . 2) . set-car!) | |
106 | ((set-cdr! . 2) . set-cdr!) | |
107 | ((null? . 1) . null?) | |
c11f46af AW |
108 | ((list? . 1) . list?) |
109 | (list . list) | |
ad9b8c45 | 110 | (vector . vector) |
aec4a84a | 111 | ((class-of . 1) . class-of) |
ad9b8c45 | 112 | ((@slot-ref . 2) . slot-ref) |
d6f1ce3d AW |
113 | ((@slot-set! . 3) . slot-set) |
114 | ((vector-ref . 2) . vector-ref) | |
115 | ((vector-set! . 3) . vector-set) | |
1d30393f AW |
116 | ((variable-ref . 1) . variable-ref) |
117 | ;; nb, *not* variable-set! -- the args are switched | |
118 | ((variable-set . 2) . variable-set) | |
d27a7811 | 119 | ((variable-bound? . 1) . variable-bound?) |
bd91ecce LC |
120 | ((struct? . 1) . struct?) |
121 | ((struct-vtable . 1) . struct-vtable) | |
a752c0dc LC |
122 | ((struct-ref . 2) . struct-ref) |
123 | ((struct-set! . 3) . struct-set) | |
bd91ecce | 124 | (make-struct . make-struct) |
39141c87 | 125 | |
d61e866c AW |
126 | ;; hack for javascript |
127 | ((return . 1) return) | |
128 | ||
39141c87 AW |
129 | ((bytevector-u8-ref . 2) . bv-u8-ref) |
130 | ((bytevector-u8-set! . 3) . bv-u8-set) | |
131 | ((bytevector-s8-ref . 2) . bv-s8-ref) | |
132 | ((bytevector-s8-set! . 3) . bv-s8-set) | |
133 | ||
134 | ((bytevector-u16-ref . 3) . bv-u16-ref) | |
135 | ((bytevector-u16-set! . 4) . bv-u16-set) | |
136 | ((bytevector-u16-native-ref . 2) . bv-u16-native-ref) | |
137 | ((bytevector-u16-native-set! . 3) . bv-u16-native-set) | |
138 | ((bytevector-s16-ref . 3) . bv-s16-ref) | |
139 | ((bytevector-s16-set! . 4) . bv-s16-set) | |
140 | ((bytevector-s16-native-ref . 2) . bv-s16-native-ref) | |
141 | ((bytevector-s16-native-set! . 3) . bv-s16-native-set) | |
142 | ||
143 | ((bytevector-u32-ref . 3) . bv-u32-ref) | |
144 | ((bytevector-u32-set! . 4) . bv-u32-set) | |
145 | ((bytevector-u32-native-ref . 2) . bv-u32-native-ref) | |
146 | ((bytevector-u32-native-set! . 3) . bv-u32-native-set) | |
147 | ((bytevector-s32-ref . 3) . bv-s32-ref) | |
148 | ((bytevector-s32-set! . 4) . bv-s32-set) | |
149 | ((bytevector-s32-native-ref . 2) . bv-s32-native-ref) | |
150 | ((bytevector-s32-native-set! . 3) . bv-s32-native-set) | |
151 | ||
152 | ((bytevector-u64-ref . 3) . bv-u64-ref) | |
153 | ((bytevector-u64-set! . 4) . bv-u64-set) | |
154 | ((bytevector-u64-native-ref . 2) . bv-u64-native-ref) | |
155 | ((bytevector-u64-native-set! . 3) . bv-u64-native-set) | |
156 | ((bytevector-s64-ref . 3) . bv-s64-ref) | |
157 | ((bytevector-s64-set! . 4) . bv-s64-set) | |
158 | ((bytevector-s64-native-ref . 2) . bv-s64-native-ref) | |
159 | ((bytevector-s64-native-set! . 3) . bv-s64-native-set) | |
160 | ||
161 | ((bytevector-ieee-single-ref . 3) . bv-f32-ref) | |
162 | ((bytevector-ieee-single-set! . 4) . bv-f32-set) | |
163 | ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref) | |
164 | ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set) | |
165 | ((bytevector-ieee-double-ref . 3) . bv-f64-ref) | |
166 | ((bytevector-ieee-double-set! . 4) . bv-f64-set) | |
167 | ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref) | |
168 | ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set))) | |
169 | ||
170 | ||
171 | \f | |
112edbae | 172 | |
811d10f5 AW |
173 | (define (make-label) (gensym ":L")) |
174 | ||
66d3e9a3 | 175 | (define (vars->bind-list ids vars allocation proc) |
2ce77f2d | 176 | (map (lambda (id v) |
66d3e9a3 AW |
177 | (pmatch (hashq-ref (hashq-ref allocation v) proc) |
178 | ((#t ,boxed? . ,n) | |
179 | (list id boxed? n)) | |
9a9d82c2 | 180 | (,x (error "badness" id v x)))) |
2ce77f2d | 181 | ids |
cf10678f AW |
182 | vars)) |
183 | ||
66d3e9a3 | 184 | (define (emit-bindings src ids vars allocation proc emit-code) |
d97b69d9 AW |
185 | (emit-code src (make-glil-bind |
186 | (vars->bind-list ids vars allocation proc)))) | |
cf10678f AW |
187 | |
188 | (define (with-output-to-code proc) | |
189 | (let ((out '())) | |
190 | (define (emit-code src x) | |
191 | (set! out (cons x out)) | |
192 | (if src | |
193 | (set! out (cons (make-glil-source src) out)))) | |
194 | (proc emit-code) | |
195 | (reverse out))) | |
196 | ||
9b29d607 | 197 | (define (flatten-lambda x self-label allocation) |
8a4ca0ea AW |
198 | (record-case x |
199 | ((<lambda> src meta body) | |
200 | (make-glil-program | |
201 | meta | |
202 | (with-output-to-code | |
203 | (lambda (emit-code) | |
204 | ;; write source info for proc | |
205 | (if src (emit-code #f (make-glil-source src))) | |
206 | ;; emit pre-prelude label for self tail calls in which the | |
207 | ;; number of arguments doesn't check out at compile time | |
208 | (if self-label | |
209 | (emit-code #f (make-glil-label self-label))) | |
210 | ;; compile the body, yo | |
211 | (flatten body allocation x self-label (car (hashq-ref allocation x)) | |
212 | emit-code))))))) | |
cf10678f | 213 | |
230cfcfb | 214 | (define (flatten x allocation self self-label fix-labels emit-code) |
cf10678f AW |
215 | (define (emit-label label) |
216 | (emit-code #f (make-glil-label label))) | |
217 | (define (emit-branch src inst label) | |
218 | (emit-code src (make-glil-branch inst label))) | |
219 | ||
230cfcfb AW |
220 | ;; RA: "return address"; #f unless we're in a non-tail fix with labels |
221 | ;; MVRA: "multiple-values return address"; #f unless we're in a let-values | |
222 | (let comp ((x x) (context 'tail) (RA #f) (MVRA #f)) | |
223 | (define (comp-tail tree) (comp tree context RA MVRA)) | |
224 | (define (comp-push tree) (comp tree 'push #f #f)) | |
225 | (define (comp-drop tree) (comp tree 'drop #f #f)) | |
226 | (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) | |
227 | (define (comp-fix tree RA) (comp tree context RA MVRA)) | |
228 | ||
229 | ;; A couple of helpers. Note that if we are in tail context, we | |
230 | ;; won't have an RA. | |
231 | (define (maybe-emit-return) | |
232 | (if RA | |
233 | (emit-branch #f 'br RA) | |
234 | (if (eq? context 'tail) | |
235 | (emit-code #f (make-glil-call 'return 1))))) | |
236 | ||
cf10678f AW |
237 | (record-case x |
238 | ((<void>) | |
239 | (case context | |
230cfcfb AW |
240 | ((push vals tail) |
241 | (emit-code #f (make-glil-void)))) | |
242 | (maybe-emit-return)) | |
cf10678f AW |
243 | |
244 | ((<const> src exp) | |
245 | (case context | |
230cfcfb AW |
246 | ((push vals tail) |
247 | (emit-code src (make-glil-const exp)))) | |
248 | (maybe-emit-return)) | |
cf10678f AW |
249 | |
250 | ;; FIXME: should represent sequence as exps tail | |
e5f5113c | 251 | ((<sequence> exps) |
cf10678f AW |
252 | (let lp ((exps exps)) |
253 | (if (null? (cdr exps)) | |
254 | (comp-tail (car exps)) | |
255 | (begin | |
256 | (comp-drop (car exps)) | |
257 | (lp (cdr exps)))))) | |
258 | ||
259 | ((<application> src proc args) | |
dce042f1 | 260 | ;; FIXME: need a better pattern-matcher here |
112edbae | 261 | (cond |
dce042f1 AW |
262 | ((and (primitive-ref? proc) |
263 | (eq? (primitive-ref-name proc) '@apply) | |
0f423f20 | 264 | (>= (length args) 1)) |
dce042f1 AW |
265 | (let ((proc (car args)) |
266 | (args (cdr args))) | |
267 | (cond | |
268 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) | |
f4aa8d53 | 269 | (not (eq? context 'push)) (not (eq? context 'vals))) |
dce042f1 AW |
270 | ;; tail: (lambda () (apply values '(1 2))) |
271 | ;; drop: (lambda () (apply values '(1 2)) 3) | |
272 | ;; push: (lambda () (list (apply values '(10 12)) 1)) | |
273 | (case context | |
230cfcfb | 274 | ((drop) (for-each comp-drop args) (maybe-emit-return)) |
dce042f1 AW |
275 | ((tail) |
276 | (for-each comp-push args) | |
277 | (emit-code src (make-glil-call 'return/values* (length args)))))) | |
278 | ||
279 | (else | |
dce042f1 | 280 | (case context |
0f423f20 AW |
281 | ((tail) |
282 | (comp-push proc) | |
283 | (for-each comp-push args) | |
a5bbb22e | 284 | (emit-code src (make-glil-call 'tail-apply (1+ (length args))))) |
0f423f20 | 285 | ((push) |
b7946e9e | 286 | (emit-code src (make-glil-call 'new-frame 0)) |
0f423f20 AW |
287 | (comp-push proc) |
288 | (for-each comp-push args) | |
230cfcfb AW |
289 | (emit-code src (make-glil-call 'apply (1+ (length args)))) |
290 | (maybe-emit-return)) | |
f4aa8d53 AW |
291 | ((vals) |
292 | (comp-vals | |
293 | (make-application src (make-primitive-ref #f 'apply) | |
294 | (cons proc args)) | |
230cfcfb AW |
295 | MVRA) |
296 | (maybe-emit-return)) | |
0f423f20 AW |
297 | ((drop) |
298 | ;; Well, shit. The proc might return any number of | |
299 | ;; values (including 0), since it's in a drop context, | |
300 | ;; yet apply does not create a MV continuation. So we | |
301 | ;; mv-call out to our trampoline instead. | |
302 | (comp-drop | |
303 | (make-application src (make-primitive-ref #f 'apply) | |
230cfcfb AW |
304 | (cons proc args))) |
305 | (maybe-emit-return))))))) | |
306 | ||
a1a482e0 AW |
307 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) |
308 | (not (eq? context 'push))) | |
309 | ;; tail: (lambda () (values '(1 2))) | |
310 | ;; drop: (lambda () (values '(1 2)) 3) | |
311 | ;; push: (lambda () (list (values '(10 12)) 1)) | |
f4aa8d53 | 312 | ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) |
a1a482e0 | 313 | (case context |
230cfcfb | 314 | ((drop) (for-each comp-drop args) (maybe-emit-return)) |
f4aa8d53 AW |
315 | ((vals) |
316 | (for-each comp-push args) | |
317 | (emit-code #f (make-glil-const (length args))) | |
230cfcfb | 318 | (emit-branch src 'br MVRA)) |
a1a482e0 AW |
319 | ((tail) |
320 | (for-each comp-push args) | |
321 | (emit-code src (make-glil-call 'return/values (length args)))))) | |
f4aa8d53 | 322 | |
dce042f1 AW |
323 | ((and (primitive-ref? proc) |
324 | (eq? (primitive-ref-name proc) '@call-with-values) | |
325 | (= (length args) 2)) | |
326 | ;; CONSUMER | |
327 | ;; PRODUCER | |
328 | ;; (mv-call MV) | |
329 | ;; ([tail]-call 1) | |
330 | ;; goto POST | |
331 | ;; MV: [tail-]call/nargs | |
332 | ;; POST: (maybe-drop) | |
f4aa8d53 AW |
333 | (case context |
334 | ((vals) | |
335 | ;; Fall back. | |
336 | (comp-vals | |
337 | (make-application src (make-primitive-ref #f 'call-with-values) | |
338 | args) | |
230cfcfb AW |
339 | MVRA) |
340 | (maybe-emit-return)) | |
f4aa8d53 AW |
341 | (else |
342 | (let ((MV (make-label)) (POST (make-label)) | |
343 | (producer (car args)) (consumer (cadr args))) | |
b7946e9e AW |
344 | (if (not (eq? context 'tail)) |
345 | (emit-code src (make-glil-call 'new-frame 0))) | |
f4aa8d53 | 346 | (comp-push consumer) |
b7946e9e | 347 | (emit-code src (make-glil-call 'new-frame 0)) |
f4aa8d53 AW |
348 | (comp-push producer) |
349 | (emit-code src (make-glil-mv-call 0 MV)) | |
350 | (case context | |
a5bbb22e | 351 | ((tail) (emit-code src (make-glil-call 'tail-call 1))) |
f4aa8d53 AW |
352 | (else (emit-code src (make-glil-call 'call 1)) |
353 | (emit-branch #f 'br POST))) | |
354 | (emit-label MV) | |
355 | (case context | |
a5bbb22e | 356 | ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0))) |
f4aa8d53 AW |
357 | (else (emit-code src (make-glil-call 'call/nargs 0)) |
358 | (emit-label POST) | |
359 | (if (eq? context 'drop) | |
230cfcfb AW |
360 | (emit-code #f (make-glil-call 'drop 1))) |
361 | (maybe-emit-return))))))) | |
dce042f1 AW |
362 | |
363 | ((and (primitive-ref? proc) | |
364 | (eq? (primitive-ref-name proc) '@call-with-current-continuation) | |
e32a1792 | 365 | (= (length args) 1)) |
dce042f1 | 366 | (case context |
0f423f20 AW |
367 | ((tail) |
368 | (comp-push (car args)) | |
a5bbb22e | 369 | (emit-code src (make-glil-call 'tail-call/cc 1))) |
f4aa8d53 AW |
370 | ((vals) |
371 | (comp-vals | |
372 | (make-application | |
373 | src (make-primitive-ref #f 'call-with-current-continuation) | |
374 | args) | |
230cfcfb AW |
375 | MVRA) |
376 | (maybe-emit-return)) | |
0f423f20 AW |
377 | ((push) |
378 | (comp-push (car args)) | |
230cfcfb AW |
379 | (emit-code src (make-glil-call 'call/cc 1)) |
380 | (maybe-emit-return)) | |
0f423f20 AW |
381 | ((drop) |
382 | ;; Crap. Just like `apply' in drop context. | |
383 | (comp-drop | |
384 | (make-application | |
385 | src (make-primitive-ref #f 'call-with-current-continuation) | |
230cfcfb AW |
386 | args)) |
387 | (maybe-emit-return)))) | |
dce042f1 | 388 | |
112edbae | 389 | ((and (primitive-ref? proc) |
c11f46af AW |
390 | (or (hash-ref *primcall-ops* |
391 | (cons (primitive-ref-name proc) (length args))) | |
392 | (hash-ref *primcall-ops* (primitive-ref-name proc)))) | |
112edbae AW |
393 | => (lambda (op) |
394 | (for-each comp-push args) | |
395 | (emit-code src (make-glil-call op (length args))) | |
60ed31d2 AW |
396 | (case (instruction-pushes op) |
397 | ((0) | |
398 | (case context | |
230cfcfb AW |
399 | ((tail push vals) (emit-code #f (make-glil-void)))) |
400 | (maybe-emit-return)) | |
60ed31d2 AW |
401 | ((1) |
402 | (case context | |
230cfcfb AW |
403 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
404 | (maybe-emit-return)) | |
60ed31d2 AW |
405 | (else |
406 | (error "bad primitive op: too many pushes" | |
407 | op (instruction-pushes op)))))) | |
408 | ||
8a4ca0ea | 409 | ;; self-call in tail position |
9b29d607 AW |
410 | ((and (lexical-ref? proc) |
411 | self-label (eq? (lexical-ref-gensym proc) self-label) | |
8a4ca0ea AW |
412 | (eq? context 'tail)) |
413 | ;; first, evaluate new values, pushing them on the stack | |
9b29d607 | 414 | (for-each comp-push args) |
8a4ca0ea AW |
415 | (let lp ((lcase (lambda-body self))) |
416 | (cond | |
417 | ((and (lambda-case? lcase) | |
418 | (not (lambda-case-kw lcase)) | |
419 | (not (lambda-case-opt lcase)) | |
420 | (not (lambda-case-rest lcase)) | |
421 | (= (length args) (length (lambda-case-req lcase)))) | |
422 | ;; we have a case that matches the args; rename variables | |
423 | ;; and goto the case label | |
424 | (for-each (lambda (sym) | |
425 | (pmatch (hashq-ref (hashq-ref allocation sym) self) | |
426 | ((#t #f . ,index) ; unboxed | |
427 | (emit-code #f (make-glil-lexical #t #f 'set index))) | |
428 | ((#t #t . ,index) ; boxed | |
429 | ;; new box | |
430 | (emit-code #f (make-glil-lexical #t #t 'box index))) | |
431 | (,x (error "what" x)))) | |
432 | (reverse (lambda-case-vars lcase))) | |
433 | (emit-branch src 'br (car (hashq-ref allocation lcase)))) | |
434 | ((lambda-case? lcase) | |
435 | ;; no match, try next case | |
3a88cb3b | 436 | (lp (lambda-case-alternate lcase))) |
8a4ca0ea AW |
437 | (else |
438 | ;; no cases left; shuffle args down and jump before the prelude. | |
439 | (for-each (lambda (i) | |
24bf130f | 440 | (emit-code #f (make-glil-lexical #t #f 'set i))) |
8a4ca0ea AW |
441 | (reverse (iota (length args)))) |
442 | (emit-branch src 'br self-label))))) | |
9b29d607 | 443 | |
230cfcfb AW |
444 | ;; lambda, the ultimate goto |
445 | ((and (lexical-ref? proc) | |
446 | (assq (lexical-ref-gensym proc) fix-labels)) | |
8a4ca0ea AW |
447 | ;; like the self-tail-call case, though we can handle "drop" |
448 | ;; contexts too. first, evaluate new values, pushing them on | |
449 | ;; the stack | |
230cfcfb | 450 | (for-each comp-push args) |
8a4ca0ea AW |
451 | ;; find the specific case, rename args, and goto the case label |
452 | (let lp ((lcase (lambda-body | |
453 | (assq-ref fix-labels (lexical-ref-gensym proc))))) | |
454 | (cond | |
455 | ((and (lambda-case? lcase) | |
456 | (not (lambda-case-kw lcase)) | |
457 | (not (lambda-case-opt lcase)) | |
458 | (not (lambda-case-rest lcase)) | |
459 | (= (length args) (length (lambda-case-req lcase)))) | |
460 | ;; we have a case that matches the args; rename variables | |
461 | ;; and goto the case label | |
462 | (for-each (lambda (sym) | |
463 | (pmatch (hashq-ref (hashq-ref allocation sym) self) | |
464 | ((#t #f . ,index) ; unboxed | |
465 | (emit-code #f (make-glil-lexical #t #f 'set index))) | |
466 | ((#t #t . ,index) ; boxed | |
467 | (emit-code #f (make-glil-lexical #t #t 'box index))) | |
468 | (,x (error "what" x)))) | |
469 | (reverse (lambda-case-vars lcase))) | |
470 | (emit-branch src 'br (car (hashq-ref allocation lcase)))) | |
471 | ((lambda-case? lcase) | |
472 | ;; no match, try next case | |
3a88cb3b | 473 | (lp (lambda-case-alternate lcase))) |
8a4ca0ea AW |
474 | (else |
475 | ;; no cases left. we can't really handle this currently. | |
476 | ;; ideally we would push on a new frame, then do a "local | |
477 | ;; call" -- which doesn't require consing up a program | |
478 | ;; object. but for now error, as this sort of case should | |
479 | ;; preclude label allocation. | |
480 | (error "couldn't find matching case for label call" x))))) | |
230cfcfb | 481 | |
112edbae | 482 | (else |
b7946e9e AW |
483 | (if (not (eq? context 'tail)) |
484 | (emit-code src (make-glil-call 'new-frame 0))) | |
112edbae AW |
485 | (comp-push proc) |
486 | (for-each comp-push args) | |
dce042f1 AW |
487 | (let ((len (length args))) |
488 | (case context | |
a5bbb22e | 489 | ((tail) (emit-code src (make-glil-call 'tail-call len))) |
230cfcfb AW |
490 | ((push) (emit-code src (make-glil-call 'call len)) |
491 | (maybe-emit-return)) | |
492 | ((vals) (emit-code src (make-glil-mv-call len MVRA)) | |
493 | (maybe-emit-return)) | |
494 | ((drop) (let ((MV (make-label)) (POST (make-label))) | |
495 | (emit-code src (make-glil-mv-call len MV)) | |
496 | (emit-code #f (make-glil-call 'drop 1)) | |
497 | (emit-branch #f 'br (or RA POST)) | |
498 | (emit-label MV) | |
499 | (emit-code #f (make-glil-mv-bind '() #f)) | |
500 | (emit-code #f (make-glil-unbind)) | |
501 | (if RA | |
502 | (emit-branch #f 'br RA) | |
503 | (emit-label POST))))))))) | |
073bb617 | 504 | |
b6d93b11 | 505 | ((<conditional> src test consequent alternate) |
073bb617 AW |
506 | ;; TEST |
507 | ;; (br-if-not L1) | |
b6d93b11 | 508 | ;; consequent |
073bb617 | 509 | ;; (br L2) |
b6d93b11 | 510 | ;; L1: alternate |
073bb617 AW |
511 | ;; L2: |
512 | (let ((L1 (make-label)) (L2 (make-label))) | |
b4a595a5 AW |
513 | ;; need a pattern matcher |
514 | (record-case test | |
515 | ((<application> proc args) | |
516 | (record-case proc | |
517 | ((<primitive-ref> name) | |
518 | (let ((len (length args))) | |
519 | (cond | |
520 | ||
521 | ((and (eq? name 'eq?) (= len 2)) | |
522 | (comp-push (car args)) | |
523 | (comp-push (cadr args)) | |
524 | (emit-branch src 'br-if-not-eq L1)) | |
525 | ||
526 | ((and (eq? name 'null?) (= len 1)) | |
527 | (comp-push (car args)) | |
528 | (emit-branch src 'br-if-not-null L1)) | |
529 | ||
530 | ((and (eq? name 'not) (= len 1)) | |
531 | (let ((app (car args))) | |
532 | (record-case app | |
533 | ((<application> proc args) | |
534 | (let ((len (length args))) | |
535 | (record-case proc | |
536 | ((<primitive-ref> name) | |
537 | (cond | |
538 | ||
539 | ((and (eq? name 'eq?) (= len 2)) | |
540 | (comp-push (car args)) | |
541 | (comp-push (cadr args)) | |
542 | (emit-branch src 'br-if-eq L1)) | |
543 | ||
544 | ((and (eq? name 'null?) (= len 1)) | |
545 | (comp-push (car args)) | |
546 | (emit-branch src 'br-if-null L1)) | |
547 | ||
548 | (else | |
549 | (comp-push app) | |
550 | (emit-branch src 'br-if L1)))) | |
551 | (else | |
552 | (comp-push app) | |
553 | (emit-branch src 'br-if L1))))) | |
554 | (else | |
555 | (comp-push app) | |
556 | (emit-branch src 'br-if L1))))) | |
557 | ||
558 | (else | |
559 | (comp-push test) | |
560 | (emit-branch src 'br-if-not L1))))) | |
561 | (else | |
562 | (comp-push test) | |
563 | (emit-branch src 'br-if-not L1)))) | |
564 | (else | |
565 | (comp-push test) | |
566 | (emit-branch src 'br-if-not L1))) | |
567 | ||
b6d93b11 | 568 | (comp-tail consequent) |
d97b69d9 AW |
569 | ;; if there is an RA, comp-tail will cause a jump to it -- just |
570 | ;; have to clean up here if there is no RA. | |
571 | (if (and (not RA) (not (eq? context 'tail))) | |
572 | (emit-branch #f 'br L2)) | |
cf10678f | 573 | (emit-label L1) |
b4a595a5 | 574 | (comp-tail alternate) |
d97b69d9 AW |
575 | (if (and (not RA) (not (eq? context 'tail))) |
576 | (emit-label L2)))) | |
577 | ||
cf10678f | 578 | ((<primitive-ref> src name) |
a1a482e0 AW |
579 | (cond |
580 | ((eq? (module-variable (fluid-ref *comp-module*) name) | |
581 | (module-variable the-root-module name)) | |
582 | (case context | |
230cfcfb AW |
583 | ((tail push vals) |
584 | (emit-code src (make-glil-toplevel 'ref name)))) | |
585 | (maybe-emit-return)) | |
94ff26b9 | 586 | ((module-variable the-root-module name) |
a1a482e0 | 587 | (case context |
230cfcfb AW |
588 | ((tail push vals) |
589 | (emit-code src (make-glil-module 'ref '(guile) name #f)))) | |
94ff26b9 AW |
590 | (maybe-emit-return)) |
591 | (else | |
592 | (case context | |
593 | ((tail push vals) | |
594 | (emit-code src (make-glil-module | |
595 | 'ref (module-name (fluid-ref *comp-module*)) name #f)))) | |
230cfcfb | 596 | (maybe-emit-return)))) |
cf10678f | 597 | |
e5f5113c | 598 | ((<lexical-ref> src gensym) |
cf10678f | 599 | (case context |
f4aa8d53 | 600 | ((push vals tail) |
9b29d607 | 601 | (pmatch (hashq-ref (hashq-ref allocation gensym) self) |
66d3e9a3 AW |
602 | ((,local? ,boxed? . ,index) |
603 | (emit-code src (make-glil-lexical local? boxed? 'ref index))) | |
604 | (,loc | |
605 | (error "badness" x loc))))) | |
230cfcfb | 606 | (maybe-emit-return)) |
66d3e9a3 | 607 | |
e5f5113c | 608 | ((<lexical-set> src gensym exp) |
cf10678f | 609 | (comp-push exp) |
9b29d607 | 610 | (pmatch (hashq-ref (hashq-ref allocation gensym) self) |
66d3e9a3 AW |
611 | ((,local? ,boxed? . ,index) |
612 | (emit-code src (make-glil-lexical local? boxed? 'set index))) | |
613 | (,loc | |
614 | (error "badness" x loc))) | |
cf10678f | 615 | (case context |
230cfcfb AW |
616 | ((tail push vals) |
617 | (emit-code #f (make-glil-void)))) | |
618 | (maybe-emit-return)) | |
cf10678f AW |
619 | |
620 | ((<module-ref> src mod name public?) | |
621 | (emit-code src (make-glil-module 'ref mod name public?)) | |
622 | (case context | |
230cfcfb AW |
623 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
624 | (maybe-emit-return)) | |
cf10678f AW |
625 | |
626 | ((<module-set> src mod name public? exp) | |
627 | (comp-push exp) | |
628 | (emit-code src (make-glil-module 'set mod name public?)) | |
629 | (case context | |
230cfcfb AW |
630 | ((tail push vals) |
631 | (emit-code #f (make-glil-void)))) | |
632 | (maybe-emit-return)) | |
cf10678f AW |
633 | |
634 | ((<toplevel-ref> src name) | |
635 | (emit-code src (make-glil-toplevel 'ref name)) | |
636 | (case context | |
230cfcfb AW |
637 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
638 | (maybe-emit-return)) | |
cf10678f AW |
639 | |
640 | ((<toplevel-set> src name exp) | |
641 | (comp-push exp) | |
642 | (emit-code src (make-glil-toplevel 'set name)) | |
643 | (case context | |
230cfcfb AW |
644 | ((tail push vals) |
645 | (emit-code #f (make-glil-void)))) | |
646 | (maybe-emit-return)) | |
cf10678f AW |
647 | |
648 | ((<toplevel-define> src name exp) | |
649 | (comp-push exp) | |
650 | (emit-code src (make-glil-toplevel 'define name)) | |
651 | (case context | |
230cfcfb AW |
652 | ((tail push vals) |
653 | (emit-code #f (make-glil-void)))) | |
654 | (maybe-emit-return)) | |
cf10678f AW |
655 | |
656 | ((<lambda>) | |
8a4ca0ea | 657 | (let ((free-locs (cdr (hashq-ref allocation x)))) |
66d3e9a3 AW |
658 | (case context |
659 | ((push vals tail) | |
9b29d607 | 660 | (emit-code #f (flatten-lambda x #f allocation)) |
66d3e9a3 AW |
661 | (if (not (null? free-locs)) |
662 | (begin | |
663 | (for-each | |
664 | (lambda (loc) | |
665 | (pmatch loc | |
d773ba23 | 666 | ((,local? ,boxed? . ,n) |
66d3e9a3 AW |
667 | (emit-code #f (make-glil-lexical local? #f 'ref n))) |
668 | (else (error "what" x loc)))) | |
669 | free-locs) | |
6f16379e AW |
670 | (emit-code #f (make-glil-call 'make-closure |
671 | (length free-locs)))))))) | |
230cfcfb | 672 | (maybe-emit-return)) |
66d3e9a3 | 673 | |
3a88cb3b | 674 | ((<lambda-case> src req opt rest kw inits vars alternate body) |
899d37a6 AW |
675 | ;; o/~ feature on top of feature o/~ |
676 | ;; req := (name ...) | |
b0c8c187 | 677 | ;; opt := (name ...) | #f |
899d37a6 | 678 | ;; rest := name | #f |
b0c8c187 | 679 | ;; kw: (allow-other-keys? (keyword name var) ...) | #f |
899d37a6 | 680 | ;; vars: (sym ...) |
899d37a6 AW |
681 | ;; init: tree-il in context of vars |
682 | ;; vars map to named arguments in the following order: | |
683 | ;; required, optional (positional), rest, keyword. | |
684 | (let* ((nreq (length req)) | |
685 | (nopt (if opt (length opt) 0)) | |
686 | (rest-idx (and rest (+ nreq nopt))) | |
b0c8c187 | 687 | (opt-names (or opt '())) |
899d37a6 AW |
688 | (allow-other-keys? (if kw (car kw) #f)) |
689 | (kw-indices (map (lambda (x) | |
690 | (pmatch x | |
b0c8c187 | 691 | ((,key ,name ,var) |
899d37a6 AW |
692 | (cons key (list-index vars var))) |
693 | (else (error "bad kwarg" x)))) | |
694 | (if kw (cdr kw) '()))) | |
b0c8c187 AW |
695 | (nargs (apply max (+ nreq nopt (if rest 1 0)) |
696 | (map 1+ (map cdr kw-indices)))) | |
899d37a6 | 697 | (nlocs (cdr (hashq-ref allocation x))) |
3a88cb3b | 698 | (alternate-label (and alternate (make-label)))) |
899d37a6 AW |
699 | (or (= nargs |
700 | (length vars) | |
b0c8c187 | 701 | (+ nreq (length inits) (if rest 1 0))) |
899d37a6 | 702 | (error "something went wrong" |
b0c8c187 | 703 | req opt rest kw inits vars nreq nopt kw-indices nargs)) |
7e01997e AW |
704 | ;; the prelude, to check args & reset the stack pointer, |
705 | ;; allowing room for locals | |
706 | (emit-code | |
707 | src | |
708 | (cond | |
7e01997e | 709 | (kw |
899d37a6 | 710 | (make-glil-kw-prelude nreq nopt rest-idx kw-indices |
3a88cb3b | 711 | allow-other-keys? nlocs alternate-label)) |
7e01997e | 712 | ((or rest opt) |
3a88cb3b | 713 | (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label)) |
7e01997e | 714 | (#t |
3a88cb3b | 715 | (make-glil-std-prelude nreq nlocs alternate-label)))) |
7e01997e AW |
716 | ;; box args if necessary |
717 | (for-each | |
718 | (lambda (v) | |
719 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
720 | ((#t #t . ,n) | |
721 | (emit-code #f (make-glil-lexical #t #f 'ref n)) | |
722 | (emit-code #f (make-glil-lexical #t #t 'box n))))) | |
723 | vars) | |
724 | ;; write bindings info | |
725 | (if (not (null? vars)) | |
726 | (emit-bindings | |
727 | #f | |
728 | (let lp ((kw (if kw (cdr kw) '())) | |
b0c8c187 | 729 | (names (append (reverse opt-names) (reverse req))) |
899d37a6 | 730 | (vars (list-tail vars (+ nreq nopt |
7e01997e AW |
731 | (if rest 1 0))))) |
732 | (pmatch kw | |
899d37a6 AW |
733 | (() |
734 | ;; fixme: check that vars is empty | |
735 | (reverse (if rest (cons rest names) names))) | |
7e01997e AW |
736 | (((,key ,name ,var) . ,kw) |
737 | (if (memq var vars) | |
738 | (lp kw (cons name names) (delq var vars)) | |
739 | (lp kw names vars))) | |
740 | (,kw (error "bad keywords, yo" kw)))) | |
741 | vars allocation self emit-code)) | |
b0c8c187 AW |
742 | ;; init optional/kw args |
743 | (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq))) | |
744 | (cond | |
745 | ((null? inits)) ; done | |
746 | ((and rest-idx (= n rest-idx)) | |
747 | (lp inits (1+ n) (cdr vars))) | |
748 | (#t | |
749 | (pmatch (hashq-ref (hashq-ref allocation (car vars)) self) | |
750 | ((#t ,boxed? . ,n*) (guard (= n* n)) | |
751 | (let ((L (make-label))) | |
752 | (emit-code #f (make-glil-lexical #t boxed? 'bound? n)) | |
753 | (emit-code #f (make-glil-branch 'br-if L)) | |
754 | (comp-push (car inits)) | |
755 | (emit-code #f (make-glil-lexical #t boxed? 'set n)) | |
756 | (emit-label L) | |
757 | (lp (cdr inits) (1+ n) (cdr vars)))) | |
758 | (#t (error "what" inits)))))) | |
7e01997e AW |
759 | ;; post-prelude case label for label calls |
760 | (emit-label (car (hashq-ref allocation x))) | |
8a4ca0ea AW |
761 | (comp-tail body) |
762 | (if (not (null? vars)) | |
763 | (emit-code #f (make-glil-unbind))) | |
3a88cb3b | 764 | (if alternate-label |
8a4ca0ea | 765 | (begin |
3a88cb3b AW |
766 | (emit-label alternate-label) |
767 | (comp-tail alternate))))) | |
8a4ca0ea | 768 | |
f4aa8d53 | 769 | ((<let> src names vars vals body) |
073bb617 | 770 | (for-each comp-push vals) |
9b29d607 | 771 | (emit-bindings src names vars allocation self emit-code) |
cf10678f | 772 | (for-each (lambda (v) |
9b29d607 | 773 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
774 | ((#t #f . ,n) |
775 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
776 | ((#t #t . ,n) | |
777 | (emit-code src (make-glil-lexical #t #t 'box n))) | |
778 | (,loc (error "badness" x loc)))) | |
cf10678f | 779 | (reverse vars)) |
f4aa8d53 | 780 | (comp-tail body) |
cf10678f AW |
781 | (emit-code #f (make-glil-unbind))) |
782 | ||
f4aa8d53 | 783 | ((<letrec> src names vars vals body) |
66d3e9a3 | 784 | (for-each (lambda (v) |
9b29d607 | 785 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
786 | ((#t #t . ,n) |
787 | (emit-code src (make-glil-lexical #t #t 'empty-box n))) | |
788 | (,loc (error "badness" x loc)))) | |
789 | vars) | |
cf10678f | 790 | (for-each comp-push vals) |
9b29d607 | 791 | (emit-bindings src names vars allocation self emit-code) |
cf10678f | 792 | (for-each (lambda (v) |
9b29d607 | 793 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
794 | ((#t #t . ,n) |
795 | (emit-code src (make-glil-lexical #t #t 'set n))) | |
796 | (,loc (error "badness" x loc)))) | |
cf10678f | 797 | (reverse vars)) |
f4aa8d53 AW |
798 | (comp-tail body) |
799 | (emit-code #f (make-glil-unbind))) | |
800 | ||
c21c89b1 | 801 | ((<fix> src names vars vals body) |
230cfcfb AW |
802 | ;; The ideal here is to just render the lambda bodies inline, and |
803 | ;; wire the code together with gotos. We can do that if | |
804 | ;; analyze-lexicals has determined that a given var has "label" | |
805 | ;; allocation -- which is the case if it is in `fix-labels'. | |
806 | ;; | |
807 | ;; But even for closures that we can't inline, we can do some | |
808 | ;; tricks to avoid heap-allocation for the binding itself. Since | |
809 | ;; we know the vals are lambdas, we can set them to their local | |
810 | ;; var slots first, then capture their bindings, mutating them in | |
811 | ;; place. | |
7f7b85cb | 812 | (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label)))) |
230cfcfb AW |
813 | (for-each |
814 | (lambda (x v) | |
815 | (cond | |
816 | ((hashq-ref allocation x) | |
817 | ;; allocating a closure | |
818 | (emit-code #f (flatten-lambda x v allocation)) | |
6f16379e AW |
819 | (let ((free-locs (cdr (hashq-ref allocation x)))) |
820 | (if (not (null? free-locs)) | |
821 | ;; Need to make-closure first, so we have a fresh closure on | |
822 | ;; the heap, but with a temporary free values. | |
823 | (begin | |
824 | (for-each (lambda (loc) | |
825 | (emit-code #f (make-glil-const #f))) | |
826 | free-locs) | |
827 | (emit-code #f (make-glil-call 'make-closure | |
828 | (length free-locs)))))) | |
230cfcfb AW |
829 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
830 | ((#t #f . ,n) | |
831 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
832 | (,loc (error "badness" x loc)))) | |
833 | (else | |
834 | ;; labels allocation: emit label & body, but jump over it | |
835 | (let ((POST (make-label))) | |
836 | (emit-branch #f 'br POST) | |
8a4ca0ea AW |
837 | (let lp ((lcase (lambda-body x))) |
838 | (if lcase | |
839 | (record-case lcase | |
3a88cb3b | 840 | ((<lambda-case> src req vars body alternate) |
8a4ca0ea AW |
841 | (emit-label (car (hashq-ref allocation lcase))) |
842 | ;; FIXME: opt & kw args in the bindings | |
843 | (emit-bindings #f req vars allocation self emit-code) | |
844 | (if src | |
845 | (emit-code #f (make-glil-source src))) | |
846 | (comp-fix body (or RA new-RA)) | |
847 | (emit-code #f (make-glil-unbind)) | |
3a88cb3b | 848 | (lp alternate))) |
8a4ca0ea | 849 | (emit-label POST))))))) |
230cfcfb AW |
850 | vals |
851 | vars) | |
852 | ;; Emit bindings metadata for closures | |
853 | (let ((binds (let lp ((out '()) (vars vars) (names names)) | |
854 | (cond ((null? vars) (reverse! out)) | |
d97b69d9 | 855 | ((assq (car vars) fix-labels) |
230cfcfb AW |
856 | (lp out (cdr vars) (cdr names))) |
857 | (else | |
858 | (lp (acons (car vars) (car names) out) | |
859 | (cdr vars) (cdr names))))))) | |
860 | (emit-bindings src (map cdr binds) (map car binds) | |
861 | allocation self emit-code)) | |
862 | ;; Now go back and fix up the bindings for closures. | |
863 | (for-each | |
864 | (lambda (x v) | |
865 | (let ((free-locs (if (hashq-ref allocation x) | |
8a4ca0ea | 866 | (cdr (hashq-ref allocation x)) |
230cfcfb AW |
867 | ;; can hit this latter case for labels allocation |
868 | '()))) | |
869 | (if (not (null? free-locs)) | |
870 | (begin | |
871 | (for-each | |
872 | (lambda (loc) | |
873 | (pmatch loc | |
d773ba23 | 874 | ((,local? ,boxed? . ,n) |
230cfcfb AW |
875 | (emit-code #f (make-glil-lexical local? #f 'ref n))) |
876 | (else (error "what" x loc)))) | |
877 | free-locs) | |
230cfcfb AW |
878 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
879 | ((#t #f . ,n) | |
880 | (emit-code #f (make-glil-lexical #t #f 'fix n))) | |
881 | (,loc (error "badness" x loc))))))) | |
882 | vals | |
883 | vars) | |
884 | (comp-tail body) | |
7f7b85cb AW |
885 | (if new-RA |
886 | (emit-label new-RA)) | |
230cfcfb | 887 | (emit-code #f (make-glil-unbind)))) |
c21c89b1 | 888 | |
8a4ca0ea AW |
889 | ((<let-values> src exp body) |
890 | (record-case body | |
3a88cb3b AW |
891 | ((<lambda-case> req opt kw rest vars body alternate) |
892 | (if (or opt kw alternate) | |
8a4ca0ea AW |
893 | (error "unexpected lambda-case in let-values" x)) |
894 | (let ((MV (make-label))) | |
895 | (comp-vals exp MV) | |
896 | (emit-code #f (make-glil-const 1)) | |
897 | (emit-label MV) | |
898 | (emit-code src (make-glil-mv-bind | |
899 | (vars->bind-list | |
900 | (append req (if rest (list rest) '())) | |
901 | vars allocation self) | |
902 | (and rest #t))) | |
903 | (for-each (lambda (v) | |
904 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
905 | ((#t #f . ,n) | |
906 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
907 | ((#t #t . ,n) | |
908 | (emit-code src (make-glil-lexical #t #t 'box n))) | |
909 | (,loc (error "badness" x loc)))) | |
910 | (reverse vars)) | |
911 | (comp-tail body) | |
c6601f10 AW |
912 | (emit-code #f (make-glil-unbind)))))) |
913 | ||
914 | ;; much trickier than i thought this would be, at first, due to the need | |
915 | ;; to have body's return value(s) on the stack while the unwinder runs, | |
916 | ;; then proceed with returning or dropping or what-have-you, interacting | |
917 | ;; with RA and MVRA. What have you, I say. | |
8da6ab34 | 918 | ((<dynwind> src body winder unwinder) |
c6601f10 AW |
919 | (comp-push winder) |
920 | (comp-push unwinder) | |
921 | (comp-drop (make-application src winder '())) | |
922 | (emit-code #f (make-glil-call 'wind 2)) | |
923 | ||
924 | (case context | |
925 | ((tail) | |
926 | (let ((MV (make-label))) | |
927 | (comp-vals body MV) | |
928 | ;; one value: unwind... | |
929 | (emit-code #f (make-glil-call 'unwind 0)) | |
930 | (comp-drop (make-application src unwinder '())) | |
931 | ;; ...and return the val | |
932 | (emit-code #f (make-glil-call 'return 1)) | |
933 | ||
934 | (emit-label MV) | |
935 | ;; multiple values: unwind... | |
936 | (emit-code #f (make-glil-call 'unwind 0)) | |
937 | (comp-drop (make-application src unwinder '())) | |
938 | ;; and return the values. | |
939 | (emit-code #f (make-glil-call 'return/nvalues 1)))) | |
940 | ||
941 | ((push) | |
942 | ;; we only want one value. so ask for one value | |
943 | (comp-push body) | |
944 | ;; and unwind, leaving the val on the stack | |
945 | (emit-code #f (make-glil-call 'unwind 0)) | |
946 | (comp-drop (make-application src unwinder '()))) | |
947 | ||
948 | ((vals) | |
949 | (let ((MV (make-label))) | |
950 | (comp-vals body MV) | |
951 | ;; one value: push 1 and fall through to MV case | |
952 | (emit-code #f (make-glil-const 1)) | |
953 | ||
954 | (emit-label MV) | |
955 | ;; multiple values: unwind... | |
956 | (emit-code #f (make-glil-call 'unwind 0)) | |
957 | (comp-drop (make-application src unwinder '())) | |
958 | ;; and goto the MVRA. | |
959 | (emit-branch #f 'br MVRA))) | |
960 | ||
961 | ((drop) | |
962 | ;; compile body, discarding values. then unwind... | |
963 | (comp-drop body) | |
964 | (emit-code #f (make-glil-call 'unwind 0)) | |
965 | (comp-drop (make-application src unwinder '())) | |
966 | ;; and fall through, or goto RA if there is one. | |
b50511b4 AW |
967 | (if RA |
968 | (emit-branch #f 'br RA))))) | |
969 | ||
970 | ((<dynlet> src fluids vals body) | |
971 | (for-each comp-push fluids) | |
972 | (for-each comp-push vals) | |
973 | (emit-code #f (make-glil-call 'wind-fluids (length fluids))) | |
974 | ||
975 | (case context | |
976 | ((tail) | |
977 | (let ((MV (make-label))) | |
978 | ;; NB: in tail case, it is possible to preserve asymptotic tail | |
979 | ;; recursion, via merging unwind-fluids structures -- but we'd need | |
980 | ;; to compile in the body twice (once in tail context, assuming the | |
981 | ;; caller unwinds, and once with this trampoline thing, unwinding | |
982 | ;; ourselves). | |
983 | (comp-vals body MV) | |
984 | ;; one value: unwind and return | |
985 | (emit-code #f (make-glil-call 'unwind-fluids 0)) | |
986 | (emit-code #f (make-glil-call 'return 1)) | |
987 | ||
988 | (emit-label MV) | |
989 | ;; multiple values: unwind and return values | |
990 | (emit-code #f (make-glil-call 'unwind-fluids 0)) | |
991 | (emit-code #f (make-glil-call 'return/nvalues 1)))) | |
992 | ||
993 | ((push) | |
994 | (comp-push body) | |
995 | (emit-code #f (make-glil-call 'unwind-fluids 0))) | |
996 | ||
997 | ((vals) | |
998 | (let ((MV (make-label))) | |
999 | (comp-vals body MV) | |
1000 | ;; one value: push 1 and fall through to MV case | |
1001 | (emit-code #f (make-glil-const 1)) | |
1002 | ||
1003 | (emit-label MV) | |
1004 | ;; multiple values: unwind and goto MVRA | |
1005 | (emit-code #f (make-glil-call 'unwind-fluids 0)) | |
1006 | (emit-branch #f 'br MVRA))) | |
1007 | ||
1008 | ((drop) | |
1009 | ;; compile body, discarding values. then unwind... | |
1010 | (comp-drop body) | |
1011 | (emit-code #f (make-glil-call 'unwind-fluids 0)) | |
1012 | ;; and fall through, or goto RA if there is one. | |
c6601f10 AW |
1013 | (if RA |
1014 | (emit-branch #f 'br RA))))) | |
1015 | ||
706a705e AW |
1016 | ((<dynref> src fluid) |
1017 | (case context | |
1018 | ((drop) | |
1019 | (comp-drop fluid)) | |
1020 | ((push vals tail) | |
1021 | (comp-push fluid) | |
1022 | (emit-code #f (make-glil-call 'fluid-ref 1)))) | |
1023 | (maybe-emit-return)) | |
1024 | ||
1025 | ((<dynset> src fluid exp) | |
1026 | (comp-push fluid) | |
1027 | (comp-push exp) | |
1028 | (emit-code #f (make-glil-call 'fluid-set 2)) | |
1029 | (case context | |
1030 | ((push vals tail) | |
1031 | (emit-code #f (make-glil-void)))) | |
1032 | (maybe-emit-return)) | |
1033 | ||
c6601f10 AW |
1034 | ;; What's the deal here? The deal is that we are compiling the start of a |
1035 | ;; delimited continuation. We try to avoid heap allocation in the normal | |
1036 | ;; case; so the body is an expression, not a thunk, and we try to render | |
1037 | ;; the handler inline. Also we did some analysis, in analyze.scm, so that | |
1038 | ;; if the continuation isn't referenced, we don't reify it. This makes it | |
1039 | ;; possible to implement catch and throw with delimited continuations, | |
1040 | ;; without any overhead. | |
07a0c7d5 | 1041 | ((<prompt> src tag body handler) |
c6601f10 AW |
1042 | (let ((H (make-label)) |
1043 | (POST (make-label)) | |
c6601f10 AW |
1044 | (escape-only? (hashq-ref allocation x))) |
1045 | ;; First, set up the prompt. | |
1046 | (comp-push tag) | |
ea6b18e8 | 1047 | (emit-code src (make-glil-prompt H escape-only?)) |
c6601f10 AW |
1048 | |
1049 | ;; Then we compile the body, with its normal return path, unwinding | |
1050 | ;; before proceeding. | |
1051 | (case context | |
1052 | ((tail) | |
1053 | (let ((MV (make-label))) | |
1054 | (comp-vals body MV) | |
1055 | ;; one value: unwind and return | |
1056 | (emit-code #f (make-glil-call 'unwind 0)) | |
1057 | (emit-code #f (make-glil-call 'return 1)) | |
1058 | ;; multiple values: unwind and return | |
1059 | (emit-label MV) | |
1060 | (emit-code #f (make-glil-call 'unwind 0)) | |
1061 | (emit-code #f (make-glil-call 'return/nvalues 1)))) | |
1062 | ||
1063 | ((push) | |
1064 | ;; we only want one value. so ask for one value, unwind, and jump to | |
1065 | ;; post | |
1066 | (comp-push body) | |
1067 | (emit-code #f (make-glil-call 'unwind 0)) | |
1068 | (emit-branch #f 'br POST)) | |
1069 | ||
1070 | ((vals) | |
1071 | (let ((MV (make-label))) | |
1072 | (comp-vals body MV) | |
1073 | ;; one value: push 1 and fall through to MV case | |
1074 | (emit-code #f (make-glil-const 1)) | |
1075 | ;; multiple values: unwind and goto MVRA | |
1076 | (emit-label MV) | |
1077 | (emit-code #f (make-glil-call 'unwind 0)) | |
1078 | (emit-branch #f 'br MVRA))) | |
1079 | ||
1080 | ((drop) | |
1081 | ;; compile body, discarding values, then unwind & fall through. | |
1082 | (comp-drop body) | |
1083 | (emit-code #f (make-glil-call 'unwind 0)) | |
1084 | (emit-branch #f 'br (or RA POST)))) | |
1085 | ||
c6601f10 | 1086 | (emit-label H) |
ea6b18e8 AW |
1087 | ;; Now the handler. The stack is now made up of the continuation, and |
1088 | ;; then the args to the continuation (pushed separately), and then the | |
1089 | ;; number of args, including the continuation. | |
1090 | (record-case handler | |
1091 | ((<lambda-case> req opt kw rest vars body alternate) | |
1092 | (if (or opt kw alternate) | |
1093 | (error "unexpected lambda-case in prompt" x)) | |
1094 | (emit-code src (make-glil-mv-bind | |
1095 | (vars->bind-list | |
1096 | (append req (if rest (list rest) '())) | |
1097 | vars allocation self) | |
1098 | (and rest #t))) | |
1099 | (for-each (lambda (v) | |
1100 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
1101 | ((#t #f . ,n) | |
1102 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
1103 | ((#t #t . ,n) | |
1104 | (emit-code src (make-glil-lexical #t #t 'box n))) | |
1105 | (,loc (error "badness" x loc)))) | |
1106 | (reverse vars)) | |
1107 | (comp-tail body) | |
1108 | (emit-code #f (make-glil-unbind)))) | |
c6601f10 | 1109 | |
c6601f10 AW |
1110 | (if (or (eq? context 'push) |
1111 | (and (eq? context 'drop) (not RA))) | |
1112 | (emit-label POST)))) | |
1113 | ||
2d026f04 | 1114 | ((<abort> src tag args tail) |
c6601f10 | 1115 | (comp-push tag) |
6e84cb95 | 1116 | (for-each comp-push args) |
2d026f04 | 1117 | (comp-push tail) |
eaefabee AW |
1118 | (emit-code src (make-glil-call 'abort (length args))) |
1119 | ;; so, the abort can actually return. if it does, the values will be on | |
1120 | ;; the stack, then the MV marker, just as in an MV context. | |
1121 | (case context | |
1122 | ((tail) | |
1123 | ;; Return values. | |
1124 | (emit-code #f (make-glil-call 'return/nvalues 1))) | |
1125 | ((drop) | |
1126 | ;; Drop all values and goto RA, or otherwise fall through. | |
1127 | (emit-code #f (make-glil-mv-bind '() #f)) | |
1128 | (emit-code #f (make-glil-unbind)) | |
1129 | (if RA (emit-branch #f 'br RA))) | |
1130 | ((push) | |
1131 | ;; Truncate to one value. | |
1132 | (emit-code #f (make-glil-mv-bind '(val) #f))) | |
1133 | ((vals) | |
1134 | ;; Go to MVRA. | |
1135 | (emit-branch #f 'br MVRA))))))) |