Commit | Line | Data |
---|---|---|
f1d7723b AW |
1 | ;;; Guile VM assembler |
2 | ||
b912a1cd | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
f1d7723b 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 glil compile-assembly) | |
23 | #:use-module (system base syntax) | |
24 | #:use-module (system base pmatch) | |
25 | #:use-module (language glil) | |
26 | #:use-module (language assembly) | |
27 | #:use-module (system vm instruction) | |
28 | #:use-module ((system vm program) #:select (make-binding)) | |
f1d7723b AW |
29 | #:use-module (ice-9 receive) |
30 | #:use-module ((srfi srfi-1) #:select (fold)) | |
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)) | |
60 | (filename ,new-filename) | |
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 AW |
74 | (compile-assembly |
75 | (make-glil-program 0 0 0 0 '() | |
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. | |
81 | (define (make-open-binding name ext? index) | |
82 | (list name ext? index)) | |
83 | (define (make-closed-binding open-binding start end) | |
84 | (make-binding (car open-binding) (cadr open-binding) | |
85 | (caddr open-binding) start end)) | |
86 | (define (open-binding bindings vars nargs start) | |
87 | (cons | |
88 | (acons start | |
89 | (map | |
90 | (lambda (v) | |
91 | (pmatch v | |
92 | ((,name argument ,i) (make-open-binding name #f i)) | |
93 | ((,name local ,i) (make-open-binding name #f (+ nargs i))) | |
94 | ((,name external ,i) (make-open-binding name #t i)) | |
95 | (else (error "unknown binding type" name type)))) | |
96 | vars) | |
97 | (car bindings)) | |
98 | (cdr bindings))) | |
99 | (define (close-binding bindings end) | |
100 | (pmatch bindings | |
101 | ((((,start . ,closing) . ,open) . ,closed) | |
102 | (cons open | |
103 | (fold (lambda (o tail) | |
104 | ;; the cons is for dsu sort | |
105 | (acons start (make-closed-binding o start end) | |
106 | tail)) | |
107 | closed | |
108 | closing))) | |
109 | (else (error "broken bindings" bindings)))) | |
110 | (define (close-all-bindings bindings end) | |
111 | (if (null? (car bindings)) | |
112 | (map cdr | |
113 | (stable-sort (reverse (cdr bindings)) | |
114 | (lambda (x y) (< (car x) (car y))))) | |
115 | (close-all-bindings (close-binding bindings end) end))) | |
116 | ||
117 | ;; A functional object table. | |
ac47d5f6 | 118 | (define *module* 1) |
53e28ed9 AW |
119 | (define (assoc-ref-or-acons alist x make-y) |
120 | (cond ((assoc-ref alist x) | |
f1d7723b AW |
121 | => (lambda (y) (values y alist))) |
122 | (else | |
123 | (let ((y (make-y x alist))) | |
53e28ed9 | 124 | (values y (acons x y alist)))))) |
f1d7723b | 125 | (define (object-index-and-alist x alist) |
53e28ed9 | 126 | (assoc-ref-or-acons alist x |
f1d7723b | 127 | (lambda (x alist) |
ac47d5f6 | 128 | (+ (length alist) *module*)))) |
f1d7723b AW |
129 | |
130 | (define (compile-assembly glil) | |
131 | (receive (code . _) | |
1005628a | 132 | (glil->assembly glil 0 '() '(()) '() '() #f -1) |
f1d7723b | 133 | (car code))) |
ac47d5f6 AW |
134 | (define (make-object-table objects) |
135 | (and (not (null? objects)) | |
136 | (list->vector (cons #f objects)))) | |
f1d7723b AW |
137 | |
138 | (define (glil->assembly glil nargs nexts-stack bindings | |
139 | source-alist label-alist object-alist addr) | |
140 | (define (emit-code x) | |
194566b0 | 141 | (values (map assembly-pack x) bindings source-alist label-alist object-alist)) |
f1d7723b | 142 | (define (emit-code/object x object-alist) |
194566b0 | 143 | (values (map assembly-pack x) bindings source-alist label-alist object-alist)) |
f1d7723b AW |
144 | |
145 | (record-case glil | |
53e28ed9 AW |
146 | ((<glil-program> nargs nrest nlocs nexts meta body closure-level) |
147 | (let ((toplevel? (null? nexts-stack))) | |
148 | (define (process-body) | |
149 | (let ((nexts-stack (cons nexts nexts-stack))) | |
150 | (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) | |
151 | (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) | |
152 | (cond | |
153 | ((null? body) | |
154 | (values (reverse code) | |
155 | (close-all-bindings bindings addr) | |
028e3d06 | 156 | (limn-sources (reverse! source-alist)) |
53e28ed9 AW |
157 | (reverse label-alist) |
158 | (and object-alist (map car (reverse object-alist))) | |
159 | addr)) | |
160 | (else | |
161 | (receive (subcode bindings source-alist label-alist object-alist) | |
162 | (glil->assembly (car body) nargs nexts-stack bindings | |
163 | source-alist label-alist object-alist addr) | |
164 | (lp (cdr body) (append (reverse subcode) code) | |
165 | bindings source-alist label-alist object-alist | |
2cf1705c | 166 | (addr+ addr subcode)))))))) |
53e28ed9 AW |
167 | |
168 | (receive (code bindings sources labels objects len) | |
169 | (process-body) | |
170 | (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels | |
ac47d5f6 AW |
171 | ,len |
172 | ,(make-meta bindings sources meta) | |
173 | . ,code))) | |
f1d7723b | 174 | (cond |
53e28ed9 AW |
175 | (toplevel? |
176 | ;; toplevel bytecode isn't loaded by the vm, no way to do | |
177 | ;; object table or closure capture (not in the bytecode, | |
178 | ;; anyway) | |
1005628a | 179 | (emit-code (align-program prog addr))) |
f1d7723b | 180 | (else |
ac47d5f6 | 181 | (let ((table (dump-object (make-object-table objects) addr)) |
53e28ed9 AW |
182 | (closure (if (> closure-level 0) '((make-closure)) '()))) |
183 | (cond | |
184 | (object-alist | |
185 | ;; if we are being compiled from something with an object | |
186 | ;; table, cache the program there | |
187 | (receive (i object-alist) | |
2cf1705c | 188 | (object-index-and-alist (make-subprogram table prog) |
53e28ed9 AW |
189 | object-alist) |
190 | (emit-code/object `((object-ref ,i) ,@closure) | |
191 | object-alist))) | |
192 | (else | |
193 | ;; otherwise emit a load directly | |
1005628a AW |
194 | (emit-code `(,@table ,@(align-program prog (addr+ addr table)) |
195 | ,@closure))))))))))) | |
f1d7723b AW |
196 | |
197 | ((<glil-bind> vars) | |
198 | (values '() | |
199 | (open-binding bindings vars nargs addr) | |
200 | source-alist | |
201 | label-alist | |
202 | object-alist)) | |
203 | ||
204 | ((<glil-mv-bind> vars rest) | |
205 | (values `((truncate-values ,(length vars) ,(if rest 1 0))) | |
206 | (open-binding bindings vars nargs addr) | |
207 | source-alist | |
208 | label-alist | |
209 | object-alist)) | |
210 | ||
211 | ((<glil-unbind>) | |
212 | (values '() | |
213 | (close-binding bindings addr) | |
214 | source-alist | |
215 | label-alist | |
216 | object-alist)) | |
217 | ||
028e3d06 | 218 | ((<glil-source> props) |
f1d7723b AW |
219 | (values '() |
220 | bindings | |
028e3d06 | 221 | (acons addr props source-alist) |
f1d7723b AW |
222 | label-alist |
223 | object-alist)) | |
224 | ||
225 | ((<glil-void>) | |
226 | (emit-code '((void)))) | |
227 | ||
228 | ((<glil-const> obj) | |
229 | (cond | |
4b318482 | 230 | ((object->assembly obj) |
f1d7723b AW |
231 | => (lambda (code) |
232 | (emit-code (list code)))) | |
233 | ((not object-alist) | |
234 | (emit-code (dump-object obj addr))) | |
235 | (else | |
236 | (receive (i object-alist) | |
237 | (object-index-and-alist obj object-alist) | |
238 | (emit-code/object `((object-ref ,i)) | |
239 | object-alist))))) | |
240 | ||
241 | ((<glil-argument> op index) | |
242 | (emit-code (if (eq? op 'ref) | |
243 | `((local-ref ,index)) | |
244 | `((local-set ,index))))) | |
245 | ||
246 | ((<glil-local> op index) | |
247 | (emit-code (if (eq? op 'ref) | |
248 | `((local-ref ,(+ nargs index))) | |
249 | `((local-set ,(+ nargs index)))))) | |
250 | ||
251 | ((<glil-external> op depth index) | |
252 | (emit-code (let lp ((d depth) (n 0) (stack nexts-stack)) | |
253 | (if (> d 0) | |
254 | (lp (1- d) (+ n (car stack)) (cdr stack)) | |
255 | (if (eq? op 'ref) | |
256 | `((external-ref ,(+ n index))) | |
257 | `((external-set ,(+ n index)))))))) | |
258 | ||
259 | ((<glil-toplevel> op name) | |
260 | (case op | |
261 | ((ref set) | |
262 | (cond | |
263 | ((not object-alist) | |
264 | (emit-code `(,@(dump-object name addr) | |
265 | (link-now) | |
266 | ,(case op | |
267 | ((ref) '(variable-ref)) | |
268 | ((set) '(variable-set)))))) | |
269 | (else | |
270 | (receive (i object-alist) | |
271 | (object-index-and-alist (make-variable-cache-cell name) | |
272 | object-alist) | |
273 | (emit-code/object (case op | |
274 | ((ref) `((toplevel-ref ,i))) | |
275 | ((set) `((toplevel-set ,i)))) | |
276 | object-alist))))) | |
277 | ((define) | |
278 | (emit-code `((define ,(symbol->string name)) | |
279 | (variable-set)))) | |
280 | (else | |
281 | (error "unknown toplevel var kind" op name)))) | |
282 | ||
283 | ((<glil-module> op mod name public?) | |
284 | (let ((key (list mod name public?))) | |
285 | (case op | |
286 | ((ref set) | |
287 | (cond | |
288 | ((not object-alist) | |
289 | (emit-code `(,@(dump-object key addr) | |
290 | (link-now) | |
291 | ,(case op | |
292 | ((ref) '(variable-ref)) | |
293 | ((set) '(variable-set)))))) | |
294 | (else | |
295 | (receive (i object-alist) | |
53e28ed9 | 296 | (object-index-and-alist (make-variable-cache-cell key) |
f1d7723b AW |
297 | object-alist) |
298 | (emit-code/object (case op | |
299 | ((ref) `((toplevel-ref ,i))) | |
300 | ((set) `((toplevel-set ,i)))) | |
301 | object-alist))))) | |
302 | (else | |
303 | (error "unknown module var kind" op key))))) | |
304 | ||
305 | ((<glil-label> label) | |
306 | (values '() | |
307 | bindings | |
308 | source-alist | |
309 | (acons label addr label-alist) | |
310 | object-alist)) | |
311 | ||
312 | ((<glil-branch> inst label) | |
313 | (emit-code `((,inst ,label)))) | |
314 | ||
315 | ;; nargs is number of stack args to insn. probably should rename. | |
316 | ((<glil-call> inst nargs) | |
317 | (if (not (instruction? inst)) | |
318 | (error "Unknown instruction:" inst)) | |
319 | (let ((pops (instruction-pops inst))) | |
320 | (cond ((< pops 0) | |
321 | (emit-code `((,inst ,nargs)))) | |
322 | ((= pops nargs) | |
323 | (emit-code `((,inst)))) | |
324 | (else | |
325 | (error "Wrong number of stack arguments to instruction:" inst nargs))))) | |
326 | ||
327 | ((<glil-mv-call> nargs ra) | |
328 | (emit-code `((mv-call ,nargs ,ra)))))) | |
329 | ||
f1d7723b AW |
330 | (define (dump-object x addr) |
331 | (define (too-long x) | |
332 | (error (string-append x " too long"))) | |
333 | ||
2cf1705c AW |
334 | (cond |
335 | ((object->assembly x) => list) | |
336 | ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr)) | |
337 | ((subprogram? x) | |
338 | `(,@(subprogram-table x) | |
339 | ,@(align-program (subprogram-prog x) | |
340 | (addr+ addr (subprogram-table x))))) | |
341 | ((and (integer? x) (exact? x)) | |
342 | (let ((str (do ((n x (quotient n 256)) | |
343 | (l '() (cons (modulo n 256) l))) | |
344 | ((= n 0) | |
345 | (list->string (map integer->char l)))))) | |
b912a1cd LC |
346 | (if (< x 0) |
347 | `((load-integer ,str)) | |
348 | `((load-unsigned-integer ,str))))) | |
2cf1705c AW |
349 | ((number? x) |
350 | `((load-number ,(number->string x)))) | |
351 | ((string? x) | |
352 | `((load-string ,x))) | |
353 | ((symbol? x) | |
354 | `((load-symbol ,(symbol->string x)))) | |
355 | ((keyword? x) | |
356 | `((load-keyword ,(symbol->string (keyword->symbol x))))) | |
357 | ((list? x) | |
358 | (let ((tail (let ((len (length x))) | |
359 | (if (>= len 65536) (too-long "list")) | |
360 | `((list ,(quotient len 256) ,(modulo len 256)))))) | |
361 | (let dump-objects ((objects x) (codes '()) (addr addr)) | |
362 | (if (null? objects) | |
363 | (fold append tail codes) | |
364 | (let ((code (dump-object (car objects) addr))) | |
365 | (dump-objects (cdr objects) (cons code codes) | |
366 | (addr+ addr code))))))) | |
367 | ((pair? x) | |
368 | (let ((kar (dump-object (car x) addr))) | |
369 | `(,@kar | |
370 | ,@(dump-object (cdr x) (addr+ addr kar)) | |
371 | (cons)))) | |
372 | ((vector? x) | |
373 | (let* ((len (vector-length x)) | |
374 | (tail (if (>= len 65536) | |
375 | (too-long "vector") | |
376 | `((vector ,(quotient len 256) ,(modulo len 256)))))) | |
377 | (let dump-objects ((i 0) (codes '()) (addr addr)) | |
378 | (if (>= i len) | |
379 | (fold append tail codes) | |
380 | (let ((code (dump-object (vector-ref x i) addr))) | |
381 | (dump-objects (1+ i) (cons code codes) | |
382 | (addr+ addr code))))))) | |
383 | (else | |
384 | (error "assemble: unrecognized object" x)))) | |
f1d7723b | 385 |