Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; GHIL -> GLIL compiler |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
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 | |
17e90c5e KN |
18 | |
19 | ;;; Code: | |
20 | ||
d9042285 | 21 | (define-module (language ghil compile-glil) |
8239263f | 22 | #:use-module (system base syntax) |
9ff56d9e AW |
23 | #:use-module (language glil) |
24 | #:use-module (language ghil) | |
1a1a10d3 | 25 | #:use-module (ice-9 common-list) |
d9042285 | 26 | #:export (compile-glil)) |
17e90c5e | 27 | |
d9042285 | 28 | (define (compile-glil x e opts) |
1a1a10d3 | 29 | (if (memq #:O opts) (set! x (optimize x))) |
b0b180d5 | 30 | (values (codegen x) |
b41b92c9 AW |
31 | (and e (cons (car e) (cddr e))) |
32 | e)) | |
17e90c5e KN |
33 | |
34 | \f | |
35 | ;;; | |
36 | ;;; Stage 2: Optimization | |
37 | ;;; | |
38 | ||
d51406fe AW |
39 | (define (lift-variables! env) |
40 | (let ((parent-env (ghil-env-parent env))) | |
41 | (for-each (lambda (v) | |
42 | (case (ghil-var-kind v) | |
43 | ((argument) (set! (ghil-var-kind v) 'local))) | |
44 | (set! (ghil-var-env v) parent-env) | |
45 | (ghil-env-add! parent-env v)) | |
46 | (ghil-env-variables env)))) | |
47 | ||
3ca84011 AW |
48 | ;; The premise of this, unused, approach to optimization is that you can |
49 | ;; determine the environment of a variable lexically, because they have | |
50 | ;; been alpha-renamed. It makes the transformations *much* easier. | |
51 | ;; Unfortunately it doesn't work yet. | |
b106a3ed AW |
52 | (define (optimize* x) |
53 | (transform-record (<ghil> env loc) x | |
54 | ((quasiquote exp) | |
55 | (define (optimize-qq x) | |
56 | (cond ((list? x) (map optimize-qq x)) | |
57 | ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x)))) | |
58 | ((record? x) (optimize x)) | |
59 | (else x))) | |
89522052 | 60 | (-> (quasiquote (optimize-qq x)))) |
b106a3ed AW |
61 | |
62 | ((unquote exp) | |
89522052 | 63 | (-> (unquote (optimize exp)))) |
b106a3ed AW |
64 | |
65 | ((unquote-splicing exp) | |
89522052 | 66 | (-> (unquote-splicing (optimize exp)))) |
b106a3ed AW |
67 | |
68 | ((set var val) | |
89522052 | 69 | (-> (set var (optimize val)))) |
b106a3ed AW |
70 | |
71 | ((define var val) | |
89522052 | 72 | (-> (define var (optimize val)))) |
b106a3ed AW |
73 | |
74 | ((if test then else) | |
89522052 | 75 | (-> (if (optimize test) (optimize then) (optimize else)))) |
b106a3ed AW |
76 | |
77 | ((and exps) | |
89522052 | 78 | (-> (and (map optimize exps)))) |
b106a3ed AW |
79 | |
80 | ((or exps) | |
89522052 | 81 | (-> (or (map optimize exps)))) |
b106a3ed AW |
82 | |
83 | ((begin exps) | |
89522052 | 84 | (-> (begin (map optimize exps)))) |
b106a3ed AW |
85 | |
86 | ((bind vars vals body) | |
89522052 | 87 | (-> (bind vars (map optimize vals) (optimize body)))) |
b106a3ed AW |
88 | |
89 | ((mv-bind producer vars rest body) | |
89522052 | 90 | (-> (mv-bind (optimize producer) vars rest (optimize body)))) |
b106a3ed AW |
91 | |
92 | ((inline inst args) | |
89522052 | 93 | (-> (inline inst (map optimize args)))) |
b106a3ed AW |
94 | |
95 | ((call (proc (lambda vars (rest #f) meta body)) args) | |
89522052 | 96 | (-> (bind vars (optimize args) (optimize body)))) |
b106a3ed AW |
97 | |
98 | ((call proc args) | |
89522052 | 99 | (-> (call (optimize proc) (map optimize args)))) |
b106a3ed AW |
100 | |
101 | ((lambda vars rest meta body) | |
89522052 | 102 | (-> (lambda vars rest meta (optimize body)))) |
b106a3ed AW |
103 | |
104 | ((mv-call producer (consumer (lambda vars rest meta body))) | |
89522052 | 105 | (-> (mv-bind (optimize producer) vars rest (optimize body)))) |
b106a3ed AW |
106 | |
107 | ((mv-call producer consumer) | |
89522052 | 108 | (-> (mv-call (optimize producer) (optimize consumer)))) |
b106a3ed AW |
109 | |
110 | ((values values) | |
89522052 | 111 | (-> (values (map optimize values)))) |
b106a3ed AW |
112 | |
113 | ((values* values) | |
89522052 | 114 | (-> (values* (map optimize values)))) |
b106a3ed AW |
115 | |
116 | (else | |
117 | (error "unrecognized GHIL" x)))) | |
118 | ||
17e90c5e | 119 | (define (optimize x) |
67169b29 | 120 | (record-case x |
61dc81d9 | 121 | ((<ghil-set> env loc var val) |
849cefac | 122 | (make-ghil-set env var (optimize val))) |
3616e9e9 | 123 | |
d51406fe AW |
124 | ((<ghil-define> env loc var val) |
125 | (make-ghil-define env var (optimize val))) | |
126 | ||
61dc81d9 | 127 | ((<ghil-if> env loc test then else) |
22bcbe8c | 128 | (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) |
3616e9e9 | 129 | |
d51406fe AW |
130 | ((<ghil-and> env loc exps) |
131 | (make-ghil-and env loc (map optimize exps))) | |
132 | ||
133 | ((<ghil-or> env loc exps) | |
134 | (make-ghil-or env loc (map optimize exps))) | |
135 | ||
61dc81d9 | 136 | ((<ghil-begin> env loc exps) |
22bcbe8c | 137 | (make-ghil-begin env loc (map optimize exps))) |
3616e9e9 | 138 | |
61dc81d9 | 139 | ((<ghil-bind> env loc vars vals body) |
22bcbe8c | 140 | (make-ghil-bind env loc vars (map optimize vals) (optimize body))) |
3616e9e9 | 141 | |
fbde2b91 AW |
142 | ((<ghil-lambda> env loc vars rest meta body) |
143 | (make-ghil-lambda env loc vars rest meta (optimize body))) | |
3616e9e9 | 144 | |
22bcbe8c AW |
145 | ((<ghil-inline> env loc instruction args) |
146 | (make-ghil-inline env loc instruction (map optimize args))) | |
3616e9e9 | 147 | |
61dc81d9 AW |
148 | ((<ghil-call> env loc proc args) |
149 | (let ((parent-env env)) | |
150 | (record-case proc | |
151 | ;; ((@lambda (VAR...) BODY...) ARG...) => | |
152 | ;; (@let ((VAR ARG) ...) BODY...) | |
fbde2b91 | 153 | ((<ghil-lambda> env loc vars rest meta body) |
61dc81d9 AW |
154 | (cond |
155 | ((not rest) | |
d51406fe AW |
156 | (lift-variables! env) |
157 | (make-ghil-bind parent-env loc (map optimize args))) | |
61dc81d9 | 158 | (else |
22bcbe8c | 159 | (make-ghil-call parent-env loc (optimize proc) (map optimize args))))) |
61dc81d9 | 160 | (else |
22bcbe8c | 161 | (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))) |
61dc81d9 | 162 | |
d51406fe AW |
163 | ((<ghil-mv-call> env loc producer consumer) |
164 | (record-case consumer | |
165 | ;; (mv-call PRODUCER (lambda ARGS BODY...)) => | |
166 | ;; (mv-let PRODUCER ARGS BODY...) | |
167 | ((<ghil-lambda> env loc vars rest meta body) | |
168 | (lift-variables! env) | |
169 | (make-ghil-mv-bind producer vars rest body)) | |
170 | (else | |
171 | (make-ghil-mv-call env loc (optimize producer) (optimize consumer))))) | |
172 | ||
17e90c5e KN |
173 | (else x))) |
174 | ||
175 | \f | |
176 | ;;; | |
177 | ;;; Stage 3: Code generation | |
178 | ;;; | |
179 | ||
849cefac | 180 | (define *ia-void* (make-glil-void)) |
131f7d6c AW |
181 | (define *ia-drop* (make-glil-call 'drop 1)) |
182 | (define *ia-return* (make-glil-call 'return 1)) | |
17e90c5e KN |
183 | |
184 | (define (make-label) (gensym ":L")) | |
185 | ||
186 | (define (make-glil-var op env var) | |
aa0a011b | 187 | (case (ghil-var-kind var) |
17e90c5e | 188 | ((argument) |
cf10678f | 189 | (make-glil-local op (ghil-var-index var))) |
17e90c5e | 190 | ((local) |
aa0a011b | 191 | (make-glil-local op (ghil-var-index var))) |
17e90c5e KN |
192 | ((external) |
193 | (do ((depth 0 (1+ depth)) | |
aa0a011b AW |
194 | (e env (ghil-env-parent e))) |
195 | ((eq? e (ghil-var-env var)) | |
196 | (make-glil-external op depth (ghil-var-index var))))) | |
a1122f8c AW |
197 | ((toplevel) |
198 | (make-glil-toplevel op (ghil-var-name var))) | |
fd358575 AW |
199 | ((public private) |
200 | (make-glil-module op (ghil-var-env var) (ghil-var-name var) | |
201 | (eq? (ghil-var-kind var) 'public))) | |
17e90c5e KN |
202 | (else (error "Unknown kind of variable:" var)))) |
203 | ||
1b79210a AW |
204 | (define (constant? x) |
205 | (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t) | |
206 | ((pair? x) (and (constant? (car x)) | |
207 | (constant? (cdr x)))) | |
208 | ((vector? x) (let lp ((i (vector-length x))) | |
209 | (or (zero? i) | |
210 | (and (constant? (vector-ref x (1- i))) | |
211 | (lp (1- i)))))))) | |
212 | ||
17e90c5e KN |
213 | (define (codegen ghil) |
214 | (let ((stack '())) | |
96969dc1 | 215 | (define (push-code! loc code) |
d0168f3d AW |
216 | (set! stack (cons code stack)) |
217 | (if loc (set! stack (cons (make-glil-source loc) stack)))) | |
d51406fe | 218 | (define (var->binding var) |
cf10678f AW |
219 | (list (ghil-var-name var) (let ((kind (ghil-var-kind var))) |
220 | (case kind ((argument) 'local) (else kind))) | |
221 | (ghil-var-index var))) | |
96969dc1 | 222 | (define (push-bindings! loc vars) |
aa0a011b | 223 | (if (not (null? vars)) |
d51406fe | 224 | (push-code! loc (make-glil-bind (map var->binding vars))))) |
17e90c5e | 225 | (define (comp tree tail drop) |
cb4cca12 | 226 | (define (push-label! label) |
96969dc1 AW |
227 | (push-code! #f (make-glil-label label))) |
228 | (define (push-branch! loc inst label) | |
229 | (push-code! loc (make-glil-branch inst label))) | |
ac99cb0c | 230 | (define (push-call! loc inst args) |
cb4cca12 | 231 | (for-each comp-push args) |
96969dc1 | 232 | (push-code! loc (make-glil-call inst (length args)))) |
17e90c5e KN |
233 | ;; possible tail position |
234 | (define (comp-tail tree) (comp tree tail drop)) | |
235 | ;; push the result | |
236 | (define (comp-push tree) (comp tree #f #f)) | |
237 | ;; drop the result | |
238 | (define (comp-drop tree) (comp tree #f #t)) | |
cb4cca12 KN |
239 | ;; drop the result if unnecessary |
240 | (define (maybe-drop) | |
96969dc1 | 241 | (if drop (push-code! #f *ia-drop*))) |
cb4cca12 KN |
242 | ;; return here if necessary |
243 | (define (maybe-return) | |
96969dc1 | 244 | (if tail (push-code! #f *ia-return*))) |
17e90c5e | 245 | ;; return this code if necessary |
96969dc1 AW |
246 | (define (return-code! loc code) |
247 | (if (not drop) (push-code! loc code)) | |
cb4cca12 | 248 | (maybe-return)) |
17e90c5e | 249 | ;; return void if necessary |
cb4cca12 | 250 | (define (return-void!) |
96969dc1 | 251 | (return-code! #f *ia-void*)) |
cb4cca12 | 252 | ;; return object if necessary |
96969dc1 | 253 | (define (return-object! loc obj) |
d9d671f7 | 254 | (return-code! loc (make-glil-const obj))) |
17e90c5e KN |
255 | ;; |
256 | ;; dispatch | |
67169b29 AW |
257 | (record-case tree |
258 | ((<ghil-void>) | |
17e90c5e KN |
259 | (return-void!)) |
260 | ||
67169b29 | 261 | ((<ghil-quote> env loc obj) |
96969dc1 | 262 | (return-object! loc obj)) |
cb4cca12 | 263 | |
67169b29 | 264 | ((<ghil-quasiquote> env loc exp) |
2bd859c8 | 265 | (let loop ((x exp) (in-car? #f)) |
67169b29 AW |
266 | (cond |
267 | ((list? x) | |
268 | (push-call! #f 'mark '()) | |
2bd859c8 | 269 | (for-each (lambda (x) (loop x #t)) x) |
67169b29 AW |
270 | (push-call! #f 'list-mark '())) |
271 | ((pair? x) | |
2bd859c8 AW |
272 | (push-call! #f 'mark '()) |
273 | (loop (car x) #t) | |
274 | (loop (cdr x) #f) | |
275 | (push-call! #f 'cons-mark '())) | |
67169b29 AW |
276 | ((record? x) |
277 | (record-case x | |
278 | ((<ghil-unquote> env loc exp) | |
279 | (comp-push exp)) | |
280 | ((<ghil-unquote-splicing> env loc exp) | |
2bd859c8 AW |
281 | (if (not in-car?) |
282 | (error "unquote-splicing in the cdr of a pair" exp)) | |
67169b29 AW |
283 | (comp-push exp) |
284 | (push-call! #f 'list-break '())))) | |
1b79210a | 285 | ((constant? x) |
d9d671f7 | 286 | (push-code! #f (make-glil-const x))) |
67169b29 | 287 | (else |
1b79210a | 288 | (error "element of quasiquote can't be compiled" x)))) |
cb4cca12 KN |
289 | (maybe-drop) |
290 | (maybe-return)) | |
17e90c5e | 291 | |
c2c82b62 AW |
292 | ((<ghil-unquote> env loc exp) |
293 | (error "unquote outside of quasiquote" exp)) | |
294 | ||
295 | ((<ghil-unquote-splicing> env loc exp) | |
296 | (error "unquote-splicing outside of quasiquote" exp)) | |
297 | ||
67169b29 | 298 | ((<ghil-ref> env loc var) |
96969dc1 | 299 | (return-code! loc (make-glil-var 'ref env var))) |
17e90c5e | 300 | |
67169b29 | 301 | ((<ghil-set> env loc var val) |
ac99cb0c | 302 | (comp-push val) |
96969dc1 | 303 | (push-code! loc (make-glil-var 'set env var)) |
ac99cb0c KN |
304 | (return-void!)) |
305 | ||
67169b29 | 306 | ((<ghil-define> env loc var val) |
17e90c5e | 307 | (comp-push val) |
96969dc1 | 308 | (push-code! loc (make-glil-var 'define env var)) |
17e90c5e KN |
309 | (return-void!)) |
310 | ||
67169b29 | 311 | ((<ghil-if> env loc test then else) |
17e90c5e KN |
312 | ;; TEST |
313 | ;; (br-if-not L1) | |
314 | ;; THEN | |
41f248a8 | 315 | ;; (br L2) |
17e90c5e KN |
316 | ;; L1: ELSE |
317 | ;; L2: | |
318 | (let ((L1 (make-label)) (L2 (make-label))) | |
319 | (comp-push test) | |
96969dc1 | 320 | (push-branch! loc 'br-if-not L1) |
17e90c5e | 321 | (comp-tail then) |
96969dc1 | 322 | (if (not tail) (push-branch! #f 'br L2)) |
cb4cca12 | 323 | (push-label! L1) |
17e90c5e | 324 | (comp-tail else) |
cb4cca12 KN |
325 | (if (not tail) (push-label! L2)))) |
326 | ||
67169b29 | 327 | ((<ghil-and> env loc exps) |
cb4cca12 KN |
328 | ;; EXP |
329 | ;; (br-if-not L1) | |
330 | ;; ... | |
331 | ;; TAIL | |
332 | ;; (br L2) | |
333 | ;; L1: (const #f) | |
334 | ;; L2: | |
7e4760e4 AW |
335 | (cond ((null? exps) (return-object! loc #t)) |
336 | ((null? (cdr exps)) (comp-tail (car exps))) | |
337 | (else | |
338 | (let ((L1 (make-label)) (L2 (make-label))) | |
339 | (let lp ((exps exps)) | |
340 | (cond ((null? (cdr exps)) | |
341 | (comp-tail (car exps)) | |
342 | (push-branch! #f 'br L2) | |
343 | (push-label! L1) | |
344 | (return-object! #f #f) | |
345 | (push-label! L2) | |
346 | (maybe-return)) | |
347 | (else | |
348 | (comp-push (car exps)) | |
349 | (push-branch! #f 'br-if-not L1) | |
350 | (lp (cdr exps))))))))) | |
cb4cca12 | 351 | |
67169b29 | 352 | ((<ghil-or> env loc exps) |
cb4cca12 KN |
353 | ;; EXP |
354 | ;; (dup) | |
355 | ;; (br-if L1) | |
356 | ;; (drop) | |
357 | ;; ... | |
358 | ;; TAIL | |
359 | ;; L1: | |
7e4760e4 AW |
360 | (cond ((null? exps) (return-object! loc #f)) |
361 | ((null? (cdr exps)) (comp-tail (car exps))) | |
362 | (else | |
363 | (let ((L1 (make-label))) | |
364 | (let lp ((exps exps)) | |
365 | (cond ((null? (cdr exps)) | |
366 | (comp-tail (car exps)) | |
367 | (push-label! L1) | |
368 | (maybe-return)) | |
369 | (else | |
370 | (comp-push (car exps)) | |
535ed4d0 AW |
371 | (if (not drop) |
372 | (push-call! #f 'dup '())) | |
7e4760e4 | 373 | (push-branch! #f 'br-if L1) |
535ed4d0 | 374 | (if (not drop) |
131f7d6c | 375 | (push-code! loc (make-glil-call 'drop 1))) |
7e4760e4 | 376 | (lp (cdr exps))))))))) |
17e90c5e | 377 | |
67169b29 | 378 | ((<ghil-begin> env loc exps) |
17e90c5e KN |
379 | ;; EXPS... |
380 | ;; TAIL | |
381 | (if (null? exps) | |
382 | (return-void!) | |
383 | (do ((exps exps (cdr exps))) | |
384 | ((null? (cdr exps)) | |
385 | (comp-tail (car exps))) | |
386 | (comp-drop (car exps))))) | |
387 | ||
67169b29 | 388 | ((<ghil-bind> env loc vars vals body) |
17e90c5e KN |
389 | ;; VALS... |
390 | ;; (set VARS)... | |
391 | ;; BODY | |
392 | (for-each comp-push vals) | |
96969dc1 AW |
393 | (push-bindings! loc vars) |
394 | (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) | |
a6df585a | 395 | (reverse vars)) |
ac99cb0c | 396 | (comp-tail body) |
96969dc1 | 397 | (push-code! #f (make-glil-unbind))) |
17e90c5e | 398 | |
d51406fe AW |
399 | ((<ghil-mv-bind> env loc producer vars rest body) |
400 | ;; VALS... | |
401 | ;; (set VARS)... | |
402 | ;; BODY | |
403 | (let ((MV (make-label))) | |
404 | (comp-push producer) | |
405 | (push-code! loc (make-glil-mv-call 0 MV)) | |
d9d671f7 | 406 | (push-code! #f (make-glil-const 1)) |
d51406fe AW |
407 | (push-label! MV) |
408 | (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) | |
409 | (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) | |
410 | (reverse vars))) | |
411 | (comp-tail body) | |
412 | (push-code! #f (make-glil-unbind))) | |
413 | ||
fbde2b91 | 414 | ((<ghil-lambda> env loc vars rest meta body) |
96969dc1 | 415 | (return-code! loc (codegen tree))) |
17e90c5e | 416 | |
f540e327 | 417 | ((<ghil-inline> env loc inline args) |
46cd9a34 KN |
418 | ;; ARGS... |
419 | ;; (INST NARGS) | |
76282387 AW |
420 | (let ((tail-table '((call . goto/args) |
421 | (apply . goto/apply) | |
422 | (call/cc . goto/cc)))) | |
423 | (cond ((and tail (assq-ref tail-table inline)) | |
424 | => (lambda (tail-inst) | |
425 | (push-call! loc tail-inst args))) | |
426 | (else | |
427 | (push-call! loc inline args) | |
428 | (maybe-drop) | |
429 | (maybe-return))))) | |
46cd9a34 | 430 | |
a222b0fa AW |
431 | ((<ghil-values> env loc values) |
432 | (cond (tail ;; (lambda () (values 1 2)) | |
433 | (push-call! loc 'return/values values)) | |
434 | (drop ;; (lambda () (values 1 2) 3) | |
435 | (for-each comp-drop values)) | |
436 | (else ;; (lambda () (list (values 10 12) 1)) | |
d9d671f7 AW |
437 | (push-code! #f (make-glil-const 'values)) |
438 | (push-code! #f (make-glil-call 'link-now 1)) | |
439 | (push-code! #f (make-glil-call 'variable-ref 0)) | |
a222b0fa AW |
440 | (push-call! loc 'call values)))) |
441 | ||
ef24c01b AW |
442 | ((<ghil-values*> env loc values) |
443 | (cond (tail ;; (lambda () (apply values '(1 2))) | |
444 | (push-call! loc 'return/values* values)) | |
445 | (drop ;; (lambda () (apply values '(1 2)) 3) | |
446 | (for-each comp-drop values)) | |
447 | (else ;; (lambda () (list (apply values '(10 12)) 1)) | |
d9d671f7 AW |
448 | (push-code! #f (make-glil-const 'values)) |
449 | (push-code! #f (make-glil-call 'link-now 1)) | |
450 | (push-code! #f (make-glil-call 'variable-ref 0)) | |
ef24c01b AW |
451 | (push-call! loc 'apply values)))) |
452 | ||
67169b29 | 453 | ((<ghil-call> env loc proc args) |
17e90c5e | 454 | ;; PROC |
3616e9e9 | 455 | ;; ARGS... |
17e90c5e | 456 | ;; ([tail-]call NARGS) |
17e90c5e | 457 | (comp-push proc) |
aec8febc AW |
458 | (let ((nargs (length args))) |
459 | (cond ((< nargs 255) | |
460 | (push-call! loc (if tail 'goto/args 'call) args)) | |
461 | (else | |
462 | (push-call! loc 'mark '()) | |
463 | (for-each comp-push args) | |
464 | (push-call! loc 'list-mark '()) | |
465 | (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2))))) | |
efbd5892 AW |
466 | (maybe-drop)) |
467 | ||
468 | ((<ghil-mv-call> env loc producer consumer) | |
469 | ;; CONSUMER | |
470 | ;; PRODUCER | |
471 | ;; (mv-call MV) | |
472 | ;; ([tail]-call 1) | |
473 | ;; goto POST | |
474 | ;; MV: [tail-]call/nargs | |
475 | ;; POST: (maybe-drop) | |
476 | (let ((MV (make-label)) (POST (make-label))) | |
477 | (comp-push consumer) | |
478 | (comp-push producer) | |
479 | (push-code! loc (make-glil-mv-call 0 MV)) | |
480 | (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) | |
481 | (cond ((not tail) | |
482 | (push-branch! #f 'br POST))) | |
483 | (push-label! MV) | |
484 | (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) | |
485 | (cond ((not tail) | |
486 | (push-label! POST) | |
20bdc710 AW |
487 | (maybe-drop))))) |
488 | ||
489 | ((<ghil-reified-env> env loc) | |
490 | (return-object! loc (ghil-env-reify env))))) | |
491 | ||
17e90c5e KN |
492 | ;; |
493 | ;; main | |
67169b29 | 494 | (record-case ghil |
fbde2b91 | 495 | ((<ghil-lambda> env loc vars rest meta body) |
f540e327 AW |
496 | (let* ((evars (ghil-env-variables env)) |
497 | (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) | |
594d9d4c AW |
498 | (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) |
499 | (nargs (allocate-indices-linearly! vars)) | |
cf10678f | 500 | (nlocs (allocate-locals! locs body nargs)) |
594d9d4c | 501 | (nexts (allocate-indices-linearly! exts))) |
ac99cb0c | 502 | ;; meta bindings |
96969dc1 | 503 | (push-bindings! #f vars) |
eb7ea045 AW |
504 | ;; push on definition source location |
505 | (if loc (set! stack (cons (make-glil-source loc) stack))) | |
594d9d4c | 506 | ;; copy args to the heap if they're marked as external |
061f7fae | 507 | (do ((n 0 (1+ n)) |
f540e327 | 508 | (l vars (cdr l))) |
17e90c5e KN |
509 | ((null? l)) |
510 | (let ((v (car l))) | |
aa0a011b AW |
511 | (case (ghil-var-kind v) |
512 | ((external) | |
cf10678f | 513 | (push-code! #f (make-glil-local 'ref n)) |
96969dc1 | 514 | (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) |
17e90c5e KN |
515 | ;; compile body |
516 | (comp body #t #f) | |
517 | ;; create GLIL | |
594d9d4c AW |
518 | (make-glil-program nargs (if rest 1 0) nlocs nexts meta |
519 | (reverse! stack))))))) | |
17e90c5e | 520 | |
594d9d4c | 521 | (define (allocate-indices-linearly! vars) |
17e90c5e | 522 | (do ((n 0 (1+ n)) |
594d9d4c AW |
523 | (l vars (cdr l))) |
524 | ((null? l) n) | |
aa0a011b | 525 | (let ((v (car l))) (set! (ghil-var-index v) n)))) |
594d9d4c | 526 | |
cf10678f AW |
527 | (define (allocate-locals! vars body nargs) |
528 | (let ((free '()) (nlocs nargs)) | |
594d9d4c AW |
529 | (define (allocate! var) |
530 | (cond | |
531 | ((pair? free) | |
532 | (set! (ghil-var-index var) (car free)) | |
533 | (set! free (cdr free))) | |
534 | (else | |
535 | (set! (ghil-var-index var) nlocs) | |
536 | (set! nlocs (1+ nlocs))))) | |
537 | (define (deallocate! var) | |
538 | (set! free (cons (ghil-var-index var) free))) | |
539 | (let lp ((x body)) | |
540 | (record-case x | |
541 | ((<ghil-void>)) | |
542 | ((<ghil-quote>)) | |
543 | ((<ghil-quasiquote> exp) | |
544 | (let qlp ((x exp)) | |
545 | (cond ((list? x) (for-each qlp x)) | |
546 | ((pair? x) (qlp (car x)) (qlp (cdr x))) | |
547 | ((record? x) | |
548 | (record-case x | |
549 | ((<ghil-unquote> exp) (lp exp)) | |
550 | ((<ghil-unquote-splicing> exp) (lp exp))))))) | |
551 | ((<ghil-unquote> exp) | |
552 | (lp exp)) | |
553 | ((<ghil-unquote-splicing> exp) | |
554 | (lp exp)) | |
555 | ((<ghil-reified-env>)) | |
556 | ((<ghil-set> val) | |
557 | (lp val)) | |
558 | ((<ghil-ref>)) | |
559 | ((<ghil-define> val) | |
560 | (lp val)) | |
561 | ((<ghil-if> test then else) | |
562 | (lp test) (lp then) (lp else)) | |
563 | ((<ghil-and> exps) | |
564 | (for-each lp exps)) | |
565 | ((<ghil-or> exps) | |
566 | (for-each lp exps)) | |
567 | ((<ghil-begin> exps) | |
568 | (for-each lp exps)) | |
569 | ((<ghil-bind> vars vals body) | |
570 | (for-each allocate! vars) | |
571 | (for-each lp vals) | |
572 | (lp body) | |
573 | (for-each deallocate! vars)) | |
574 | ((<ghil-mv-bind> vars producer body) | |
575 | (lp producer) | |
576 | (for-each allocate! vars) | |
577 | (lp body) | |
578 | (for-each deallocate! vars)) | |
579 | ((<ghil-inline> args) | |
580 | (for-each lp args)) | |
581 | ((<ghil-call> proc args) | |
582 | (lp proc) | |
583 | (for-each lp args)) | |
584 | ((<ghil-lambda>)) | |
585 | ((<ghil-mv-call> producer consumer) | |
586 | (lp producer) | |
587 | (lp consumer)) | |
588 | ((<ghil-values> values) | |
589 | (for-each lp values)) | |
590 | ((<ghil-values*> values) | |
591 | (for-each lp values)))) | |
592 | nlocs)) |