Commit | Line | Data |
---|---|---|
811d10f5 AW |
1 | ;;; TREE-IL -> GLIL compiler |
2 | ||
b81d329e | 3 | ;; Copyright (C) 2001,2008,2009 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) |
811d10f5 AW |
31 | #:export (compile-glil)) |
32 | ||
1eec95f8 AW |
33 | ;;; TODO: |
34 | ;; | |
1eec95f8 | 35 | ;; call-with-values -> mv-bind |
1eec95f8 | 36 | ;; basic degenerate-case reduction |
1eec95f8 | 37 | |
073bb617 | 38 | ;; allocation: |
66d3e9a3 | 39 | ;; sym -> {lambda -> address} |
230cfcfb | 40 | ;; lambda -> (nlocs labels . free-locs) |
66d3e9a3 AW |
41 | ;; |
42 | ;; address := (local? boxed? . index) | |
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 |
f67ddf9d LC |
49 | `((unused-variable . ,report-unused-variables) |
50 | (unbound-variable . ,report-possibly-unbound-variables))) | |
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. |
aaae0d5a | 58 | (for-each (lambda (kind) |
4b856371 LC |
59 | (let ((warn (assoc-ref %warning-passes kind))) |
60 | (and (procedure? warn) | |
43eb8aca | 61 | (warn x e)))) |
aaae0d5a AW |
62 | warnings) |
63 | ||
64 | (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) | |
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) | |
96 | ((not . 1) . not) | |
97 | ((pair? . 1) . pair?) | |
98 | ((cons . 2) . cons) | |
99 | ((car . 1) . car) | |
100 | ((cdr . 1) . cdr) | |
101 | ((set-car! . 2) . set-car!) | |
102 | ((set-cdr! . 2) . set-cdr!) | |
103 | ((null? . 1) . null?) | |
c11f46af AW |
104 | ((list? . 1) . list?) |
105 | (list . list) | |
ad9b8c45 AW |
106 | (vector . vector) |
107 | ((@slot-ref . 2) . slot-ref) | |
d6f1ce3d AW |
108 | ((@slot-set! . 3) . slot-set) |
109 | ((vector-ref . 2) . vector-ref) | |
110 | ((vector-set! . 3) . vector-set) | |
39141c87 AW |
111 | |
112 | ((bytevector-u8-ref . 2) . bv-u8-ref) | |
113 | ((bytevector-u8-set! . 3) . bv-u8-set) | |
114 | ((bytevector-s8-ref . 2) . bv-s8-ref) | |
115 | ((bytevector-s8-set! . 3) . bv-s8-set) | |
116 | ||
117 | ((bytevector-u16-ref . 3) . bv-u16-ref) | |
118 | ((bytevector-u16-set! . 4) . bv-u16-set) | |
119 | ((bytevector-u16-native-ref . 2) . bv-u16-native-ref) | |
120 | ((bytevector-u16-native-set! . 3) . bv-u16-native-set) | |
121 | ((bytevector-s16-ref . 3) . bv-s16-ref) | |
122 | ((bytevector-s16-set! . 4) . bv-s16-set) | |
123 | ((bytevector-s16-native-ref . 2) . bv-s16-native-ref) | |
124 | ((bytevector-s16-native-set! . 3) . bv-s16-native-set) | |
125 | ||
126 | ((bytevector-u32-ref . 3) . bv-u32-ref) | |
127 | ((bytevector-u32-set! . 4) . bv-u32-set) | |
128 | ((bytevector-u32-native-ref . 2) . bv-u32-native-ref) | |
129 | ((bytevector-u32-native-set! . 3) . bv-u32-native-set) | |
130 | ((bytevector-s32-ref . 3) . bv-s32-ref) | |
131 | ((bytevector-s32-set! . 4) . bv-s32-set) | |
132 | ((bytevector-s32-native-ref . 2) . bv-s32-native-ref) | |
133 | ((bytevector-s32-native-set! . 3) . bv-s32-native-set) | |
134 | ||
135 | ((bytevector-u64-ref . 3) . bv-u64-ref) | |
136 | ((bytevector-u64-set! . 4) . bv-u64-set) | |
137 | ((bytevector-u64-native-ref . 2) . bv-u64-native-ref) | |
138 | ((bytevector-u64-native-set! . 3) . bv-u64-native-set) | |
139 | ((bytevector-s64-ref . 3) . bv-s64-ref) | |
140 | ((bytevector-s64-set! . 4) . bv-s64-set) | |
141 | ((bytevector-s64-native-ref . 2) . bv-s64-native-ref) | |
142 | ((bytevector-s64-native-set! . 3) . bv-s64-native-set) | |
143 | ||
144 | ((bytevector-ieee-single-ref . 3) . bv-f32-ref) | |
145 | ((bytevector-ieee-single-set! . 4) . bv-f32-set) | |
146 | ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref) | |
147 | ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set) | |
148 | ((bytevector-ieee-double-ref . 3) . bv-f64-ref) | |
149 | ((bytevector-ieee-double-set! . 4) . bv-f64-set) | |
150 | ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref) | |
151 | ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set))) | |
152 | ||
153 | ||
154 | \f | |
112edbae | 155 | |
811d10f5 AW |
156 | (define (make-label) (gensym ":L")) |
157 | ||
66d3e9a3 | 158 | (define (vars->bind-list ids vars allocation proc) |
2ce77f2d | 159 | (map (lambda (id v) |
66d3e9a3 AW |
160 | (pmatch (hashq-ref (hashq-ref allocation v) proc) |
161 | ((#t ,boxed? . ,n) | |
162 | (list id boxed? n)) | |
163 | (,x (error "badness" x)))) | |
2ce77f2d | 164 | ids |
cf10678f AW |
165 | vars)) |
166 | ||
230cfcfb | 167 | ;; FIXME: always emit? otherwise it's hard to pair bind with unbind |
66d3e9a3 | 168 | (define (emit-bindings src ids vars allocation proc emit-code) |
d97b69d9 AW |
169 | (emit-code src (make-glil-bind |
170 | (vars->bind-list ids vars allocation proc)))) | |
cf10678f AW |
171 | |
172 | (define (with-output-to-code proc) | |
173 | (let ((out '())) | |
174 | (define (emit-code src x) | |
175 | (set! out (cons x out)) | |
176 | (if src | |
177 | (set! out (cons (make-glil-source src) out)))) | |
178 | (proc emit-code) | |
179 | (reverse out))) | |
180 | ||
9b29d607 | 181 | (define (flatten-lambda x self-label allocation) |
2ce77f2d AW |
182 | (receive (ids vars nargs nrest) |
183 | (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) | |
184 | (oids '()) (ovars '()) (n 0)) | |
185 | (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) | |
186 | ((pair? vars) (lp (cdr ids) (cdr vars) | |
187 | (cons (car ids) oids) (cons (car vars) ovars) | |
188 | (1+ n))) | |
189 | (else (values (reverse (cons ids oids)) | |
190 | (reverse (cons vars ovars)) | |
191 | (1+ n) 1)))) | |
230cfcfb AW |
192 | (let ((nlocs (car (hashq-ref allocation x))) |
193 | (labels (cadr (hashq-ref allocation x)))) | |
cf10678f | 194 | (make-glil-program |
476e3572 | 195 | nargs nrest nlocs (lambda-meta x) |
cf10678f AW |
196 | (with-output-to-code |
197 | (lambda (emit-code) | |
9b29d607 AW |
198 | ;; emit label for self tail calls |
199 | (if self-label | |
200 | (emit-code #f (make-glil-label self-label))) | |
cf10678f | 201 | ;; write bindings and source debugging info |
d97b69d9 AW |
202 | (if (not (null? ids)) |
203 | (emit-bindings #f ids vars allocation x emit-code)) | |
cf10678f | 204 | (if (lambda-src x) |
e0c90f90 | 205 | (emit-code #f (make-glil-source (lambda-src x)))) |
66d3e9a3 AW |
206 | ;; box args if necessary |
207 | (for-each | |
208 | (lambda (v) | |
209 | (pmatch (hashq-ref (hashq-ref allocation v) x) | |
9b29d607 AW |
210 | ((#t #t . ,n) |
211 | (emit-code #f (make-glil-lexical #t #f 'ref n)) | |
212 | (emit-code #f (make-glil-lexical #t #t 'box n))))) | |
66d3e9a3 | 213 | vars) |
cf10678f | 214 | ;; and here, here, dear reader: we compile. |
230cfcfb AW |
215 | (flatten (lambda-body x) allocation x self-label |
216 | labels emit-code))))))) | |
cf10678f | 217 | |
230cfcfb | 218 | (define (flatten x allocation self self-label fix-labels emit-code) |
cf10678f AW |
219 | (define (emit-label label) |
220 | (emit-code #f (make-glil-label label))) | |
221 | (define (emit-branch src inst label) | |
222 | (emit-code src (make-glil-branch inst label))) | |
223 | ||
230cfcfb AW |
224 | ;; RA: "return address"; #f unless we're in a non-tail fix with labels |
225 | ;; MVRA: "multiple-values return address"; #f unless we're in a let-values | |
226 | (let comp ((x x) (context 'tail) (RA #f) (MVRA #f)) | |
227 | (define (comp-tail tree) (comp tree context RA MVRA)) | |
228 | (define (comp-push tree) (comp tree 'push #f #f)) | |
229 | (define (comp-drop tree) (comp tree 'drop #f #f)) | |
230 | (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) | |
231 | (define (comp-fix tree RA) (comp tree context RA MVRA)) | |
232 | ||
233 | ;; A couple of helpers. Note that if we are in tail context, we | |
234 | ;; won't have an RA. | |
235 | (define (maybe-emit-return) | |
236 | (if RA | |
237 | (emit-branch #f 'br RA) | |
238 | (if (eq? context 'tail) | |
239 | (emit-code #f (make-glil-call 'return 1))))) | |
240 | ||
cf10678f AW |
241 | (record-case x |
242 | ((<void>) | |
243 | (case context | |
230cfcfb AW |
244 | ((push vals tail) |
245 | (emit-code #f (make-glil-void)))) | |
246 | (maybe-emit-return)) | |
cf10678f AW |
247 | |
248 | ((<const> src exp) | |
249 | (case context | |
230cfcfb AW |
250 | ((push vals tail) |
251 | (emit-code src (make-glil-const exp)))) | |
252 | (maybe-emit-return)) | |
cf10678f AW |
253 | |
254 | ;; FIXME: should represent sequence as exps tail | |
e5f5113c | 255 | ((<sequence> exps) |
cf10678f AW |
256 | (let lp ((exps exps)) |
257 | (if (null? (cdr exps)) | |
258 | (comp-tail (car exps)) | |
259 | (begin | |
260 | (comp-drop (car exps)) | |
261 | (lp (cdr exps)))))) | |
262 | ||
263 | ((<application> src proc args) | |
dce042f1 | 264 | ;; FIXME: need a better pattern-matcher here |
112edbae | 265 | (cond |
dce042f1 AW |
266 | ((and (primitive-ref? proc) |
267 | (eq? (primitive-ref-name proc) '@apply) | |
0f423f20 | 268 | (>= (length args) 1)) |
dce042f1 AW |
269 | (let ((proc (car args)) |
270 | (args (cdr args))) | |
271 | (cond | |
272 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) | |
f4aa8d53 | 273 | (not (eq? context 'push)) (not (eq? context 'vals))) |
dce042f1 AW |
274 | ;; tail: (lambda () (apply values '(1 2))) |
275 | ;; drop: (lambda () (apply values '(1 2)) 3) | |
276 | ;; push: (lambda () (list (apply values '(10 12)) 1)) | |
277 | (case context | |
230cfcfb | 278 | ((drop) (for-each comp-drop args) (maybe-emit-return)) |
dce042f1 AW |
279 | ((tail) |
280 | (for-each comp-push args) | |
281 | (emit-code src (make-glil-call 'return/values* (length args)))))) | |
282 | ||
283 | (else | |
dce042f1 | 284 | (case context |
0f423f20 AW |
285 | ((tail) |
286 | (comp-push proc) | |
287 | (for-each comp-push args) | |
288 | (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) | |
289 | ((push) | |
b7946e9e | 290 | (emit-code src (make-glil-call 'new-frame 0)) |
0f423f20 AW |
291 | (comp-push proc) |
292 | (for-each comp-push args) | |
230cfcfb AW |
293 | (emit-code src (make-glil-call 'apply (1+ (length args)))) |
294 | (maybe-emit-return)) | |
f4aa8d53 AW |
295 | ((vals) |
296 | (comp-vals | |
297 | (make-application src (make-primitive-ref #f 'apply) | |
298 | (cons proc args)) | |
230cfcfb AW |
299 | MVRA) |
300 | (maybe-emit-return)) | |
0f423f20 AW |
301 | ((drop) |
302 | ;; Well, shit. The proc might return any number of | |
303 | ;; values (including 0), since it's in a drop context, | |
304 | ;; yet apply does not create a MV continuation. So we | |
305 | ;; mv-call out to our trampoline instead. | |
306 | (comp-drop | |
307 | (make-application src (make-primitive-ref #f 'apply) | |
230cfcfb AW |
308 | (cons proc args))) |
309 | (maybe-emit-return))))))) | |
310 | ||
a1a482e0 AW |
311 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) |
312 | (not (eq? context 'push))) | |
313 | ;; tail: (lambda () (values '(1 2))) | |
314 | ;; drop: (lambda () (values '(1 2)) 3) | |
315 | ;; push: (lambda () (list (values '(10 12)) 1)) | |
f4aa8d53 | 316 | ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) |
a1a482e0 | 317 | (case context |
230cfcfb | 318 | ((drop) (for-each comp-drop args) (maybe-emit-return)) |
f4aa8d53 AW |
319 | ((vals) |
320 | (for-each comp-push args) | |
321 | (emit-code #f (make-glil-const (length args))) | |
230cfcfb | 322 | (emit-branch src 'br MVRA)) |
a1a482e0 AW |
323 | ((tail) |
324 | (for-each comp-push args) | |
325 | (emit-code src (make-glil-call 'return/values (length args)))))) | |
f4aa8d53 | 326 | |
dce042f1 AW |
327 | ((and (primitive-ref? proc) |
328 | (eq? (primitive-ref-name proc) '@call-with-values) | |
329 | (= (length args) 2)) | |
330 | ;; CONSUMER | |
331 | ;; PRODUCER | |
332 | ;; (mv-call MV) | |
333 | ;; ([tail]-call 1) | |
334 | ;; goto POST | |
335 | ;; MV: [tail-]call/nargs | |
336 | ;; POST: (maybe-drop) | |
f4aa8d53 AW |
337 | (case context |
338 | ((vals) | |
339 | ;; Fall back. | |
340 | (comp-vals | |
341 | (make-application src (make-primitive-ref #f 'call-with-values) | |
342 | args) | |
230cfcfb AW |
343 | MVRA) |
344 | (maybe-emit-return)) | |
f4aa8d53 AW |
345 | (else |
346 | (let ((MV (make-label)) (POST (make-label)) | |
347 | (producer (car args)) (consumer (cadr args))) | |
b7946e9e AW |
348 | (if (not (eq? context 'tail)) |
349 | (emit-code src (make-glil-call 'new-frame 0))) | |
f4aa8d53 | 350 | (comp-push consumer) |
b7946e9e | 351 | (emit-code src (make-glil-call 'new-frame 0)) |
f4aa8d53 AW |
352 | (comp-push producer) |
353 | (emit-code src (make-glil-mv-call 0 MV)) | |
354 | (case context | |
355 | ((tail) (emit-code src (make-glil-call 'goto/args 1))) | |
356 | (else (emit-code src (make-glil-call 'call 1)) | |
357 | (emit-branch #f 'br POST))) | |
358 | (emit-label MV) | |
359 | (case context | |
360 | ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) | |
361 | (else (emit-code src (make-glil-call 'call/nargs 0)) | |
362 | (emit-label POST) | |
363 | (if (eq? context 'drop) | |
230cfcfb AW |
364 | (emit-code #f (make-glil-call 'drop 1))) |
365 | (maybe-emit-return))))))) | |
dce042f1 AW |
366 | |
367 | ((and (primitive-ref? proc) | |
368 | (eq? (primitive-ref-name proc) '@call-with-current-continuation) | |
e32a1792 | 369 | (= (length args) 1)) |
dce042f1 | 370 | (case context |
0f423f20 AW |
371 | ((tail) |
372 | (comp-push (car args)) | |
373 | (emit-code src (make-glil-call 'goto/cc 1))) | |
f4aa8d53 AW |
374 | ((vals) |
375 | (comp-vals | |
376 | (make-application | |
377 | src (make-primitive-ref #f 'call-with-current-continuation) | |
378 | args) | |
230cfcfb AW |
379 | MVRA) |
380 | (maybe-emit-return)) | |
0f423f20 AW |
381 | ((push) |
382 | (comp-push (car args)) | |
230cfcfb AW |
383 | (emit-code src (make-glil-call 'call/cc 1)) |
384 | (maybe-emit-return)) | |
0f423f20 AW |
385 | ((drop) |
386 | ;; Crap. Just like `apply' in drop context. | |
387 | (comp-drop | |
388 | (make-application | |
389 | src (make-primitive-ref #f 'call-with-current-continuation) | |
230cfcfb AW |
390 | args)) |
391 | (maybe-emit-return)))) | |
dce042f1 | 392 | |
112edbae | 393 | ((and (primitive-ref? proc) |
c11f46af AW |
394 | (or (hash-ref *primcall-ops* |
395 | (cons (primitive-ref-name proc) (length args))) | |
396 | (hash-ref *primcall-ops* (primitive-ref-name proc)))) | |
112edbae AW |
397 | => (lambda (op) |
398 | (for-each comp-push args) | |
399 | (emit-code src (make-glil-call op (length args))) | |
60ed31d2 AW |
400 | (case (instruction-pushes op) |
401 | ((0) | |
402 | (case context | |
230cfcfb AW |
403 | ((tail push vals) (emit-code #f (make-glil-void)))) |
404 | (maybe-emit-return)) | |
60ed31d2 AW |
405 | ((1) |
406 | (case context | |
230cfcfb AW |
407 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
408 | (maybe-emit-return)) | |
60ed31d2 AW |
409 | (else |
410 | (error "bad primitive op: too many pushes" | |
411 | op (instruction-pushes op)))))) | |
412 | ||
9b29d607 AW |
413 | ;; da capo al fine |
414 | ((and (lexical-ref? proc) | |
415 | self-label (eq? (lexical-ref-gensym proc) self-label) | |
416 | ;; self-call in tail position is a goto | |
417 | (eq? context 'tail) | |
418 | ;; make sure the arity is right | |
419 | (list? (lambda-vars self)) | |
420 | (= (length args) (length (lambda-vars self)))) | |
421 | ;; evaluate new values | |
422 | (for-each comp-push args) | |
423 | ;; rename & goto | |
424 | (for-each (lambda (sym) | |
425 | (pmatch (hashq-ref (hashq-ref allocation sym) self) | |
d773ba23 | 426 | ((#t ,boxed? . ,index) |
230cfcfb | 427 | ;; set unboxed, as the proc prelude will box if needed |
9b29d607 AW |
428 | (emit-code #f (make-glil-lexical #t #f 'set index))) |
429 | (,x (error "what" x)))) | |
430 | (reverse (lambda-vars self))) | |
431 | (emit-branch src 'br self-label)) | |
432 | ||
230cfcfb AW |
433 | ;; lambda, the ultimate goto |
434 | ((and (lexical-ref? proc) | |
435 | (assq (lexical-ref-gensym proc) fix-labels)) | |
436 | ;; evaluate new values, assuming that analyze-lexicals did its | |
437 | ;; job, and that the arity was right | |
438 | (for-each comp-push args) | |
439 | ;; rename | |
440 | (for-each (lambda (sym) | |
441 | (pmatch (hashq-ref (hashq-ref allocation sym) self) | |
442 | ((#t #f . ,index) | |
443 | (emit-code #f (make-glil-lexical #t #f 'set index))) | |
444 | ((#t #t . ,index) | |
445 | (emit-code #f (make-glil-lexical #t #t 'box index))) | |
446 | (,x (error "what" x)))) | |
447 | (reverse (assq-ref fix-labels (lexical-ref-gensym proc)))) | |
448 | ;; goto! | |
449 | (emit-branch src 'br (lexical-ref-gensym proc))) | |
450 | ||
112edbae | 451 | (else |
b7946e9e AW |
452 | (if (not (eq? context 'tail)) |
453 | (emit-code src (make-glil-call 'new-frame 0))) | |
112edbae AW |
454 | (comp-push proc) |
455 | (for-each comp-push args) | |
dce042f1 AW |
456 | (let ((len (length args))) |
457 | (case context | |
458 | ((tail) (emit-code src (make-glil-call 'goto/args len))) | |
230cfcfb AW |
459 | ((push) (emit-code src (make-glil-call 'call len)) |
460 | (maybe-emit-return)) | |
461 | ((vals) (emit-code src (make-glil-mv-call len MVRA)) | |
462 | (maybe-emit-return)) | |
463 | ((drop) (let ((MV (make-label)) (POST (make-label))) | |
464 | (emit-code src (make-glil-mv-call len MV)) | |
465 | (emit-code #f (make-glil-call 'drop 1)) | |
466 | (emit-branch #f 'br (or RA POST)) | |
467 | (emit-label MV) | |
468 | (emit-code #f (make-glil-mv-bind '() #f)) | |
469 | (emit-code #f (make-glil-unbind)) | |
470 | (if RA | |
471 | (emit-branch #f 'br RA) | |
472 | (emit-label POST))))))))) | |
073bb617 AW |
473 | |
474 | ((<conditional> src test then else) | |
475 | ;; TEST | |
476 | ;; (br-if-not L1) | |
477 | ;; THEN | |
478 | ;; (br L2) | |
479 | ;; L1: ELSE | |
480 | ;; L2: | |
481 | (let ((L1 (make-label)) (L2 (make-label))) | |
482 | (comp-push test) | |
cf10678f | 483 | (emit-branch src 'br-if-not L1) |
073bb617 | 484 | (comp-tail then) |
d97b69d9 AW |
485 | ;; if there is an RA, comp-tail will cause a jump to it -- just |
486 | ;; have to clean up here if there is no RA. | |
487 | (if (and (not RA) (not (eq? context 'tail))) | |
488 | (emit-branch #f 'br L2)) | |
cf10678f | 489 | (emit-label L1) |
073bb617 | 490 | (comp-tail else) |
d97b69d9 AW |
491 | (if (and (not RA) (not (eq? context 'tail))) |
492 | (emit-label L2)))) | |
493 | ||
cf10678f | 494 | ((<primitive-ref> src name) |
a1a482e0 AW |
495 | (cond |
496 | ((eq? (module-variable (fluid-ref *comp-module*) name) | |
497 | (module-variable the-root-module name)) | |
498 | (case context | |
230cfcfb AW |
499 | ((tail push vals) |
500 | (emit-code src (make-glil-toplevel 'ref name)))) | |
501 | (maybe-emit-return)) | |
94ff26b9 | 502 | ((module-variable the-root-module name) |
a1a482e0 | 503 | (case context |
230cfcfb AW |
504 | ((tail push vals) |
505 | (emit-code src (make-glil-module 'ref '(guile) name #f)))) | |
94ff26b9 AW |
506 | (maybe-emit-return)) |
507 | (else | |
508 | (case context | |
509 | ((tail push vals) | |
510 | (emit-code src (make-glil-module | |
511 | 'ref (module-name (fluid-ref *comp-module*)) name #f)))) | |
230cfcfb | 512 | (maybe-emit-return)))) |
cf10678f | 513 | |
e5f5113c | 514 | ((<lexical-ref> src gensym) |
cf10678f | 515 | (case context |
f4aa8d53 | 516 | ((push vals tail) |
9b29d607 | 517 | (pmatch (hashq-ref (hashq-ref allocation gensym) self) |
66d3e9a3 AW |
518 | ((,local? ,boxed? . ,index) |
519 | (emit-code src (make-glil-lexical local? boxed? 'ref index))) | |
520 | (,loc | |
521 | (error "badness" x loc))))) | |
230cfcfb | 522 | (maybe-emit-return)) |
66d3e9a3 | 523 | |
e5f5113c | 524 | ((<lexical-set> src gensym exp) |
cf10678f | 525 | (comp-push exp) |
9b29d607 | 526 | (pmatch (hashq-ref (hashq-ref allocation gensym) self) |
66d3e9a3 AW |
527 | ((,local? ,boxed? . ,index) |
528 | (emit-code src (make-glil-lexical local? boxed? 'set index))) | |
529 | (,loc | |
530 | (error "badness" x loc))) | |
cf10678f | 531 | (case context |
230cfcfb AW |
532 | ((tail push vals) |
533 | (emit-code #f (make-glil-void)))) | |
534 | (maybe-emit-return)) | |
cf10678f AW |
535 | |
536 | ((<module-ref> src mod name public?) | |
537 | (emit-code src (make-glil-module 'ref mod name public?)) | |
538 | (case context | |
230cfcfb AW |
539 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
540 | (maybe-emit-return)) | |
cf10678f AW |
541 | |
542 | ((<module-set> src mod name public? exp) | |
543 | (comp-push exp) | |
544 | (emit-code src (make-glil-module 'set mod name public?)) | |
545 | (case context | |
230cfcfb AW |
546 | ((tail push vals) |
547 | (emit-code #f (make-glil-void)))) | |
548 | (maybe-emit-return)) | |
cf10678f AW |
549 | |
550 | ((<toplevel-ref> src name) | |
551 | (emit-code src (make-glil-toplevel 'ref name)) | |
552 | (case context | |
230cfcfb AW |
553 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
554 | (maybe-emit-return)) | |
cf10678f AW |
555 | |
556 | ((<toplevel-set> src name exp) | |
557 | (comp-push exp) | |
558 | (emit-code src (make-glil-toplevel 'set name)) | |
559 | (case context | |
230cfcfb AW |
560 | ((tail push vals) |
561 | (emit-code #f (make-glil-void)))) | |
562 | (maybe-emit-return)) | |
cf10678f AW |
563 | |
564 | ((<toplevel-define> src name exp) | |
565 | (comp-push exp) | |
566 | (emit-code src (make-glil-toplevel 'define name)) | |
567 | (case context | |
230cfcfb AW |
568 | ((tail push vals) |
569 | (emit-code #f (make-glil-void)))) | |
570 | (maybe-emit-return)) | |
cf10678f AW |
571 | |
572 | ((<lambda>) | |
9059993f | 573 | (let ((free-locs (cddr (hashq-ref allocation x)))) |
66d3e9a3 AW |
574 | (case context |
575 | ((push vals tail) | |
9b29d607 | 576 | (emit-code #f (flatten-lambda x #f allocation)) |
66d3e9a3 AW |
577 | (if (not (null? free-locs)) |
578 | (begin | |
579 | (for-each | |
580 | (lambda (loc) | |
581 | (pmatch loc | |
d773ba23 | 582 | ((,local? ,boxed? . ,n) |
66d3e9a3 AW |
583 | (emit-code #f (make-glil-lexical local? #f 'ref n))) |
584 | (else (error "what" x loc)))) | |
585 | free-locs) | |
586 | (emit-code #f (make-glil-call 'vector (length free-locs))) | |
230cfcfb AW |
587 | (emit-code #f (make-glil-call 'make-closure 2))))))) |
588 | (maybe-emit-return)) | |
66d3e9a3 | 589 | |
f4aa8d53 | 590 | ((<let> src names vars vals body) |
073bb617 | 591 | (for-each comp-push vals) |
9b29d607 | 592 | (emit-bindings src names vars allocation self emit-code) |
cf10678f | 593 | (for-each (lambda (v) |
9b29d607 | 594 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
595 | ((#t #f . ,n) |
596 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
597 | ((#t #t . ,n) | |
598 | (emit-code src (make-glil-lexical #t #t 'box n))) | |
599 | (,loc (error "badness" x loc)))) | |
cf10678f | 600 | (reverse vars)) |
f4aa8d53 | 601 | (comp-tail body) |
cf10678f AW |
602 | (emit-code #f (make-glil-unbind))) |
603 | ||
f4aa8d53 | 604 | ((<letrec> src names vars vals body) |
66d3e9a3 | 605 | (for-each (lambda (v) |
9b29d607 | 606 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
607 | ((#t #t . ,n) |
608 | (emit-code src (make-glil-lexical #t #t 'empty-box n))) | |
609 | (,loc (error "badness" x loc)))) | |
610 | vars) | |
cf10678f | 611 | (for-each comp-push vals) |
9b29d607 | 612 | (emit-bindings src names vars allocation self emit-code) |
cf10678f | 613 | (for-each (lambda (v) |
9b29d607 | 614 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
615 | ((#t #t . ,n) |
616 | (emit-code src (make-glil-lexical #t #t 'set n))) | |
617 | (,loc (error "badness" x loc)))) | |
cf10678f | 618 | (reverse vars)) |
f4aa8d53 AW |
619 | (comp-tail body) |
620 | (emit-code #f (make-glil-unbind))) | |
621 | ||
c21c89b1 | 622 | ((<fix> src names vars vals body) |
230cfcfb AW |
623 | ;; The ideal here is to just render the lambda bodies inline, and |
624 | ;; wire the code together with gotos. We can do that if | |
625 | ;; analyze-lexicals has determined that a given var has "label" | |
626 | ;; allocation -- which is the case if it is in `fix-labels'. | |
627 | ;; | |
628 | ;; But even for closures that we can't inline, we can do some | |
629 | ;; tricks to avoid heap-allocation for the binding itself. Since | |
630 | ;; we know the vals are lambdas, we can set them to their local | |
631 | ;; var slots first, then capture their bindings, mutating them in | |
632 | ;; place. | |
7f7b85cb | 633 | (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label)))) |
230cfcfb AW |
634 | (for-each |
635 | (lambda (x v) | |
636 | (cond | |
637 | ((hashq-ref allocation x) | |
638 | ;; allocating a closure | |
639 | (emit-code #f (flatten-lambda x v allocation)) | |
640 | (if (not (null? (cddr (hashq-ref allocation x)))) | |
641 | ;; Need to make-closure first, but with a temporary #f | |
642 | ;; free-variables vector, so we are mutating fresh | |
643 | ;; closures on the heap. | |
644 | (begin | |
645 | (emit-code #f (make-glil-const #f)) | |
646 | (emit-code #f (make-glil-call 'make-closure 2)))) | |
647 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
648 | ((#t #f . ,n) | |
649 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
650 | (,loc (error "badness" x loc)))) | |
651 | (else | |
652 | ;; labels allocation: emit label & body, but jump over it | |
653 | (let ((POST (make-label))) | |
654 | (emit-branch #f 'br POST) | |
655 | (emit-label v) | |
656 | ;; we know the lambda vars are a list | |
657 | (emit-bindings #f (lambda-names x) (lambda-vars x) | |
658 | allocation self emit-code) | |
659 | (if (lambda-src x) | |
660 | (emit-code #f (make-glil-source (lambda-src x)))) | |
7f7b85cb | 661 | (comp-fix (lambda-body x) (or RA new-RA)) |
230cfcfb AW |
662 | (emit-code #f (make-glil-unbind)) |
663 | (emit-label POST))))) | |
664 | vals | |
665 | vars) | |
666 | ;; Emit bindings metadata for closures | |
667 | (let ((binds (let lp ((out '()) (vars vars) (names names)) | |
668 | (cond ((null? vars) (reverse! out)) | |
d97b69d9 | 669 | ((assq (car vars) fix-labels) |
230cfcfb AW |
670 | (lp out (cdr vars) (cdr names))) |
671 | (else | |
672 | (lp (acons (car vars) (car names) out) | |
673 | (cdr vars) (cdr names))))))) | |
674 | (emit-bindings src (map cdr binds) (map car binds) | |
675 | allocation self emit-code)) | |
676 | ;; Now go back and fix up the bindings for closures. | |
677 | (for-each | |
678 | (lambda (x v) | |
679 | (let ((free-locs (if (hashq-ref allocation x) | |
680 | (cddr (hashq-ref allocation x)) | |
681 | ;; can hit this latter case for labels allocation | |
682 | '()))) | |
683 | (if (not (null? free-locs)) | |
684 | (begin | |
685 | (for-each | |
686 | (lambda (loc) | |
687 | (pmatch loc | |
d773ba23 | 688 | ((,local? ,boxed? . ,n) |
230cfcfb AW |
689 | (emit-code #f (make-glil-lexical local? #f 'ref n))) |
690 | (else (error "what" x loc)))) | |
691 | free-locs) | |
692 | (emit-code #f (make-glil-call 'vector (length free-locs))) | |
693 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
694 | ((#t #f . ,n) | |
695 | (emit-code #f (make-glil-lexical #t #f 'fix n))) | |
696 | (,loc (error "badness" x loc))))))) | |
697 | vals | |
698 | vars) | |
699 | (comp-tail body) | |
7f7b85cb AW |
700 | (if new-RA |
701 | (emit-label new-RA)) | |
230cfcfb | 702 | (emit-code #f (make-glil-unbind)))) |
c21c89b1 | 703 | |
f4aa8d53 AW |
704 | ((<let-values> src names vars exp body) |
705 | (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) | |
706 | (cond | |
707 | ((pair? inames) | |
708 | (lp (cons (car inames) names) (cons (car ivars) vars) | |
709 | (cdr inames) (cdr ivars) #f)) | |
710 | ((not (null? inames)) | |
711 | (lp (cons inames names) (cons ivars vars) '() '() #t)) | |
712 | (else | |
713 | (let ((names (reverse! names)) | |
714 | (vars (reverse! vars)) | |
715 | (MV (make-label))) | |
716 | (comp-vals exp MV) | |
717 | (emit-code #f (make-glil-const 1)) | |
718 | (emit-label MV) | |
719 | (emit-code src (make-glil-mv-bind | |
9b29d607 | 720 | (vars->bind-list names vars allocation self) |
f4aa8d53 AW |
721 | rest?)) |
722 | (for-each (lambda (v) | |
9b29d607 | 723 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
724 | ((#t #f . ,n) |
725 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
726 | ((#t #t . ,n) | |
727 | (emit-code src (make-glil-lexical #t #t 'box n))) | |
728 | (,loc (error "badness" x loc)))) | |
f4aa8d53 AW |
729 | (reverse vars)) |
730 | (comp-tail body) | |
731 | (emit-code #f (make-glil-unbind)))))))))) |