Commit | Line | Data |
---|---|---|
811d10f5 AW |
1 | ;;; TREE-IL -> GLIL compiler |
2 | ||
b81d329e | 3 | ;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. |
811d10f5 AW |
4 | |
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language tree-il compile-glil) | |
23 | #:use-module (system base syntax) | |
cf10678f | 24 | #:use-module (ice-9 receive) |
811d10f5 AW |
25 | #:use-module (language glil) |
26 | #:use-module (language tree-il) | |
073bb617 | 27 | #:use-module (language tree-il optimize) |
cf10678f | 28 | #:use-module (language tree-il analyze) |
811d10f5 AW |
29 | #:export (compile-glil)) |
30 | ||
1eec95f8 AW |
31 | ;;; TODO: |
32 | ;; | |
1eec95f8 | 33 | ;; call-with-values -> mv-bind |
1eec95f8 | 34 | ;; basic degenerate-case reduction |
1eec95f8 | 35 | |
073bb617 AW |
36 | ;; allocation: |
37 | ;; sym -> (local . index) | (heap level . index) | |
cf10678f | 38 | ;; lambda -> (nlocs . nexts) |
073bb617 | 39 | |
a1a482e0 AW |
40 | (define *comp-module* (make-fluid)) |
41 | ||
811d10f5 | 42 | (define (compile-glil x e opts) |
696495f4 | 43 | (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) |
cf10678f AW |
44 | (x (optimize! x e opts)) |
45 | (allocation (analyze-lexicals x))) | |
a1a482e0 AW |
46 | (with-fluid* *comp-module* (or (and e (car e)) (current-module)) |
47 | (lambda () | |
48 | (values (flatten-lambda x -1 allocation) | |
49 | (and e (cons (car e) (cddr e))) | |
50 | e))))) | |
811d10f5 AW |
51 | |
52 | \f | |
811d10f5 | 53 | |
112edbae AW |
54 | (define *primcall-ops* (make-hash-table)) |
55 | (for-each | |
56 | (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) | |
57 | '(((eq? . 2) . eq?) | |
58 | ((eqv? . 2) . eqv?) | |
59 | ((equal? . 2) . equal?) | |
60 | ((= . 2) . ee?) | |
61 | ((< . 2) . lt?) | |
62 | ((> . 2) . gt?) | |
63 | ((<= . 2) . le?) | |
64 | ((>= . 2) . ge?) | |
65 | ((+ . 2) . add) | |
66 | ((- . 2) . sub) | |
67 | ((* . 2) . mul) | |
68 | ((/ . 2) . div) | |
69 | ((quotient . 2) . quo) | |
70 | ((remainder . 2) . rem) | |
71 | ((modulo . 2) . mod) | |
72 | ((not . 1) . not) | |
73 | ((pair? . 1) . pair?) | |
74 | ((cons . 2) . cons) | |
75 | ((car . 1) . car) | |
76 | ((cdr . 1) . cdr) | |
77 | ((set-car! . 2) . set-car!) | |
78 | ((set-cdr! . 2) . set-cdr!) | |
79 | ((null? . 1) . null?) | |
c11f46af AW |
80 | ((list? . 1) . list?) |
81 | (list . list) | |
ad9b8c45 AW |
82 | (vector . vector) |
83 | ((@slot-ref . 2) . slot-ref) | |
84 | ((@slot-set! . 3) . slot-set))) | |
112edbae | 85 | |
811d10f5 AW |
86 | (define (make-label) (gensym ":L")) |
87 | ||
2ce77f2d AW |
88 | (define (vars->bind-list ids vars allocation) |
89 | (map (lambda (id v) | |
cf10678f AW |
90 | (let ((loc (hashq-ref allocation v))) |
91 | (case (car loc) | |
2ce77f2d AW |
92 | ((stack) (list id 'local (cdr loc))) |
93 | ((heap) (list id 'external (cddr loc))) | |
94 | (else (error "badness" id v loc))))) | |
95 | ids | |
cf10678f AW |
96 | vars)) |
97 | ||
2ce77f2d | 98 | (define (emit-bindings src ids vars allocation emit-code) |
cf10678f | 99 | (if (pair? vars) |
2ce77f2d AW |
100 | (emit-code src (make-glil-bind |
101 | (vars->bind-list ids vars allocation))))) | |
cf10678f AW |
102 | |
103 | (define (with-output-to-code proc) | |
104 | (let ((out '())) | |
105 | (define (emit-code src x) | |
106 | (set! out (cons x out)) | |
107 | (if src | |
108 | (set! out (cons (make-glil-source src) out)))) | |
109 | (proc emit-code) | |
110 | (reverse out))) | |
111 | ||
112 | (define (flatten-lambda x level allocation) | |
2ce77f2d AW |
113 | (receive (ids vars nargs nrest) |
114 | (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) | |
115 | (oids '()) (ovars '()) (n 0)) | |
116 | (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) | |
117 | ((pair? vars) (lp (cdr ids) (cdr vars) | |
118 | (cons (car ids) oids) (cons (car vars) ovars) | |
119 | (1+ n))) | |
120 | (else (values (reverse (cons ids oids)) | |
121 | (reverse (cons vars ovars)) | |
122 | (1+ n) 1)))) | |
cf10678f AW |
123 | (let ((nlocs (car (hashq-ref allocation x))) |
124 | (nexts (cdr (hashq-ref allocation x)))) | |
125 | (make-glil-program | |
126 | nargs nrest nlocs nexts (lambda-meta x) | |
127 | (with-output-to-code | |
128 | (lambda (emit-code) | |
129 | ;; write bindings and source debugging info | |
2ce77f2d | 130 | (emit-bindings #f ids vars allocation emit-code) |
cf10678f | 131 | (if (lambda-src x) |
e0c90f90 | 132 | (emit-code #f (make-glil-source (lambda-src x)))) |
cf10678f AW |
133 | |
134 | ;; copy args to the heap if necessary | |
135 | (let lp ((in vars) (n 0)) | |
136 | (if (not (null? in)) | |
a1a482e0 | 137 | (let ((loc (hashq-ref allocation (car in)))) |
cf10678f AW |
138 | (case (car loc) |
139 | ((heap) | |
a1a482e0 AW |
140 | (emit-code #f (make-glil-local 'ref n)) |
141 | (emit-code #f (make-glil-external 'set 0 (cddr loc))))) | |
cf10678f AW |
142 | (lp (cdr in) (1+ n))))) |
143 | ||
144 | ;; and here, here, dear reader: we compile. | |
145 | (flatten (lambda-body x) (1+ level) allocation emit-code))))))) | |
146 | ||
147 | (define (flatten x level allocation emit-code) | |
148 | (define (emit-label label) | |
149 | (emit-code #f (make-glil-label label))) | |
150 | (define (emit-branch src inst label) | |
151 | (emit-code src (make-glil-branch inst label))) | |
152 | ||
f4aa8d53 AW |
153 | ;; LMVRA == "let-values MV return address" |
154 | (let comp ((x x) (context 'tail) (LMVRA #f)) | |
155 | (define (comp-tail tree) (comp tree context LMVRA)) | |
156 | (define (comp-push tree) (comp tree 'push #f)) | |
157 | (define (comp-drop tree) (comp tree 'drop #f)) | |
158 | (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA)) | |
073bb617 | 159 | |
cf10678f AW |
160 | (record-case x |
161 | ((<void>) | |
162 | (case context | |
f4aa8d53 | 163 | ((push vals) (emit-code #f (make-glil-void))) |
cf10678f AW |
164 | ((tail) |
165 | (emit-code #f (make-glil-void)) | |
166 | (emit-code #f (make-glil-call 'return 1))))) | |
167 | ||
168 | ((<const> src exp) | |
169 | (case context | |
f4aa8d53 | 170 | ((push vals) (emit-code src (make-glil-const exp))) |
cf10678f AW |
171 | ((tail) |
172 | (emit-code src (make-glil-const exp)) | |
173 | (emit-code #f (make-glil-call 'return 1))))) | |
174 | ||
175 | ;; FIXME: should represent sequence as exps tail | |
176 | ((<sequence> src exps) | |
177 | (let lp ((exps exps)) | |
178 | (if (null? (cdr exps)) | |
179 | (comp-tail (car exps)) | |
180 | (begin | |
181 | (comp-drop (car exps)) | |
182 | (lp (cdr exps)))))) | |
183 | ||
184 | ((<application> src proc args) | |
dce042f1 | 185 | ;; FIXME: need a better pattern-matcher here |
112edbae | 186 | (cond |
dce042f1 AW |
187 | ((and (primitive-ref? proc) |
188 | (eq? (primitive-ref-name proc) '@apply) | |
0f423f20 | 189 | (>= (length args) 1)) |
dce042f1 AW |
190 | (let ((proc (car args)) |
191 | (args (cdr args))) | |
192 | (cond | |
193 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) | |
f4aa8d53 | 194 | (not (eq? context 'push)) (not (eq? context 'vals))) |
dce042f1 AW |
195 | ;; tail: (lambda () (apply values '(1 2))) |
196 | ;; drop: (lambda () (apply values '(1 2)) 3) | |
197 | ;; push: (lambda () (list (apply values '(10 12)) 1)) | |
198 | (case context | |
199 | ((drop) (for-each comp-drop args)) | |
200 | ((tail) | |
201 | (for-each comp-push args) | |
202 | (emit-code src (make-glil-call 'return/values* (length args)))))) | |
203 | ||
204 | (else | |
dce042f1 | 205 | (case context |
0f423f20 AW |
206 | ((tail) |
207 | (comp-push proc) | |
208 | (for-each comp-push args) | |
209 | (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) | |
210 | ((push) | |
211 | (comp-push proc) | |
212 | (for-each comp-push args) | |
213 | (emit-code src (make-glil-call 'apply (1+ (length args))))) | |
f4aa8d53 AW |
214 | ((vals) |
215 | (comp-vals | |
216 | (make-application src (make-primitive-ref #f 'apply) | |
217 | (cons proc args)) | |
218 | LMVRA)) | |
0f423f20 AW |
219 | ((drop) |
220 | ;; Well, shit. The proc might return any number of | |
221 | ;; values (including 0), since it's in a drop context, | |
222 | ;; yet apply does not create a MV continuation. So we | |
223 | ;; mv-call out to our trampoline instead. | |
224 | (comp-drop | |
225 | (make-application src (make-primitive-ref #f 'apply) | |
226 | (cons proc args))))))))) | |
dce042f1 | 227 | |
a1a482e0 AW |
228 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) |
229 | (not (eq? context 'push))) | |
230 | ;; tail: (lambda () (values '(1 2))) | |
231 | ;; drop: (lambda () (values '(1 2)) 3) | |
232 | ;; push: (lambda () (list (values '(10 12)) 1)) | |
f4aa8d53 | 233 | ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) |
a1a482e0 AW |
234 | (case context |
235 | ((drop) (for-each comp-drop args)) | |
f4aa8d53 AW |
236 | ((vals) |
237 | (for-each comp-push args) | |
238 | (emit-code #f (make-glil-const (length args))) | |
239 | (emit-branch src 'br LMVRA)) | |
a1a482e0 AW |
240 | ((tail) |
241 | (for-each comp-push args) | |
242 | (emit-code src (make-glil-call 'return/values (length args)))))) | |
f4aa8d53 | 243 | |
dce042f1 AW |
244 | ((and (primitive-ref? proc) |
245 | (eq? (primitive-ref-name proc) '@call-with-values) | |
246 | (= (length args) 2)) | |
247 | ;; CONSUMER | |
248 | ;; PRODUCER | |
249 | ;; (mv-call MV) | |
250 | ;; ([tail]-call 1) | |
251 | ;; goto POST | |
252 | ;; MV: [tail-]call/nargs | |
253 | ;; POST: (maybe-drop) | |
f4aa8d53 AW |
254 | (case context |
255 | ((vals) | |
256 | ;; Fall back. | |
257 | (comp-vals | |
258 | (make-application src (make-primitive-ref #f 'call-with-values) | |
259 | args) | |
260 | LMVRA)) | |
261 | (else | |
262 | (let ((MV (make-label)) (POST (make-label)) | |
263 | (producer (car args)) (consumer (cadr args))) | |
264 | (comp-push consumer) | |
265 | (comp-push producer) | |
266 | (emit-code src (make-glil-mv-call 0 MV)) | |
267 | (case context | |
268 | ((tail) (emit-code src (make-glil-call 'goto/args 1))) | |
269 | (else (emit-code src (make-glil-call 'call 1)) | |
270 | (emit-branch #f 'br POST))) | |
271 | (emit-label MV) | |
272 | (case context | |
273 | ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) | |
274 | (else (emit-code src (make-glil-call 'call/nargs 0)) | |
275 | (emit-label POST) | |
276 | (if (eq? context 'drop) | |
277 | (emit-code #f (make-glil-call 'drop 1))))))))) | |
dce042f1 AW |
278 | |
279 | ((and (primitive-ref? proc) | |
280 | (eq? (primitive-ref-name proc) '@call-with-current-continuation) | |
e32a1792 | 281 | (= (length args) 1)) |
dce042f1 | 282 | (case context |
0f423f20 AW |
283 | ((tail) |
284 | (comp-push (car args)) | |
285 | (emit-code src (make-glil-call 'goto/cc 1))) | |
f4aa8d53 AW |
286 | ((vals) |
287 | (comp-vals | |
288 | (make-application | |
289 | src (make-primitive-ref #f 'call-with-current-continuation) | |
290 | args) | |
291 | LMVRA)) | |
0f423f20 AW |
292 | ((push) |
293 | (comp-push (car args)) | |
294 | (emit-code src (make-glil-call 'call/cc 1))) | |
295 | ((drop) | |
296 | ;; Crap. Just like `apply' in drop context. | |
297 | (comp-drop | |
298 | (make-application | |
299 | src (make-primitive-ref #f 'call-with-current-continuation) | |
300 | args))))) | |
dce042f1 | 301 | |
112edbae | 302 | ((and (primitive-ref? proc) |
c11f46af AW |
303 | (or (hash-ref *primcall-ops* |
304 | (cons (primitive-ref-name proc) (length args))) | |
305 | (hash-ref *primcall-ops* (primitive-ref-name proc)))) | |
112edbae AW |
306 | => (lambda (op) |
307 | (for-each comp-push args) | |
308 | (emit-code src (make-glil-call op (length args))) | |
309 | (case context | |
310 | ((tail) (emit-code #f (make-glil-call 'return 1))) | |
311 | ((drop) (emit-code #f (make-glil-call 'drop 1)))))) | |
f4aa8d53 | 312 | |
112edbae AW |
313 | (else |
314 | (comp-push proc) | |
315 | (for-each comp-push args) | |
dce042f1 AW |
316 | (let ((len (length args))) |
317 | (case context | |
318 | ((tail) (emit-code src (make-glil-call 'goto/args len))) | |
319 | ((push) (emit-code src (make-glil-call 'call len))) | |
f4aa8d53 | 320 | ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA))) |
30a5e062 | 321 | ((drop) |
0f423f20 | 322 | (let ((MV (make-label)) (POST (make-label))) |
30a5e062 | 323 | (emit-code src (make-glil-mv-call len MV)) |
0f423f20 AW |
324 | (emit-code #f (make-glil-call 'drop 1)) |
325 | (emit-branch #f 'br POST) | |
30a5e062 AW |
326 | (emit-label MV) |
327 | (emit-code #f (make-glil-mv-bind '() #f)) | |
0f423f20 AW |
328 | (emit-code #f (make-glil-unbind)) |
329 | (emit-label POST)))))))) | |
073bb617 AW |
330 | |
331 | ((<conditional> src test then else) | |
332 | ;; TEST | |
333 | ;; (br-if-not L1) | |
334 | ;; THEN | |
335 | ;; (br L2) | |
336 | ;; L1: ELSE | |
337 | ;; L2: | |
338 | (let ((L1 (make-label)) (L2 (make-label))) | |
339 | (comp-push test) | |
cf10678f | 340 | (emit-branch src 'br-if-not L1) |
073bb617 | 341 | (comp-tail then) |
cf10678f AW |
342 | (if (not (eq? context 'tail)) |
343 | (emit-branch #f 'br L2)) | |
344 | (emit-label L1) | |
073bb617 | 345 | (comp-tail else) |
cf10678f AW |
346 | (if (not (eq? context 'tail)) |
347 | (emit-label L2)))) | |
348 | ||
349 | ((<primitive-ref> src name) | |
a1a482e0 AW |
350 | (cond |
351 | ((eq? (module-variable (fluid-ref *comp-module*) name) | |
352 | (module-variable the-root-module name)) | |
353 | (case context | |
f4aa8d53 | 354 | ((push vals) |
a1a482e0 AW |
355 | (emit-code src (make-glil-toplevel 'ref name))) |
356 | ((tail) | |
357 | (emit-code src (make-glil-toplevel 'ref name)) | |
358 | (emit-code #f (make-glil-call 'return 1))))) | |
359 | (else | |
360 | (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) | |
361 | (case context | |
f4aa8d53 | 362 | ((push vals) |
a1a482e0 AW |
363 | (emit-code src (make-glil-module 'ref '(guile) name #f))) |
364 | ((tail) | |
365 | (emit-code src (make-glil-module 'ref '(guile) name #f)) | |
366 | (emit-code #f (make-glil-call 'return 1))))))) | |
cf10678f AW |
367 | |
368 | ((<lexical-ref> src name gensym) | |
369 | (case context | |
f4aa8d53 | 370 | ((push vals tail) |
cf10678f AW |
371 | (let ((loc (hashq-ref allocation gensym))) |
372 | (case (car loc) | |
373 | ((stack) | |
374 | (emit-code src (make-glil-local 'ref (cdr loc)))) | |
375 | ((heap) | |
376 | (emit-code src (make-glil-external | |
377 | 'ref (- level (cadr loc)) (cddr loc)))) | |
378 | (else (error "badness" x loc))) | |
379 | (if (eq? context 'tail) | |
380 | (emit-code #f (make-glil-call 'return 1))))))) | |
381 | ||
382 | ((<lexical-set> src name gensym exp) | |
383 | (comp-push exp) | |
384 | (let ((loc (hashq-ref allocation gensym))) | |
385 | (case (car loc) | |
386 | ((stack) | |
387 | (emit-code src (make-glil-local 'set (cdr loc)))) | |
388 | ((heap) | |
389 | (emit-code src (make-glil-external | |
390 | 'set (- level (cadr loc)) (cddr loc)))) | |
391 | (else (error "badness" x loc)))) | |
392 | (case context | |
f4aa8d53 | 393 | ((push vals) |
cf10678f AW |
394 | (emit-code #f (make-glil-void))) |
395 | ((tail) | |
396 | (emit-code #f (make-glil-void)) | |
397 | (emit-code #f (make-glil-call 'return 1))))) | |
398 | ||
399 | ((<module-ref> src mod name public?) | |
400 | (emit-code src (make-glil-module 'ref mod name public?)) | |
401 | (case context | |
402 | ((drop) (emit-code #f (make-glil-call 'drop 1))) | |
403 | ((tail) (emit-code #f (make-glil-call 'return 1))))) | |
404 | ||
405 | ((<module-set> src mod name public? exp) | |
406 | (comp-push exp) | |
407 | (emit-code src (make-glil-module 'set mod name public?)) | |
408 | (case context | |
f4aa8d53 | 409 | ((push vals) |
cf10678f AW |
410 | (emit-code #f (make-glil-void))) |
411 | ((tail) | |
412 | (emit-code #f (make-glil-void)) | |
413 | (emit-code #f (make-glil-call 'return 1))))) | |
414 | ||
415 | ((<toplevel-ref> src name) | |
416 | (emit-code src (make-glil-toplevel 'ref name)) | |
417 | (case context | |
418 | ((drop) (emit-code #f (make-glil-call 'drop 1))) | |
419 | ((tail) (emit-code #f (make-glil-call 'return 1))))) | |
420 | ||
421 | ((<toplevel-set> src name exp) | |
422 | (comp-push exp) | |
423 | (emit-code src (make-glil-toplevel 'set name)) | |
424 | (case context | |
f4aa8d53 | 425 | ((push vals) |
cf10678f AW |
426 | (emit-code #f (make-glil-void))) |
427 | ((tail) | |
428 | (emit-code #f (make-glil-void)) | |
429 | (emit-code #f (make-glil-call 'return 1))))) | |
430 | ||
431 | ((<toplevel-define> src name exp) | |
432 | (comp-push exp) | |
433 | (emit-code src (make-glil-toplevel 'define name)) | |
434 | (case context | |
f4aa8d53 | 435 | ((push vals) |
cf10678f AW |
436 | (emit-code #f (make-glil-void))) |
437 | ((tail) | |
438 | (emit-code #f (make-glil-void)) | |
439 | (emit-code #f (make-glil-call 'return 1))))) | |
440 | ||
441 | ((<lambda>) | |
442 | (case context | |
f4aa8d53 | 443 | ((push vals) |
cf10678f AW |
444 | (emit-code #f (flatten-lambda x level allocation))) |
445 | ((tail) | |
446 | (emit-code #f (flatten-lambda x level allocation)) | |
447 | (emit-code #f (make-glil-call 'return 1))))) | |
448 | ||
f4aa8d53 | 449 | ((<let> src names vars vals body) |
073bb617 | 450 | (for-each comp-push vals) |
2ce77f2d | 451 | (emit-bindings src names vars allocation emit-code) |
cf10678f AW |
452 | (for-each (lambda (v) |
453 | (let ((loc (hashq-ref allocation v))) | |
454 | (case (car loc) | |
455 | ((stack) | |
456 | (emit-code src (make-glil-local 'set (cdr loc)))) | |
457 | ((heap) | |
458 | (emit-code src (make-glil-external 'set 0 (cddr loc)))) | |
459 | (else (error "badness" x loc))))) | |
460 | (reverse vars)) | |
f4aa8d53 | 461 | (comp-tail body) |
cf10678f AW |
462 | (emit-code #f (make-glil-unbind))) |
463 | ||
f4aa8d53 | 464 | ((<letrec> src names vars vals body) |
cf10678f | 465 | (for-each comp-push vals) |
2ce77f2d | 466 | (emit-bindings src names vars allocation emit-code) |
cf10678f AW |
467 | (for-each (lambda (v) |
468 | (let ((loc (hashq-ref allocation v))) | |
469 | (case (car loc) | |
470 | ((stack) | |
471 | (emit-code src (make-glil-local 'set (cdr loc)))) | |
472 | ((heap) | |
473 | (emit-code src (make-glil-external 'set 0 (cddr loc)))) | |
474 | (else (error "badness" x loc))))) | |
475 | (reverse vars)) | |
f4aa8d53 AW |
476 | (comp-tail body) |
477 | (emit-code #f (make-glil-unbind))) | |
478 | ||
479 | ((<let-values> src names vars exp body) | |
480 | (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) | |
481 | (cond | |
482 | ((pair? inames) | |
483 | (lp (cons (car inames) names) (cons (car ivars) vars) | |
484 | (cdr inames) (cdr ivars) #f)) | |
485 | ((not (null? inames)) | |
486 | (lp (cons inames names) (cons ivars vars) '() '() #t)) | |
487 | (else | |
488 | (let ((names (reverse! names)) | |
489 | (vars (reverse! vars)) | |
490 | (MV (make-label))) | |
491 | (comp-vals exp MV) | |
492 | (emit-code #f (make-glil-const 1)) | |
493 | (emit-label MV) | |
494 | (emit-code src (make-glil-mv-bind | |
495 | (vars->bind-list names vars allocation) | |
496 | rest?)) | |
497 | (for-each (lambda (v) | |
498 | (let ((loc (hashq-ref allocation v))) | |
499 | (case (car loc) | |
500 | ((stack) | |
501 | (emit-code src (make-glil-local 'set (cdr loc)))) | |
502 | ((heap) | |
503 | (emit-code src (make-glil-external 'set 0 (cddr loc)))) | |
504 | (else (error "badness" x loc))))) | |
505 | (reverse vars)) | |
506 | (comp-tail body) | |
507 | (emit-code #f (make-glil-unbind)))))))))) |