Commit | Line | Data |
---|---|---|
f1d7723b AW |
1 | ;;; Guile VM assembler |
2 | ||
b912a1cd | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
f1d7723b | 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 | |
f1d7723b AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language glil compile-assembly) | |
22 | #:use-module (system base syntax) | |
23 | #:use-module (system base pmatch) | |
24 | #:use-module (language glil) | |
25 | #:use-module (language assembly) | |
26 | #:use-module (system vm instruction) | |
27 | #:use-module ((system vm program) #:select (make-binding)) | |
f1d7723b AW |
28 | #:use-module (ice-9 receive) |
29 | #:use-module ((srfi srfi-1) #:select (fold)) | |
782a82ee | 30 | #:use-module (rnrs bytevector) |
f1d7723b AW |
31 | #:export (compile-assembly)) |
32 | ||
33 | ;; Variable cache cells go in the object table, and serialize as their | |
34 | ;; keys. The reason we wrap the keys in these records is so they don't | |
35 | ;; compare as `equal?' to other objects in the object table. | |
36 | ;; | |
37 | ;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?) | |
38 | ||
39 | (define-record <variable-cache-cell> key) | |
40 | ||
41 | ;; Subprograms can be loaded into an object table as well. We need a | |
2cf1705c AW |
42 | ;; disjoint type here too. (Subprograms have their own object tables -- |
43 | ;; though probably we should just make one table per compilation unit.) | |
f1d7723b | 44 | |
2cf1705c | 45 | (define-record <subprogram> table prog) |
f1d7723b AW |
46 | |
47 | ||
028e3d06 AW |
48 | (define (limn-sources sources) |
49 | (let lp ((in sources) (out '()) (filename #f)) | |
50 | (if (null? in) | |
51 | (reverse! out) | |
52 | (let ((addr (caar in)) | |
53 | (new-filename (assq-ref (cdar in ) 'filename)) | |
54 | (line (assq-ref (cdar in) 'line)) | |
55 | (column (assq-ref (cdar in) 'column))) | |
56 | (cond | |
57 | ((not (equal? new-filename filename)) | |
58 | (lp (cdr in) | |
59 | `((,addr . (,line . ,column)) | |
ff33605d | 60 | (filename . ,new-filename) |
028e3d06 AW |
61 | . ,out) |
62 | new-filename)) | |
63 | ((or (null? out) (not (equal? (cdar out) `(,line . ,column)))) | |
64 | (lp (cdr in) | |
65 | `((,addr . (,line . ,column)) | |
66 | . ,out) | |
67 | filename)) | |
68 | (else | |
69 | (lp (cdr in) out filename))))))) | |
70 | ||
f1d7723b AW |
71 | (define (make-meta bindings sources tail) |
72 | (if (and (null? bindings) (null? sources) (null? tail)) | |
73 | #f | |
ac47d5f6 | 74 | (compile-assembly |
476e3572 | 75 | (make-glil-program 0 0 0 '() |
ac47d5f6 AW |
76 | (list |
77 | (make-glil-const `(,bindings ,sources ,@tail)) | |
131f7d6c | 78 | (make-glil-call 'return 1)))))) |
f1d7723b AW |
79 | |
80 | ;; A functional stack of names of live variables. | |
66d3e9a3 AW |
81 | (define (make-open-binding name boxed? index) |
82 | (list name boxed? index)) | |
f1d7723b AW |
83 | (define (make-closed-binding open-binding start end) |
84 | (make-binding (car open-binding) (cadr open-binding) | |
85 | (caddr open-binding) start end)) | |
cf10678f | 86 | (define (open-binding bindings vars start) |
f1d7723b AW |
87 | (cons |
88 | (acons start | |
89 | (map | |
90 | (lambda (v) | |
91 | (pmatch v | |
66d3e9a3 AW |
92 | ((,name ,boxed? ,i) |
93 | (make-open-binding name boxed? i)) | |
cf10678f | 94 | (else (error "unknown binding type" v)))) |
f1d7723b AW |
95 | vars) |
96 | (car bindings)) | |
97 | (cdr bindings))) | |
98 | (define (close-binding bindings end) | |
99 | (pmatch bindings | |
100 | ((((,start . ,closing) . ,open) . ,closed) | |
101 | (cons open | |
102 | (fold (lambda (o tail) | |
103 | ;; the cons is for dsu sort | |
104 | (acons start (make-closed-binding o start end) | |
105 | tail)) | |
106 | closed | |
107 | closing))) | |
108 | (else (error "broken bindings" bindings)))) | |
109 | (define (close-all-bindings bindings end) | |
110 | (if (null? (car bindings)) | |
111 | (map cdr | |
112 | (stable-sort (reverse (cdr bindings)) | |
113 | (lambda (x y) (< (car x) (car y))))) | |
114 | (close-all-bindings (close-binding bindings end) end))) | |
115 | ||
116 | ;; A functional object table. | |
ac47d5f6 | 117 | (define *module* 1) |
53e28ed9 AW |
118 | (define (assoc-ref-or-acons alist x make-y) |
119 | (cond ((assoc-ref alist x) | |
f1d7723b AW |
120 | => (lambda (y) (values y alist))) |
121 | (else | |
122 | (let ((y (make-y x alist))) | |
53e28ed9 | 123 | (values y (acons x y alist)))))) |
f1d7723b | 124 | (define (object-index-and-alist x alist) |
53e28ed9 | 125 | (assoc-ref-or-acons alist x |
f1d7723b | 126 | (lambda (x alist) |
ac47d5f6 | 127 | (+ (length alist) *module*)))) |
f1d7723b AW |
128 | |
129 | (define (compile-assembly glil) | |
130 | (receive (code . _) | |
476e3572 | 131 | (glil->assembly glil #t '(()) '() '() #f -1) |
f1d7723b | 132 | (car code))) |
ac47d5f6 AW |
133 | (define (make-object-table objects) |
134 | (and (not (null? objects)) | |
135 | (list->vector (cons #f objects)))) | |
f1d7723b | 136 | |
476e3572 | 137 | (define (glil->assembly glil toplevel? bindings |
f1d7723b AW |
138 | source-alist label-alist object-alist addr) |
139 | (define (emit-code x) | |
194566b0 | 140 | (values (map assembly-pack x) bindings source-alist label-alist object-alist)) |
f1d7723b | 141 | (define (emit-code/object x object-alist) |
194566b0 | 142 | (values (map assembly-pack x) bindings source-alist label-alist object-alist)) |
f1d7723b AW |
143 | |
144 | (record-case glil | |
476e3572 AW |
145 | ((<glil-program> nargs nrest nlocs meta body) |
146 | (define (process-body) | |
147 | (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) | |
148 | (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) | |
149 | (cond | |
150 | ((null? body) | |
151 | (values (reverse code) | |
152 | (close-all-bindings bindings addr) | |
153 | (limn-sources (reverse! source-alist)) | |
154 | (reverse label-alist) | |
155 | (and object-alist (map car (reverse object-alist))) | |
156 | addr)) | |
157 | (else | |
158 | (receive (subcode bindings source-alist label-alist object-alist) | |
159 | (glil->assembly (car body) #f bindings | |
160 | source-alist label-alist object-alist addr) | |
161 | (lp (cdr body) (append (reverse subcode) code) | |
162 | bindings source-alist label-alist object-alist | |
163 | (addr+ addr subcode))))))) | |
164 | ||
165 | (receive (code bindings sources labels objects len) | |
166 | (process-body) | |
167 | (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels | |
168 | ,len | |
169 | ,(make-meta bindings sources meta) | |
170 | . ,code))) | |
171 | (cond | |
172 | (toplevel? | |
173 | ;; toplevel bytecode isn't loaded by the vm, no way to do | |
174 | ;; object table or closure capture (not in the bytecode, | |
175 | ;; anyway) | |
176 | (emit-code (align-program prog addr))) | |
177 | (else | |
9efc2d14 | 178 | (let ((table (make-object-table objects))) |
53e28ed9 | 179 | (cond |
476e3572 AW |
180 | (object-alist |
181 | ;; if we are being compiled from something with an object | |
182 | ;; table, cache the program there | |
183 | (receive (i object-alist) | |
184 | (object-index-and-alist (make-subprogram table prog) | |
185 | object-alist) | |
186 | (emit-code/object `(,(if (< i 256) | |
187 | `(object-ref ,i) | |
188 | `(long-object-ref ,(quotient i 256) | |
189 | ,(modulo i 256)))) | |
190 | object-alist))) | |
53e28ed9 | 191 | (else |
476e3572 | 192 | ;; otherwise emit a load directly |
9efc2d14 AW |
193 | (let ((table-code (dump-object table addr))) |
194 | (emit-code | |
195 | `(,@table-code | |
196 | ,@(align-program prog (addr+ addr table-code))))))))))))) | |
f1d7723b AW |
197 | |
198 | ((<glil-bind> vars) | |
199 | (values '() | |
cf10678f | 200 | (open-binding bindings vars addr) |
f1d7723b AW |
201 | source-alist |
202 | label-alist | |
203 | object-alist)) | |
204 | ||
205 | ((<glil-mv-bind> vars rest) | |
206 | (values `((truncate-values ,(length vars) ,(if rest 1 0))) | |
cf10678f | 207 | (open-binding bindings vars addr) |
f1d7723b AW |
208 | source-alist |
209 | label-alist | |
210 | object-alist)) | |
211 | ||
212 | ((<glil-unbind>) | |
213 | (values '() | |
214 | (close-binding bindings addr) | |
215 | source-alist | |
216 | label-alist | |
217 | object-alist)) | |
218 | ||
028e3d06 | 219 | ((<glil-source> props) |
f1d7723b AW |
220 | (values '() |
221 | bindings | |
028e3d06 | 222 | (acons addr props source-alist) |
f1d7723b AW |
223 | label-alist |
224 | object-alist)) | |
225 | ||
226 | ((<glil-void>) | |
227 | (emit-code '((void)))) | |
228 | ||
229 | ((<glil-const> obj) | |
230 | (cond | |
4b318482 | 231 | ((object->assembly obj) |
f1d7723b AW |
232 | => (lambda (code) |
233 | (emit-code (list code)))) | |
234 | ((not object-alist) | |
235 | (emit-code (dump-object obj addr))) | |
236 | (else | |
237 | (receive (i object-alist) | |
238 | (object-index-and-alist obj object-alist) | |
a9b0f876 AW |
239 | (emit-code/object (if (< i 256) |
240 | `((object-ref ,i)) | |
241 | `((long-object-ref ,(quotient i 256) | |
242 | ,(modulo i 256)))) | |
f1d7723b AW |
243 | object-alist))))) |
244 | ||
66d3e9a3 AW |
245 | ((<glil-lexical> local? boxed? op index) |
246 | (emit-code | |
80545853 AW |
247 | (if local? |
248 | (if (< index 256) | |
249 | `((,(case op | |
250 | ((ref) (if boxed? 'local-boxed-ref 'local-ref)) | |
251 | ((set) (if boxed? 'local-boxed-set 'local-set)) | |
252 | ((box) 'box) | |
253 | ((empty-box) 'empty-box) | |
254 | (else (error "what" op))) | |
255 | ,index)) | |
256 | (let ((a (quotient i 256)) | |
257 | (b (modulo i 256))) | |
258 | `((,(case op | |
259 | ((ref) | |
260 | (if boxed? | |
261 | `((long-local-ref ,a ,b) | |
262 | (variable-ref)) | |
263 | `((long-local-ref ,a ,b)))) | |
264 | ((set) | |
265 | (if boxed? | |
266 | `((long-local-ref ,a ,b) | |
267 | (variable-set)) | |
268 | `((long-local-set ,a ,b)))) | |
269 | ((box) | |
270 | `((make-variable) | |
271 | (variable-set) | |
272 | (long-local-set ,a ,b))) | |
273 | ((empty-box) | |
274 | `((make-variable) | |
275 | (long-local-set ,a ,b))) | |
276 | (else (error "what" op))) | |
277 | ,index)))) | |
278 | `((,(case op | |
57ab0671 AW |
279 | ((ref) (if boxed? 'free-boxed-ref 'free-ref)) |
280 | ((set) (if boxed? 'free-boxed-set (error "what." glil))) | |
80545853 AW |
281 | (else (error "what" op))) |
282 | ,index))))) | |
66d3e9a3 | 283 | |
f1d7723b AW |
284 | ((<glil-toplevel> op name) |
285 | (case op | |
286 | ((ref set) | |
287 | (cond | |
288 | ((not object-alist) | |
289 | (emit-code `(,@(dump-object name addr) | |
290 | (link-now) | |
291 | ,(case op | |
292 | ((ref) '(variable-ref)) | |
293 | ((set) '(variable-set)))))) | |
294 | (else | |
295 | (receive (i object-alist) | |
296 | (object-index-and-alist (make-variable-cache-cell name) | |
297 | object-alist) | |
a9b0f876 AW |
298 | (emit-code/object (if (< i 256) |
299 | `((,(case op | |
300 | ((ref) 'toplevel-ref) | |
301 | ((set) 'toplevel-set)) | |
302 | ,i)) | |
303 | `((,(case op | |
304 | ((ref) 'long-toplevel-ref) | |
305 | ((set) 'long-toplevel-set)) | |
306 | ,(quotient i 256) | |
307 | ,(modulo i 256)))) | |
f1d7723b AW |
308 | object-alist))))) |
309 | ((define) | |
310 | (emit-code `((define ,(symbol->string name)) | |
311 | (variable-set)))) | |
312 | (else | |
313 | (error "unknown toplevel var kind" op name)))) | |
314 | ||
315 | ((<glil-module> op mod name public?) | |
316 | (let ((key (list mod name public?))) | |
317 | (case op | |
318 | ((ref set) | |
319 | (cond | |
320 | ((not object-alist) | |
321 | (emit-code `(,@(dump-object key addr) | |
322 | (link-now) | |
323 | ,(case op | |
324 | ((ref) '(variable-ref)) | |
325 | ((set) '(variable-set)))))) | |
326 | (else | |
327 | (receive (i object-alist) | |
53e28ed9 | 328 | (object-index-and-alist (make-variable-cache-cell key) |
f1d7723b AW |
329 | object-alist) |
330 | (emit-code/object (case op | |
331 | ((ref) `((toplevel-ref ,i))) | |
332 | ((set) `((toplevel-set ,i)))) | |
333 | object-alist))))) | |
334 | (else | |
335 | (error "unknown module var kind" op key))))) | |
336 | ||
337 | ((<glil-label> label) | |
338 | (values '() | |
339 | bindings | |
340 | source-alist | |
341 | (acons label addr label-alist) | |
342 | object-alist)) | |
343 | ||
344 | ((<glil-branch> inst label) | |
345 | (emit-code `((,inst ,label)))) | |
346 | ||
347 | ;; nargs is number of stack args to insn. probably should rename. | |
348 | ((<glil-call> inst nargs) | |
349 | (if (not (instruction? inst)) | |
350 | (error "Unknown instruction:" inst)) | |
351 | (let ((pops (instruction-pops inst))) | |
352 | (cond ((< pops 0) | |
c11f46af AW |
353 | (case (instruction-length inst) |
354 | ((1) (emit-code `((,inst ,nargs)))) | |
355 | ((2) (emit-code `((,inst ,(quotient nargs 256) | |
356 | ,(modulo nargs 256))))) | |
357 | (else (error "Unknown length for variable-arg instruction:" | |
358 | inst (instruction-length inst))))) | |
f1d7723b AW |
359 | ((= pops nargs) |
360 | (emit-code `((,inst)))) | |
361 | (else | |
362 | (error "Wrong number of stack arguments to instruction:" inst nargs))))) | |
363 | ||
364 | ((<glil-mv-call> nargs ra) | |
365 | (emit-code `((mv-call ,nargs ,ra)))))) | |
366 | ||
f1d7723b AW |
367 | (define (dump-object x addr) |
368 | (define (too-long x) | |
369 | (error (string-append x " too long"))) | |
370 | ||
2cf1705c AW |
371 | (cond |
372 | ((object->assembly x) => list) | |
373 | ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr)) | |
374 | ((subprogram? x) | |
9efc2d14 AW |
375 | (let ((table-code (dump-object (subprogram-table x) addr))) |
376 | `(,@table-code | |
377 | ,@(align-program (subprogram-prog x) | |
378 | (addr+ addr table-code))))) | |
2cf1705c AW |
379 | ((number? x) |
380 | `((load-number ,(number->string x)))) | |
381 | ((string? x) | |
382 | `((load-string ,x))) | |
383 | ((symbol? x) | |
384 | `((load-symbol ,(symbol->string x)))) | |
385 | ((keyword? x) | |
386 | `((load-keyword ,(symbol->string (keyword->symbol x))))) | |
387 | ((list? x) | |
388 | (let ((tail (let ((len (length x))) | |
389 | (if (>= len 65536) (too-long "list")) | |
390 | `((list ,(quotient len 256) ,(modulo len 256)))))) | |
391 | (let dump-objects ((objects x) (codes '()) (addr addr)) | |
392 | (if (null? objects) | |
393 | (fold append tail codes) | |
394 | (let ((code (dump-object (car objects) addr))) | |
395 | (dump-objects (cdr objects) (cons code codes) | |
396 | (addr+ addr code))))))) | |
397 | ((pair? x) | |
398 | (let ((kar (dump-object (car x) addr))) | |
399 | `(,@kar | |
400 | ,@(dump-object (cdr x) (addr+ addr kar)) | |
401 | (cons)))) | |
402 | ((vector? x) | |
403 | (let* ((len (vector-length x)) | |
404 | (tail (if (>= len 65536) | |
405 | (too-long "vector") | |
406 | `((vector ,(quotient len 256) ,(modulo len 256)))))) | |
407 | (let dump-objects ((i 0) (codes '()) (addr addr)) | |
408 | (if (>= i len) | |
409 | (fold append tail codes) | |
410 | (let ((code (dump-object (vector-ref x i) addr))) | |
411 | (dump-objects (1+ i) (cons code codes) | |
412 | (addr+ addr code))))))) | |
782a82ee AW |
413 | ((and (array? x) (symbol? (array-type x))) |
414 | (let* ((type (dump-object (array-type x) addr)) | |
415 | (shape (dump-object (array-shape x) (addr+ addr type)))) | |
416 | `(,@type | |
417 | ,@shape | |
418 | ,@(align-code | |
419 | `(load-array ,(uniform-array->bytevector x)) | |
420 | (addr+ (addr+ addr type) shape) | |
421 | 8 | |
422 | 4)))) | |
2cf1705c AW |
423 | (else |
424 | (error "assemble: unrecognized object" x)))) | |
f1d7723b | 425 |