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