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) |
48b1db75 | 31 | #:use-module ((srfi srfi-1) #:select (filter-map)) |
811d10f5 AW |
32 | #:export (compile-glil)) |
33 | ||
073bb617 | 34 | ;; allocation: |
66d3e9a3 | 35 | ;; sym -> {lambda -> address} |
8a4ca0ea AW |
36 | ;; lambda -> (labels . free-locs) |
37 | ;; lambda-case -> (gensym . nlocs) | |
66d3e9a3 | 38 | ;; |
8a4ca0ea AW |
39 | ;; address ::= (local? boxed? . index) |
40 | ;; labels ::= ((sym . lambda) ...) | |
66d3e9a3 AW |
41 | ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) |
42 | ;; free variable addresses are relative to parent proc. | |
073bb617 | 43 | |
a1a482e0 AW |
44 | (define *comp-module* (make-fluid)) |
45 | ||
4b856371 | 46 | (define %warning-passes |
48b1db75 | 47 | `((unused-variable . ,unused-variable-analysis) |
ae03cf1f LC |
48 | (unbound-variable . ,unbound-variable-analysis) |
49 | (arity-mismatch . ,arity-analysis))) | |
4b856371 | 50 | |
811d10f5 | 51 | (define (compile-glil x e opts) |
4b856371 LC |
52 | (define warnings |
53 | (or (and=> (memq #:warnings opts) cadr) | |
54 | '())) | |
55 | ||
43eb8aca | 56 | ;; Go through the warning passes. |
48b1db75 LC |
57 | (let ((analyses (filter-map (lambda (kind) |
58 | (assoc-ref %warning-passes kind)) | |
59 | warnings))) | |
60 | (analyze-tree analyses x e)) | |
aaae0d5a | 61 | |
8a4ca0ea | 62 | (let* ((x (make-lambda (tree-il-src x) '() |
1e2a8edb | 63 | (make-lambda-case #f '() #f #f #f '() '() x #f))) |
aaae0d5a AW |
64 | (x (optimize! x e opts)) |
65 | (allocation (analyze-lexicals x))) | |
4b856371 | 66 | |
f95f82f8 | 67 | (with-fluid* *comp-module* e |
a1a482e0 | 68 | (lambda () |
9b29d607 | 69 | (values (flatten-lambda x #f allocation) |
f95f82f8 | 70 | e |
a1a482e0 | 71 | e))))) |
811d10f5 AW |
72 | |
73 | \f | |
811d10f5 | 74 | |
112edbae AW |
75 | (define *primcall-ops* (make-hash-table)) |
76 | (for-each | |
77 | (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) | |
78 | '(((eq? . 2) . eq?) | |
79 | ((eqv? . 2) . eqv?) | |
80 | ((equal? . 2) . equal?) | |
81 | ((= . 2) . ee?) | |
82 | ((< . 2) . lt?) | |
83 | ((> . 2) . gt?) | |
84 | ((<= . 2) . le?) | |
85 | ((>= . 2) . ge?) | |
86 | ((+ . 2) . add) | |
87 | ((- . 2) . sub) | |
7382f23e AW |
88 | ((1+ . 1) . add1) |
89 | ((1- . 1) . sub1) | |
112edbae AW |
90 | ((* . 2) . mul) |
91 | ((/ . 2) . div) | |
92 | ((quotient . 2) . quo) | |
93 | ((remainder . 2) . rem) | |
94 | ((modulo . 2) . mod) | |
b10d9330 AW |
95 | ((ash . 2) . ash) |
96 | ((logand . 2) . logand) | |
97 | ((logior . 2) . logior) | |
98 | ((logxor . 2) . logxor) | |
112edbae AW |
99 | ((not . 1) . not) |
100 | ((pair? . 1) . pair?) | |
101 | ((cons . 2) . cons) | |
102 | ((car . 1) . car) | |
103 | ((cdr . 1) . cdr) | |
104 | ((set-car! . 2) . set-car!) | |
105 | ((set-cdr! . 2) . set-cdr!) | |
106 | ((null? . 1) . null?) | |
c11f46af AW |
107 | ((list? . 1) . list?) |
108 | (list . list) | |
ad9b8c45 | 109 | (vector . vector) |
aec4a84a | 110 | ((class-of . 1) . class-of) |
ad9b8c45 | 111 | ((@slot-ref . 2) . slot-ref) |
d6f1ce3d AW |
112 | ((@slot-set! . 3) . slot-set) |
113 | ((vector-ref . 2) . vector-ref) | |
114 | ((vector-set! . 3) . vector-set) | |
39141c87 | 115 | |
d61e866c AW |
116 | ;; hack for javascript |
117 | ((return . 1) return) | |
118 | ||
39141c87 AW |
119 | ((bytevector-u8-ref . 2) . bv-u8-ref) |
120 | ((bytevector-u8-set! . 3) . bv-u8-set) | |
121 | ((bytevector-s8-ref . 2) . bv-s8-ref) | |
122 | ((bytevector-s8-set! . 3) . bv-s8-set) | |
123 | ||
124 | ((bytevector-u16-ref . 3) . bv-u16-ref) | |
125 | ((bytevector-u16-set! . 4) . bv-u16-set) | |
126 | ((bytevector-u16-native-ref . 2) . bv-u16-native-ref) | |
127 | ((bytevector-u16-native-set! . 3) . bv-u16-native-set) | |
128 | ((bytevector-s16-ref . 3) . bv-s16-ref) | |
129 | ((bytevector-s16-set! . 4) . bv-s16-set) | |
130 | ((bytevector-s16-native-ref . 2) . bv-s16-native-ref) | |
131 | ((bytevector-s16-native-set! . 3) . bv-s16-native-set) | |
132 | ||
133 | ((bytevector-u32-ref . 3) . bv-u32-ref) | |
134 | ((bytevector-u32-set! . 4) . bv-u32-set) | |
135 | ((bytevector-u32-native-ref . 2) . bv-u32-native-ref) | |
136 | ((bytevector-u32-native-set! . 3) . bv-u32-native-set) | |
137 | ((bytevector-s32-ref . 3) . bv-s32-ref) | |
138 | ((bytevector-s32-set! . 4) . bv-s32-set) | |
139 | ((bytevector-s32-native-ref . 2) . bv-s32-native-ref) | |
140 | ((bytevector-s32-native-set! . 3) . bv-s32-native-set) | |
141 | ||
142 | ((bytevector-u64-ref . 3) . bv-u64-ref) | |
143 | ((bytevector-u64-set! . 4) . bv-u64-set) | |
144 | ((bytevector-u64-native-ref . 2) . bv-u64-native-ref) | |
145 | ((bytevector-u64-native-set! . 3) . bv-u64-native-set) | |
146 | ((bytevector-s64-ref . 3) . bv-s64-ref) | |
147 | ((bytevector-s64-set! . 4) . bv-s64-set) | |
148 | ((bytevector-s64-native-ref . 2) . bv-s64-native-ref) | |
149 | ((bytevector-s64-native-set! . 3) . bv-s64-native-set) | |
150 | ||
151 | ((bytevector-ieee-single-ref . 3) . bv-f32-ref) | |
152 | ((bytevector-ieee-single-set! . 4) . bv-f32-set) | |
153 | ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref) | |
154 | ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set) | |
155 | ((bytevector-ieee-double-ref . 3) . bv-f64-ref) | |
156 | ((bytevector-ieee-double-set! . 4) . bv-f64-set) | |
157 | ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref) | |
158 | ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set))) | |
159 | ||
160 | ||
161 | \f | |
112edbae | 162 | |
811d10f5 AW |
163 | (define (make-label) (gensym ":L")) |
164 | ||
66d3e9a3 | 165 | (define (vars->bind-list ids vars allocation proc) |
2ce77f2d | 166 | (map (lambda (id v) |
66d3e9a3 AW |
167 | (pmatch (hashq-ref (hashq-ref allocation v) proc) |
168 | ((#t ,boxed? . ,n) | |
169 | (list id boxed? n)) | |
170 | (,x (error "badness" x)))) | |
2ce77f2d | 171 | ids |
cf10678f AW |
172 | vars)) |
173 | ||
66d3e9a3 | 174 | (define (emit-bindings src ids vars allocation proc emit-code) |
d97b69d9 AW |
175 | (emit-code src (make-glil-bind |
176 | (vars->bind-list ids vars allocation proc)))) | |
cf10678f AW |
177 | |
178 | (define (with-output-to-code proc) | |
179 | (let ((out '())) | |
180 | (define (emit-code src x) | |
181 | (set! out (cons x out)) | |
182 | (if src | |
183 | (set! out (cons (make-glil-source src) out)))) | |
184 | (proc emit-code) | |
185 | (reverse out))) | |
186 | ||
9b29d607 | 187 | (define (flatten-lambda x self-label allocation) |
8a4ca0ea AW |
188 | (record-case x |
189 | ((<lambda> src meta body) | |
190 | (make-glil-program | |
191 | meta | |
192 | (with-output-to-code | |
193 | (lambda (emit-code) | |
194 | ;; write source info for proc | |
195 | (if src (emit-code #f (make-glil-source src))) | |
196 | ;; emit pre-prelude label for self tail calls in which the | |
197 | ;; number of arguments doesn't check out at compile time | |
198 | (if self-label | |
199 | (emit-code #f (make-glil-label self-label))) | |
200 | ;; compile the body, yo | |
201 | (flatten body allocation x self-label (car (hashq-ref allocation x)) | |
202 | emit-code))))))) | |
cf10678f | 203 | |
230cfcfb | 204 | (define (flatten x allocation self self-label fix-labels emit-code) |
cf10678f AW |
205 | (define (emit-label label) |
206 | (emit-code #f (make-glil-label label))) | |
207 | (define (emit-branch src inst label) | |
208 | (emit-code src (make-glil-branch inst label))) | |
209 | ||
230cfcfb AW |
210 | ;; RA: "return address"; #f unless we're in a non-tail fix with labels |
211 | ;; MVRA: "multiple-values return address"; #f unless we're in a let-values | |
212 | (let comp ((x x) (context 'tail) (RA #f) (MVRA #f)) | |
213 | (define (comp-tail tree) (comp tree context RA MVRA)) | |
214 | (define (comp-push tree) (comp tree 'push #f #f)) | |
215 | (define (comp-drop tree) (comp tree 'drop #f #f)) | |
216 | (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) | |
217 | (define (comp-fix tree RA) (comp tree context RA MVRA)) | |
218 | ||
219 | ;; A couple of helpers. Note that if we are in tail context, we | |
220 | ;; won't have an RA. | |
221 | (define (maybe-emit-return) | |
222 | (if RA | |
223 | (emit-branch #f 'br RA) | |
224 | (if (eq? context 'tail) | |
225 | (emit-code #f (make-glil-call 'return 1))))) | |
226 | ||
cf10678f AW |
227 | (record-case x |
228 | ((<void>) | |
229 | (case context | |
230cfcfb AW |
230 | ((push vals tail) |
231 | (emit-code #f (make-glil-void)))) | |
232 | (maybe-emit-return)) | |
cf10678f AW |
233 | |
234 | ((<const> src exp) | |
235 | (case context | |
230cfcfb AW |
236 | ((push vals tail) |
237 | (emit-code src (make-glil-const exp)))) | |
238 | (maybe-emit-return)) | |
cf10678f AW |
239 | |
240 | ;; FIXME: should represent sequence as exps tail | |
e5f5113c | 241 | ((<sequence> exps) |
cf10678f AW |
242 | (let lp ((exps exps)) |
243 | (if (null? (cdr exps)) | |
244 | (comp-tail (car exps)) | |
245 | (begin | |
246 | (comp-drop (car exps)) | |
247 | (lp (cdr exps)))))) | |
248 | ||
249 | ((<application> src proc args) | |
dce042f1 | 250 | ;; FIXME: need a better pattern-matcher here |
112edbae | 251 | (cond |
dce042f1 AW |
252 | ((and (primitive-ref? proc) |
253 | (eq? (primitive-ref-name proc) '@apply) | |
0f423f20 | 254 | (>= (length args) 1)) |
dce042f1 AW |
255 | (let ((proc (car args)) |
256 | (args (cdr args))) | |
257 | (cond | |
258 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) | |
f4aa8d53 | 259 | (not (eq? context 'push)) (not (eq? context 'vals))) |
dce042f1 AW |
260 | ;; tail: (lambda () (apply values '(1 2))) |
261 | ;; drop: (lambda () (apply values '(1 2)) 3) | |
262 | ;; push: (lambda () (list (apply values '(10 12)) 1)) | |
263 | (case context | |
230cfcfb | 264 | ((drop) (for-each comp-drop args) (maybe-emit-return)) |
dce042f1 AW |
265 | ((tail) |
266 | (for-each comp-push args) | |
267 | (emit-code src (make-glil-call 'return/values* (length args)))))) | |
268 | ||
269 | (else | |
dce042f1 | 270 | (case context |
0f423f20 AW |
271 | ((tail) |
272 | (comp-push proc) | |
273 | (for-each comp-push args) | |
274 | (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) | |
275 | ((push) | |
b7946e9e | 276 | (emit-code src (make-glil-call 'new-frame 0)) |
0f423f20 AW |
277 | (comp-push proc) |
278 | (for-each comp-push args) | |
230cfcfb AW |
279 | (emit-code src (make-glil-call 'apply (1+ (length args)))) |
280 | (maybe-emit-return)) | |
f4aa8d53 AW |
281 | ((vals) |
282 | (comp-vals | |
283 | (make-application src (make-primitive-ref #f 'apply) | |
284 | (cons proc args)) | |
230cfcfb AW |
285 | MVRA) |
286 | (maybe-emit-return)) | |
0f423f20 AW |
287 | ((drop) |
288 | ;; Well, shit. The proc might return any number of | |
289 | ;; values (including 0), since it's in a drop context, | |
290 | ;; yet apply does not create a MV continuation. So we | |
291 | ;; mv-call out to our trampoline instead. | |
292 | (comp-drop | |
293 | (make-application src (make-primitive-ref #f 'apply) | |
230cfcfb AW |
294 | (cons proc args))) |
295 | (maybe-emit-return))))))) | |
296 | ||
a1a482e0 AW |
297 | ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) |
298 | (not (eq? context 'push))) | |
299 | ;; tail: (lambda () (values '(1 2))) | |
300 | ;; drop: (lambda () (values '(1 2)) 3) | |
301 | ;; push: (lambda () (list (values '(10 12)) 1)) | |
f4aa8d53 | 302 | ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) |
a1a482e0 | 303 | (case context |
230cfcfb | 304 | ((drop) (for-each comp-drop args) (maybe-emit-return)) |
f4aa8d53 AW |
305 | ((vals) |
306 | (for-each comp-push args) | |
307 | (emit-code #f (make-glil-const (length args))) | |
230cfcfb | 308 | (emit-branch src 'br MVRA)) |
a1a482e0 AW |
309 | ((tail) |
310 | (for-each comp-push args) | |
311 | (emit-code src (make-glil-call 'return/values (length args)))))) | |
f4aa8d53 | 312 | |
dce042f1 AW |
313 | ((and (primitive-ref? proc) |
314 | (eq? (primitive-ref-name proc) '@call-with-values) | |
315 | (= (length args) 2)) | |
316 | ;; CONSUMER | |
317 | ;; PRODUCER | |
318 | ;; (mv-call MV) | |
319 | ;; ([tail]-call 1) | |
320 | ;; goto POST | |
321 | ;; MV: [tail-]call/nargs | |
322 | ;; POST: (maybe-drop) | |
f4aa8d53 AW |
323 | (case context |
324 | ((vals) | |
325 | ;; Fall back. | |
326 | (comp-vals | |
327 | (make-application src (make-primitive-ref #f 'call-with-values) | |
328 | args) | |
230cfcfb AW |
329 | MVRA) |
330 | (maybe-emit-return)) | |
f4aa8d53 AW |
331 | (else |
332 | (let ((MV (make-label)) (POST (make-label)) | |
333 | (producer (car args)) (consumer (cadr args))) | |
b7946e9e AW |
334 | (if (not (eq? context 'tail)) |
335 | (emit-code src (make-glil-call 'new-frame 0))) | |
f4aa8d53 | 336 | (comp-push consumer) |
b7946e9e | 337 | (emit-code src (make-glil-call 'new-frame 0)) |
f4aa8d53 AW |
338 | (comp-push producer) |
339 | (emit-code src (make-glil-mv-call 0 MV)) | |
340 | (case context | |
341 | ((tail) (emit-code src (make-glil-call 'goto/args 1))) | |
342 | (else (emit-code src (make-glil-call 'call 1)) | |
343 | (emit-branch #f 'br POST))) | |
344 | (emit-label MV) | |
345 | (case context | |
346 | ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) | |
347 | (else (emit-code src (make-glil-call 'call/nargs 0)) | |
348 | (emit-label POST) | |
349 | (if (eq? context 'drop) | |
230cfcfb AW |
350 | (emit-code #f (make-glil-call 'drop 1))) |
351 | (maybe-emit-return))))))) | |
dce042f1 AW |
352 | |
353 | ((and (primitive-ref? proc) | |
354 | (eq? (primitive-ref-name proc) '@call-with-current-continuation) | |
e32a1792 | 355 | (= (length args) 1)) |
dce042f1 | 356 | (case context |
0f423f20 AW |
357 | ((tail) |
358 | (comp-push (car args)) | |
359 | (emit-code src (make-glil-call 'goto/cc 1))) | |
f4aa8d53 AW |
360 | ((vals) |
361 | (comp-vals | |
362 | (make-application | |
363 | src (make-primitive-ref #f 'call-with-current-continuation) | |
364 | args) | |
230cfcfb AW |
365 | MVRA) |
366 | (maybe-emit-return)) | |
0f423f20 AW |
367 | ((push) |
368 | (comp-push (car args)) | |
230cfcfb AW |
369 | (emit-code src (make-glil-call 'call/cc 1)) |
370 | (maybe-emit-return)) | |
0f423f20 AW |
371 | ((drop) |
372 | ;; Crap. Just like `apply' in drop context. | |
373 | (comp-drop | |
374 | (make-application | |
375 | src (make-primitive-ref #f 'call-with-current-continuation) | |
230cfcfb AW |
376 | args)) |
377 | (maybe-emit-return)))) | |
dce042f1 | 378 | |
112edbae | 379 | ((and (primitive-ref? proc) |
c11f46af AW |
380 | (or (hash-ref *primcall-ops* |
381 | (cons (primitive-ref-name proc) (length args))) | |
382 | (hash-ref *primcall-ops* (primitive-ref-name proc)))) | |
112edbae AW |
383 | => (lambda (op) |
384 | (for-each comp-push args) | |
385 | (emit-code src (make-glil-call op (length args))) | |
60ed31d2 AW |
386 | (case (instruction-pushes op) |
387 | ((0) | |
388 | (case context | |
230cfcfb AW |
389 | ((tail push vals) (emit-code #f (make-glil-void)))) |
390 | (maybe-emit-return)) | |
60ed31d2 AW |
391 | ((1) |
392 | (case context | |
230cfcfb AW |
393 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
394 | (maybe-emit-return)) | |
60ed31d2 AW |
395 | (else |
396 | (error "bad primitive op: too many pushes" | |
397 | op (instruction-pushes op)))))) | |
398 | ||
8a4ca0ea | 399 | ;; self-call in tail position |
9b29d607 AW |
400 | ((and (lexical-ref? proc) |
401 | self-label (eq? (lexical-ref-gensym proc) self-label) | |
8a4ca0ea AW |
402 | (eq? context 'tail)) |
403 | ;; first, evaluate new values, pushing them on the stack | |
9b29d607 | 404 | (for-each comp-push args) |
8a4ca0ea AW |
405 | (let lp ((lcase (lambda-body self))) |
406 | (cond | |
407 | ((and (lambda-case? lcase) | |
408 | (not (lambda-case-kw lcase)) | |
409 | (not (lambda-case-opt lcase)) | |
410 | (not (lambda-case-rest lcase)) | |
411 | (= (length args) (length (lambda-case-req lcase)))) | |
412 | ;; we have a case that matches the args; rename variables | |
413 | ;; and goto the case label | |
414 | (for-each (lambda (sym) | |
415 | (pmatch (hashq-ref (hashq-ref allocation sym) self) | |
416 | ((#t #f . ,index) ; unboxed | |
417 | (emit-code #f (make-glil-lexical #t #f 'set index))) | |
418 | ((#t #t . ,index) ; boxed | |
419 | ;; new box | |
420 | (emit-code #f (make-glil-lexical #t #t 'box index))) | |
421 | (,x (error "what" x)))) | |
422 | (reverse (lambda-case-vars lcase))) | |
423 | (emit-branch src 'br (car (hashq-ref allocation lcase)))) | |
424 | ((lambda-case? lcase) | |
425 | ;; no match, try next case | |
426 | (lp (lambda-case-else lcase))) | |
427 | (else | |
428 | ;; no cases left; shuffle args down and jump before the prelude. | |
429 | (for-each (lambda (i) | |
24bf130f | 430 | (emit-code #f (make-glil-lexical #t #f 'set i))) |
8a4ca0ea AW |
431 | (reverse (iota (length args)))) |
432 | (emit-branch src 'br self-label))))) | |
9b29d607 | 433 | |
230cfcfb AW |
434 | ;; lambda, the ultimate goto |
435 | ((and (lexical-ref? proc) | |
436 | (assq (lexical-ref-gensym proc) fix-labels)) | |
8a4ca0ea AW |
437 | ;; like the self-tail-call case, though we can handle "drop" |
438 | ;; contexts too. first, evaluate new values, pushing them on | |
439 | ;; the stack | |
230cfcfb | 440 | (for-each comp-push args) |
8a4ca0ea AW |
441 | ;; find the specific case, rename args, and goto the case label |
442 | (let lp ((lcase (lambda-body | |
443 | (assq-ref fix-labels (lexical-ref-gensym proc))))) | |
444 | (cond | |
445 | ((and (lambda-case? lcase) | |
446 | (not (lambda-case-kw lcase)) | |
447 | (not (lambda-case-opt lcase)) | |
448 | (not (lambda-case-rest lcase)) | |
449 | (= (length args) (length (lambda-case-req lcase)))) | |
450 | ;; we have a case that matches the args; rename variables | |
451 | ;; and goto the case label | |
452 | (for-each (lambda (sym) | |
453 | (pmatch (hashq-ref (hashq-ref allocation sym) self) | |
454 | ((#t #f . ,index) ; unboxed | |
455 | (emit-code #f (make-glil-lexical #t #f 'set index))) | |
456 | ((#t #t . ,index) ; boxed | |
457 | (emit-code #f (make-glil-lexical #t #t 'box index))) | |
458 | (,x (error "what" x)))) | |
459 | (reverse (lambda-case-vars lcase))) | |
460 | (emit-branch src 'br (car (hashq-ref allocation lcase)))) | |
461 | ((lambda-case? lcase) | |
462 | ;; no match, try next case | |
463 | (lp (lambda-case-else lcase))) | |
464 | (else | |
465 | ;; no cases left. we can't really handle this currently. | |
466 | ;; ideally we would push on a new frame, then do a "local | |
467 | ;; call" -- which doesn't require consing up a program | |
468 | ;; object. but for now error, as this sort of case should | |
469 | ;; preclude label allocation. | |
470 | (error "couldn't find matching case for label call" x))))) | |
230cfcfb | 471 | |
112edbae | 472 | (else |
b7946e9e AW |
473 | (if (not (eq? context 'tail)) |
474 | (emit-code src (make-glil-call 'new-frame 0))) | |
112edbae AW |
475 | (comp-push proc) |
476 | (for-each comp-push args) | |
dce042f1 AW |
477 | (let ((len (length args))) |
478 | (case context | |
479 | ((tail) (emit-code src (make-glil-call 'goto/args len))) | |
230cfcfb AW |
480 | ((push) (emit-code src (make-glil-call 'call len)) |
481 | (maybe-emit-return)) | |
482 | ((vals) (emit-code src (make-glil-mv-call len MVRA)) | |
483 | (maybe-emit-return)) | |
484 | ((drop) (let ((MV (make-label)) (POST (make-label))) | |
485 | (emit-code src (make-glil-mv-call len MV)) | |
486 | (emit-code #f (make-glil-call 'drop 1)) | |
487 | (emit-branch #f 'br (or RA POST)) | |
488 | (emit-label MV) | |
489 | (emit-code #f (make-glil-mv-bind '() #f)) | |
490 | (emit-code #f (make-glil-unbind)) | |
491 | (if RA | |
492 | (emit-branch #f 'br RA) | |
493 | (emit-label POST))))))))) | |
073bb617 | 494 | |
b4a595a5 | 495 | ((<conditional> src test then (alternate else)) |
073bb617 AW |
496 | ;; TEST |
497 | ;; (br-if-not L1) | |
498 | ;; THEN | |
499 | ;; (br L2) | |
500 | ;; L1: ELSE | |
501 | ;; L2: | |
502 | (let ((L1 (make-label)) (L2 (make-label))) | |
b4a595a5 AW |
503 | ;; need a pattern matcher |
504 | (record-case test | |
505 | ((<application> proc args) | |
506 | (record-case proc | |
507 | ((<primitive-ref> name) | |
508 | (let ((len (length args))) | |
509 | (cond | |
510 | ||
511 | ((and (eq? name 'eq?) (= len 2)) | |
512 | (comp-push (car args)) | |
513 | (comp-push (cadr args)) | |
514 | (emit-branch src 'br-if-not-eq L1)) | |
515 | ||
516 | ((and (eq? name 'null?) (= len 1)) | |
517 | (comp-push (car args)) | |
518 | (emit-branch src 'br-if-not-null L1)) | |
519 | ||
520 | ((and (eq? name 'not) (= len 1)) | |
521 | (let ((app (car args))) | |
522 | (record-case app | |
523 | ((<application> proc args) | |
524 | (let ((len (length args))) | |
525 | (record-case proc | |
526 | ((<primitive-ref> name) | |
527 | (cond | |
528 | ||
529 | ((and (eq? name 'eq?) (= len 2)) | |
530 | (comp-push (car args)) | |
531 | (comp-push (cadr args)) | |
532 | (emit-branch src 'br-if-eq L1)) | |
533 | ||
534 | ((and (eq? name 'null?) (= len 1)) | |
535 | (comp-push (car args)) | |
536 | (emit-branch src 'br-if-null L1)) | |
537 | ||
538 | (else | |
539 | (comp-push app) | |
540 | (emit-branch src 'br-if L1)))) | |
541 | (else | |
542 | (comp-push app) | |
543 | (emit-branch src 'br-if L1))))) | |
544 | (else | |
545 | (comp-push app) | |
546 | (emit-branch src 'br-if L1))))) | |
547 | ||
548 | (else | |
549 | (comp-push test) | |
550 | (emit-branch src 'br-if-not L1))))) | |
551 | (else | |
552 | (comp-push test) | |
553 | (emit-branch src 'br-if-not L1)))) | |
554 | (else | |
555 | (comp-push test) | |
556 | (emit-branch src 'br-if-not L1))) | |
557 | ||
073bb617 | 558 | (comp-tail then) |
d97b69d9 AW |
559 | ;; if there is an RA, comp-tail will cause a jump to it -- just |
560 | ;; have to clean up here if there is no RA. | |
561 | (if (and (not RA) (not (eq? context 'tail))) | |
562 | (emit-branch #f 'br L2)) | |
cf10678f | 563 | (emit-label L1) |
b4a595a5 | 564 | (comp-tail alternate) |
d97b69d9 AW |
565 | (if (and (not RA) (not (eq? context 'tail))) |
566 | (emit-label L2)))) | |
567 | ||
cf10678f | 568 | ((<primitive-ref> src name) |
a1a482e0 AW |
569 | (cond |
570 | ((eq? (module-variable (fluid-ref *comp-module*) name) | |
571 | (module-variable the-root-module name)) | |
572 | (case context | |
230cfcfb AW |
573 | ((tail push vals) |
574 | (emit-code src (make-glil-toplevel 'ref name)))) | |
575 | (maybe-emit-return)) | |
94ff26b9 | 576 | ((module-variable the-root-module name) |
a1a482e0 | 577 | (case context |
230cfcfb AW |
578 | ((tail push vals) |
579 | (emit-code src (make-glil-module 'ref '(guile) name #f)))) | |
94ff26b9 AW |
580 | (maybe-emit-return)) |
581 | (else | |
582 | (case context | |
583 | ((tail push vals) | |
584 | (emit-code src (make-glil-module | |
585 | 'ref (module-name (fluid-ref *comp-module*)) name #f)))) | |
230cfcfb | 586 | (maybe-emit-return)))) |
cf10678f | 587 | |
e5f5113c | 588 | ((<lexical-ref> src gensym) |
cf10678f | 589 | (case context |
f4aa8d53 | 590 | ((push vals tail) |
9b29d607 | 591 | (pmatch (hashq-ref (hashq-ref allocation gensym) self) |
66d3e9a3 AW |
592 | ((,local? ,boxed? . ,index) |
593 | (emit-code src (make-glil-lexical local? boxed? 'ref index))) | |
594 | (,loc | |
595 | (error "badness" x loc))))) | |
230cfcfb | 596 | (maybe-emit-return)) |
66d3e9a3 | 597 | |
e5f5113c | 598 | ((<lexical-set> src gensym exp) |
cf10678f | 599 | (comp-push exp) |
9b29d607 | 600 | (pmatch (hashq-ref (hashq-ref allocation gensym) self) |
66d3e9a3 AW |
601 | ((,local? ,boxed? . ,index) |
602 | (emit-code src (make-glil-lexical local? boxed? 'set index))) | |
603 | (,loc | |
604 | (error "badness" x loc))) | |
cf10678f | 605 | (case context |
230cfcfb AW |
606 | ((tail push vals) |
607 | (emit-code #f (make-glil-void)))) | |
608 | (maybe-emit-return)) | |
cf10678f AW |
609 | |
610 | ((<module-ref> src mod name public?) | |
611 | (emit-code src (make-glil-module 'ref mod name public?)) | |
612 | (case context | |
230cfcfb AW |
613 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
614 | (maybe-emit-return)) | |
cf10678f AW |
615 | |
616 | ((<module-set> src mod name public? exp) | |
617 | (comp-push exp) | |
618 | (emit-code src (make-glil-module 'set mod name public?)) | |
619 | (case context | |
230cfcfb AW |
620 | ((tail push vals) |
621 | (emit-code #f (make-glil-void)))) | |
622 | (maybe-emit-return)) | |
cf10678f AW |
623 | |
624 | ((<toplevel-ref> src name) | |
625 | (emit-code src (make-glil-toplevel 'ref name)) | |
626 | (case context | |
230cfcfb AW |
627 | ((drop) (emit-code #f (make-glil-call 'drop 1)))) |
628 | (maybe-emit-return)) | |
cf10678f AW |
629 | |
630 | ((<toplevel-set> src name exp) | |
631 | (comp-push exp) | |
632 | (emit-code src (make-glil-toplevel 'set name)) | |
633 | (case context | |
230cfcfb AW |
634 | ((tail push vals) |
635 | (emit-code #f (make-glil-void)))) | |
636 | (maybe-emit-return)) | |
cf10678f AW |
637 | |
638 | ((<toplevel-define> src name exp) | |
639 | (comp-push exp) | |
640 | (emit-code src (make-glil-toplevel 'define name)) | |
641 | (case context | |
230cfcfb AW |
642 | ((tail push vals) |
643 | (emit-code #f (make-glil-void)))) | |
644 | (maybe-emit-return)) | |
cf10678f AW |
645 | |
646 | ((<lambda>) | |
8a4ca0ea | 647 | (let ((free-locs (cdr (hashq-ref allocation x)))) |
66d3e9a3 AW |
648 | (case context |
649 | ((push vals tail) | |
9b29d607 | 650 | (emit-code #f (flatten-lambda x #f allocation)) |
66d3e9a3 AW |
651 | (if (not (null? free-locs)) |
652 | (begin | |
653 | (for-each | |
654 | (lambda (loc) | |
655 | (pmatch loc | |
d773ba23 | 656 | ((,local? ,boxed? . ,n) |
66d3e9a3 AW |
657 | (emit-code #f (make-glil-lexical local? #f 'ref n))) |
658 | (else (error "what" x loc)))) | |
659 | free-locs) | |
660 | (emit-code #f (make-glil-call 'vector (length free-locs))) | |
230cfcfb AW |
661 | (emit-code #f (make-glil-call 'make-closure 2))))))) |
662 | (maybe-emit-return)) | |
66d3e9a3 | 663 | |
1e2a8edb | 664 | ((<lambda-case> src req opt rest kw inits vars else body) |
899d37a6 AW |
665 | ;; o/~ feature on top of feature o/~ |
666 | ;; req := (name ...) | |
b0c8c187 | 667 | ;; opt := (name ...) | #f |
899d37a6 | 668 | ;; rest := name | #f |
b0c8c187 | 669 | ;; kw: (allow-other-keys? (keyword name var) ...) | #f |
899d37a6 | 670 | ;; vars: (sym ...) |
899d37a6 AW |
671 | ;; init: tree-il in context of vars |
672 | ;; vars map to named arguments in the following order: | |
673 | ;; required, optional (positional), rest, keyword. | |
674 | (let* ((nreq (length req)) | |
675 | (nopt (if opt (length opt) 0)) | |
676 | (rest-idx (and rest (+ nreq nopt))) | |
b0c8c187 | 677 | (opt-names (or opt '())) |
899d37a6 AW |
678 | (allow-other-keys? (if kw (car kw) #f)) |
679 | (kw-indices (map (lambda (x) | |
680 | (pmatch x | |
b0c8c187 | 681 | ((,key ,name ,var) |
899d37a6 AW |
682 | (cons key (list-index vars var))) |
683 | (else (error "bad kwarg" x)))) | |
684 | (if kw (cdr kw) '()))) | |
b0c8c187 AW |
685 | (nargs (apply max (+ nreq nopt (if rest 1 0)) |
686 | (map 1+ (map cdr kw-indices)))) | |
899d37a6 AW |
687 | (nlocs (cdr (hashq-ref allocation x))) |
688 | (else-label (and else (make-label)))) | |
689 | (or (= nargs | |
690 | (length vars) | |
b0c8c187 | 691 | (+ nreq (length inits) (if rest 1 0))) |
899d37a6 | 692 | (error "something went wrong" |
b0c8c187 | 693 | req opt rest kw inits vars nreq nopt kw-indices nargs)) |
7e01997e AW |
694 | ;; the prelude, to check args & reset the stack pointer, |
695 | ;; allowing room for locals | |
696 | (emit-code | |
697 | src | |
698 | (cond | |
7e01997e | 699 | (kw |
899d37a6 AW |
700 | (make-glil-kw-prelude nreq nopt rest-idx kw-indices |
701 | allow-other-keys? nlocs else-label)) | |
7e01997e | 702 | ((or rest opt) |
899d37a6 | 703 | (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label)) |
7e01997e | 704 | (#t |
899d37a6 | 705 | (make-glil-std-prelude nreq nlocs else-label)))) |
7e01997e AW |
706 | ;; box args if necessary |
707 | (for-each | |
708 | (lambda (v) | |
709 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
710 | ((#t #t . ,n) | |
711 | (emit-code #f (make-glil-lexical #t #f 'ref n)) | |
712 | (emit-code #f (make-glil-lexical #t #t 'box n))))) | |
713 | vars) | |
714 | ;; write bindings info | |
715 | (if (not (null? vars)) | |
716 | (emit-bindings | |
717 | #f | |
718 | (let lp ((kw (if kw (cdr kw) '())) | |
b0c8c187 | 719 | (names (append (reverse opt-names) (reverse req))) |
899d37a6 | 720 | (vars (list-tail vars (+ nreq nopt |
7e01997e AW |
721 | (if rest 1 0))))) |
722 | (pmatch kw | |
899d37a6 AW |
723 | (() |
724 | ;; fixme: check that vars is empty | |
725 | (reverse (if rest (cons rest names) names))) | |
7e01997e AW |
726 | (((,key ,name ,var) . ,kw) |
727 | (if (memq var vars) | |
728 | (lp kw (cons name names) (delq var vars)) | |
729 | (lp kw names vars))) | |
730 | (,kw (error "bad keywords, yo" kw)))) | |
731 | vars allocation self emit-code)) | |
b0c8c187 AW |
732 | ;; init optional/kw args |
733 | (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq))) | |
734 | (cond | |
735 | ((null? inits)) ; done | |
736 | ((and rest-idx (= n rest-idx)) | |
737 | (lp inits (1+ n) (cdr vars))) | |
738 | (#t | |
739 | (pmatch (hashq-ref (hashq-ref allocation (car vars)) self) | |
740 | ((#t ,boxed? . ,n*) (guard (= n* n)) | |
741 | (let ((L (make-label))) | |
742 | (emit-code #f (make-glil-lexical #t boxed? 'bound? n)) | |
743 | (emit-code #f (make-glil-branch 'br-if L)) | |
744 | (comp-push (car inits)) | |
745 | (emit-code #f (make-glil-lexical #t boxed? 'set n)) | |
746 | (emit-label L) | |
747 | (lp (cdr inits) (1+ n) (cdr vars)))) | |
748 | (#t (error "what" inits)))))) | |
7e01997e AW |
749 | ;; post-prelude case label for label calls |
750 | (emit-label (car (hashq-ref allocation x))) | |
8a4ca0ea AW |
751 | (comp-tail body) |
752 | (if (not (null? vars)) | |
753 | (emit-code #f (make-glil-unbind))) | |
754 | (if else-label | |
755 | (begin | |
756 | (emit-label else-label) | |
757 | (comp-tail else))))) | |
758 | ||
f4aa8d53 | 759 | ((<let> src names vars vals body) |
073bb617 | 760 | (for-each comp-push vals) |
9b29d607 | 761 | (emit-bindings src names vars allocation self emit-code) |
cf10678f | 762 | (for-each (lambda (v) |
9b29d607 | 763 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
764 | ((#t #f . ,n) |
765 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
766 | ((#t #t . ,n) | |
767 | (emit-code src (make-glil-lexical #t #t 'box n))) | |
768 | (,loc (error "badness" x loc)))) | |
cf10678f | 769 | (reverse vars)) |
f4aa8d53 | 770 | (comp-tail body) |
cf10678f AW |
771 | (emit-code #f (make-glil-unbind))) |
772 | ||
f4aa8d53 | 773 | ((<letrec> src names vars vals body) |
66d3e9a3 | 774 | (for-each (lambda (v) |
9b29d607 | 775 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
776 | ((#t #t . ,n) |
777 | (emit-code src (make-glil-lexical #t #t 'empty-box n))) | |
778 | (,loc (error "badness" x loc)))) | |
779 | vars) | |
cf10678f | 780 | (for-each comp-push vals) |
9b29d607 | 781 | (emit-bindings src names vars allocation self emit-code) |
cf10678f | 782 | (for-each (lambda (v) |
9b29d607 | 783 | (pmatch (hashq-ref (hashq-ref allocation v) self) |
66d3e9a3 AW |
784 | ((#t #t . ,n) |
785 | (emit-code src (make-glil-lexical #t #t 'set n))) | |
786 | (,loc (error "badness" x loc)))) | |
cf10678f | 787 | (reverse vars)) |
f4aa8d53 AW |
788 | (comp-tail body) |
789 | (emit-code #f (make-glil-unbind))) | |
790 | ||
c21c89b1 | 791 | ((<fix> src names vars vals body) |
230cfcfb AW |
792 | ;; The ideal here is to just render the lambda bodies inline, and |
793 | ;; wire the code together with gotos. We can do that if | |
794 | ;; analyze-lexicals has determined that a given var has "label" | |
795 | ;; allocation -- which is the case if it is in `fix-labels'. | |
796 | ;; | |
797 | ;; But even for closures that we can't inline, we can do some | |
798 | ;; tricks to avoid heap-allocation for the binding itself. Since | |
799 | ;; we know the vals are lambdas, we can set them to their local | |
800 | ;; var slots first, then capture their bindings, mutating them in | |
801 | ;; place. | |
7f7b85cb | 802 | (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label)))) |
230cfcfb AW |
803 | (for-each |
804 | (lambda (x v) | |
805 | (cond | |
806 | ((hashq-ref allocation x) | |
807 | ;; allocating a closure | |
808 | (emit-code #f (flatten-lambda x v allocation)) | |
8a4ca0ea | 809 | (if (not (null? (cdr (hashq-ref allocation x)))) |
230cfcfb AW |
810 | ;; Need to make-closure first, but with a temporary #f |
811 | ;; free-variables vector, so we are mutating fresh | |
812 | ;; closures on the heap. | |
813 | (begin | |
814 | (emit-code #f (make-glil-const #f)) | |
815 | (emit-code #f (make-glil-call 'make-closure 2)))) | |
816 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
817 | ((#t #f . ,n) | |
818 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
819 | (,loc (error "badness" x loc)))) | |
820 | (else | |
821 | ;; labels allocation: emit label & body, but jump over it | |
822 | (let ((POST (make-label))) | |
823 | (emit-branch #f 'br POST) | |
8a4ca0ea AW |
824 | (let lp ((lcase (lambda-body x))) |
825 | (if lcase | |
826 | (record-case lcase | |
827 | ((<lambda-case> src req vars body else) | |
828 | (emit-label (car (hashq-ref allocation lcase))) | |
829 | ;; FIXME: opt & kw args in the bindings | |
830 | (emit-bindings #f req vars allocation self emit-code) | |
831 | (if src | |
832 | (emit-code #f (make-glil-source src))) | |
833 | (comp-fix body (or RA new-RA)) | |
834 | (emit-code #f (make-glil-unbind)) | |
835 | (lp else))) | |
836 | (emit-label POST))))))) | |
230cfcfb AW |
837 | vals |
838 | vars) | |
839 | ;; Emit bindings metadata for closures | |
840 | (let ((binds (let lp ((out '()) (vars vars) (names names)) | |
841 | (cond ((null? vars) (reverse! out)) | |
d97b69d9 | 842 | ((assq (car vars) fix-labels) |
230cfcfb AW |
843 | (lp out (cdr vars) (cdr names))) |
844 | (else | |
845 | (lp (acons (car vars) (car names) out) | |
846 | (cdr vars) (cdr names))))))) | |
847 | (emit-bindings src (map cdr binds) (map car binds) | |
848 | allocation self emit-code)) | |
849 | ;; Now go back and fix up the bindings for closures. | |
850 | (for-each | |
851 | (lambda (x v) | |
852 | (let ((free-locs (if (hashq-ref allocation x) | |
8a4ca0ea | 853 | (cdr (hashq-ref allocation x)) |
230cfcfb AW |
854 | ;; can hit this latter case for labels allocation |
855 | '()))) | |
856 | (if (not (null? free-locs)) | |
857 | (begin | |
858 | (for-each | |
859 | (lambda (loc) | |
860 | (pmatch loc | |
d773ba23 | 861 | ((,local? ,boxed? . ,n) |
230cfcfb AW |
862 | (emit-code #f (make-glil-lexical local? #f 'ref n))) |
863 | (else (error "what" x loc)))) | |
864 | free-locs) | |
865 | (emit-code #f (make-glil-call 'vector (length free-locs))) | |
866 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
867 | ((#t #f . ,n) | |
868 | (emit-code #f (make-glil-lexical #t #f 'fix n))) | |
869 | (,loc (error "badness" x loc))))))) | |
870 | vals | |
871 | vars) | |
872 | (comp-tail body) | |
7f7b85cb AW |
873 | (if new-RA |
874 | (emit-label new-RA)) | |
230cfcfb | 875 | (emit-code #f (make-glil-unbind)))) |
c21c89b1 | 876 | |
8a4ca0ea AW |
877 | ((<let-values> src exp body) |
878 | (record-case body | |
1e2a8edb AW |
879 | ((<lambda-case> req opt kw rest vars body else) |
880 | (if (or opt kw else) | |
8a4ca0ea AW |
881 | (error "unexpected lambda-case in let-values" x)) |
882 | (let ((MV (make-label))) | |
883 | (comp-vals exp MV) | |
884 | (emit-code #f (make-glil-const 1)) | |
885 | (emit-label MV) | |
886 | (emit-code src (make-glil-mv-bind | |
887 | (vars->bind-list | |
888 | (append req (if rest (list rest) '())) | |
889 | vars allocation self) | |
890 | (and rest #t))) | |
891 | (for-each (lambda (v) | |
892 | (pmatch (hashq-ref (hashq-ref allocation v) self) | |
893 | ((#t #f . ,n) | |
894 | (emit-code src (make-glil-lexical #t #f 'set n))) | |
895 | ((#t #t . ,n) | |
896 | (emit-code src (make-glil-lexical #t #t 'box n))) | |
897 | (,loc (error "badness" x loc)))) | |
898 | (reverse vars)) | |
899 | (comp-tail body) | |
900 | (emit-code #f (make-glil-unbind))))))))) |