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