Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Guile VM assembler |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
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 (system vm assemble) | |
1a1a10d3 AW |
23 | #:use-syntax (system base syntax) |
24 | #:use-module (system il glil) | |
25 | #:use-module (system vm instruction) | |
26 | #:use-module (system vm objcode) | |
27 | #:use-module ((system vm program) #:select (make-binding)) | |
28 | #:use-module (system vm conv) | |
29 | #:use-module (ice-9 regex) | |
30 | #:use-module (ice-9 common-list) | |
31 | #:use-module (srfi srfi-4) | |
32 | #:use-module ((srfi srfi-1) #:select (append-map)) | |
33 | #:export (preprocess codegen assemble)) | |
17e90c5e KN |
34 | |
35 | (define (assemble glil env . opts) | |
4bfb26f5 | 36 | (codegen (preprocess glil #f) #t)) |
17e90c5e KN |
37 | |
38 | \f | |
39 | ;;; | |
40 | ;;; Types | |
41 | ;;; | |
42 | ||
ac99cb0c KN |
43 | (define-record (<vm-asm> venv glil body)) |
44 | (define-record (<venv> parent nexts closure?)) | |
fd358575 AW |
45 | ;; key is either a symbol or the list (MODNAME SYM PUBLIC?) |
46 | (define-record (<vlink-now> key)) | |
47 | (define-record (<vlink-later> key)) | |
a1122f8c | 48 | (define-record (<vdefine> name)) |
ac99cb0c | 49 | (define-record (<bytespec> vars bytes meta objs closure?)) |
17e90c5e KN |
50 | |
51 | \f | |
52 | ;;; | |
53 | ;;; Stage 1: Preprocess | |
54 | ;;; | |
55 | ||
56 | (define (preprocess x e) | |
1aa0dd2b | 57 | (record-case x |
fbde2b91 | 58 | ((<glil-asm> vars meta body) |
1a1a10d3 | 59 | (let* ((venv (make-venv #:parent e #:nexts (glil-vars-nexts vars) #:closure? #f)) |
17e90c5e | 60 | (body (map (lambda (x) (preprocess x venv)) body))) |
1a1a10d3 | 61 | (make-vm-asm #:venv venv #:glil x #:body body))) |
1aa0dd2b | 62 | ((<glil-external> op depth index) |
0b5f0e49 | 63 | (do ((d depth (- d 1)) |
f540e327 | 64 | (e e (venv-parent e))) |
b6368dbb | 65 | ((= d 0)) |
f540e327 | 66 | (set! (venv-closure? e) #t)) |
17e90c5e | 67 | x) |
b6368dbb | 68 | (else x))) |
17e90c5e KN |
69 | |
70 | \f | |
71 | ;;; | |
72 | ;;; Stage 2: Bytecode generation | |
73 | ;;; | |
74 | ||
13906f97 AW |
75 | (define-macro (push x loc) |
76 | `(set! ,loc (cons ,x ,loc))) | |
02b1883e AW |
77 | (define-macro (pop loc) |
78 | `(let ((_x (car ,loc))) (set! ,loc (cdr ,loc)) _x)) | |
13906f97 AW |
79 | |
80 | ;; this is to avoid glil-const's desire to put constants in the object | |
81 | ;; array -- instead we explicitly want them in the code, because meta | |
82 | ;; info is infrequently used. to load it up always would make garbage, | |
83 | ;; needlessly. so hide it behind a lambda. | |
84 | (define (make-meta bindings sources tail) | |
85 | (if (and (null? bindings) (null? sources) (null? tail)) | |
86 | #f | |
87 | (let ((stack '())) | |
88 | (define (push-code! code) | |
89 | (push (code->bytes code) stack)) | |
90 | (dump-object! push-code! `(,bindings ,sources ,@tail)) | |
91 | (push-code! '(return)) | |
1a1a10d3 AW |
92 | (make-bytespec #:vars (make-glil-vars 0 0 0 0) |
93 | #:bytes (stack->bytes (reverse! stack) '()) | |
94 | #:meta #f #:objs #f #:closure? #f)))) | |
13906f97 | 95 | |
efbd5892 AW |
96 | (define (byte-length x) |
97 | (cond ((u8vector? x) (u8vector-length x)) | |
98 | ((>= (instruction-length (car x)) 0) | |
99 | ;; one byte for the instruction itself | |
100 | (1+ (instruction-length (car x)))) | |
101 | (else (error "variable-length instruction?" x)))) | |
102 | ||
17e90c5e | 103 | (define (codegen glil toplevel) |
1aa0dd2b | 104 | (record-case glil |
fbde2b91 | 105 | ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body? |
17e90c5e | 106 | (let ((stack '()) |
02b1883e AW |
107 | (open-bindings '()) |
108 | (closed-bindings '()) | |
ac99cb0c | 109 | (source-alist '()) |
17e90c5e | 110 | (label-alist '()) |
3616e9e9 | 111 | (object-alist '())) |
17e90c5e | 112 | (define (push-code! code) |
2d80426a | 113 | ; (format #t "push-code! ~a~%" code) |
13906f97 | 114 | (push (code->bytes code) stack)) |
206a0622 | 115 | (define (push-object! x) |
880ed584 | 116 | (cond ((object->code x) => push-code!) |
13906f97 AW |
117 | (toplevel |
118 | (dump-object! push-code! x)) | |
f0c99935 | 119 | (else |
880ed584 KN |
120 | (let ((i (cond ((object-assoc x object-alist) => cdr) |
121 | (else | |
122 | (let ((i (length object-alist))) | |
123 | (set! object-alist (acons x i object-alist)) | |
124 | i))))) | |
125 | (push-code! `(object-ref ,i)))))) | |
02b1883e AW |
126 | (define (munge-bindings bindings nargs) |
127 | (map | |
128 | (lambda (v) | |
129 | (let ((name (car v)) (type (cadr v)) (i (caddr v))) | |
130 | (case type | |
131 | ((argument) (make-binding name #f i)) | |
132 | ((local) (make-binding name #f (+ nargs i))) | |
133 | ((external) (make-binding name #t i)) | |
134 | (else (error "unknown binding type" name type))))) | |
135 | bindings)) | |
136 | (define (push-bindings! bindings) | |
137 | (push (cons (current-address) bindings) open-bindings)) | |
138 | (define (close-binding!) | |
139 | (let* ((bindings (pop open-bindings)) | |
140 | (start (car bindings)) | |
141 | (end (current-address))) | |
142 | (for-each | |
143 | (lambda (binding) | |
144 | (push `(,start ,@binding ,start ,end) closed-bindings)) | |
145 | (cdr bindings)))) | |
146 | (define (finish-bindings!) | |
147 | (while (not (null? open-bindings)) (close-binding!)) | |
148 | (set! closed-bindings | |
149 | (stable-sort! (reverse! closed-bindings) | |
150 | (lambda (x y) (< (car x) (car y))))) | |
151 | (set! closed-bindings (map cdr closed-bindings))) | |
ac99cb0c | 152 | (define (current-address) |
ac99cb0c | 153 | (apply + (map byte-length stack))) |
17e90c5e | 154 | (define (generate-code x) |
1aa0dd2b AW |
155 | (record-case x |
156 | ((<vm-asm> venv) | |
f0c99935 | 157 | (push-object! (codegen x #f)) |
f540e327 | 158 | (if (venv-closure? venv) (push-code! `(make-closure)))) |
ac99cb0c | 159 | |
f540e327 | 160 | ((<glil-bind> (binds vars)) |
02b1883e | 161 | (push-bindings! (munge-bindings binds (glil-vars-nargs vars)))) |
ac99cb0c | 162 | |
d51406fe | 163 | ((<glil-mv-bind> (binds vars) rest) |
02b1883e AW |
164 | (push-bindings! (munge-bindings binds (glil-vars-nargs vars))) |
165 | (push-code! `(truncate-values ,(length binds) ,(if rest 1 0)))) | |
d51406fe | 166 | |
1aa0dd2b | 167 | ((<glil-unbind>) |
02b1883e | 168 | (close-binding!)) |
ac99cb0c | 169 | |
1aa0dd2b | 170 | ((<glil-source> loc) |
ac99cb0c | 171 | (set! source-alist (acons (current-address) loc source-alist))) |
17e90c5e | 172 | |
1aa0dd2b | 173 | ((<glil-void>) |
41f248a8 | 174 | (push-code! '(void))) |
17e90c5e | 175 | |
f540e327 AW |
176 | ((<glil-const> obj) |
177 | (push-object! obj)) | |
17e90c5e | 178 | |
1aa0dd2b | 179 | ((<glil-argument> op index) |
f0c99935 | 180 | (if (eq? op 'ref) |
532565b0 KN |
181 | (push-code! `(local-ref ,index)) |
182 | (push-code! `(local-set ,index)))) | |
17e90c5e | 183 | |
1aa0dd2b | 184 | ((<glil-local> op index) |
f0c99935 | 185 | (if (eq? op 'ref) |
024e1862 AW |
186 | (push-code! `(local-ref ,(+ (glil-vars-nargs vars) index))) |
187 | (push-code! `(local-set ,(+ (glil-vars-nargs vars) index))))) | |
17e90c5e | 188 | |
1aa0dd2b | 189 | ((<glil-external> op depth index) |
024e1862 | 190 | (do ((e venv (venv-parent e)) |
17e90c5e | 191 | (d depth (1- d)) |
024e1862 | 192 | (n 0 (+ n (venv-nexts e)))) |
17e90c5e | 193 | ((= d 0) |
f0c99935 KN |
194 | (if (eq? op 'ref) |
195 | (push-code! `(external-ref ,(+ n index))) | |
196 | (push-code! `(external-set ,(+ n index))))))) | |
17e90c5e | 197 | |
a1122f8c | 198 | ((<glil-toplevel> op name) |
cd9d95d7 | 199 | (case op |
6297d229 AW |
200 | ((ref set) |
201 | (cond | |
202 | (toplevel | |
fd358575 | 203 | (push-object! (make-vlink-now #:key name)) |
6297d229 AW |
204 | (push-code! (case op |
205 | ((ref) '(variable-ref)) | |
206 | ((set) '(variable-set))))) | |
207 | (else | |
fd358575 | 208 | (let* ((var (make-vlink-later #:key name)) |
6297d229 AW |
209 | (i (cond ((object-assoc var object-alist) => cdr) |
210 | (else | |
211 | (let ((i (length object-alist))) | |
212 | (set! object-alist (acons var i object-alist)) | |
213 | i))))) | |
214 | (push-code! (case op | |
215 | ((ref) `(late-variable-ref ,i)) | |
216 | ((set) `(late-variable-set ,i)))))))) | |
cd9d95d7 | 217 | ((define) |
a1122f8c | 218 | (push-object! (make-vdefine #:name name)) |
6297d229 AW |
219 | (push-code! '(variable-set))) |
220 | (else | |
221 | (error "unknown toplevel var kind" op name)))) | |
9cc649b8 | 222 | |
fd358575 AW |
223 | ((<glil-module> op mod name public?) |
224 | (let ((key (list mod name public?))) | |
225 | (case op | |
226 | ((ref set) | |
227 | (cond | |
228 | (toplevel | |
229 | (push-object! (make-vlink-now #:key key)) | |
230 | (push-code! (case op | |
231 | ((ref) '(variable-ref)) | |
232 | ((set) '(variable-set))))) | |
233 | (else | |
234 | (let* ((var (make-vlink-later #:key key)) | |
235 | (i (cond ((object-assoc var object-alist) => cdr) | |
236 | (else | |
237 | (let ((i (length object-alist))) | |
238 | (set! object-alist (acons var i object-alist)) | |
239 | i))))) | |
240 | (push-code! (case op | |
241 | ((ref) `(late-variable-ref ,i)) | |
242 | ((set) `(late-variable-set ,i)))))))) | |
243 | (else | |
244 | (error "unknown module var kind" op key))))) | |
245 | ||
1aa0dd2b | 246 | ((<glil-label> label) |
ac99cb0c | 247 | (set! label-alist (assq-set! label-alist label (current-address)))) |
17e90c5e | 248 | |
1aa0dd2b | 249 | ((<glil-branch> inst label) |
13906f97 | 250 | (push (list inst label) stack)) |
17e90c5e | 251 | |
1aa0dd2b | 252 | ((<glil-call> inst nargs) |
17e90c5e | 253 | (if (instruction? inst) |
46cd9a34 KN |
254 | (let ((pops (instruction-pops inst))) |
255 | (cond ((< pops 0) | |
256 | (push-code! (list inst nargs))) | |
257 | ((= pops nargs) | |
258 | (push-code! (list inst))) | |
259 | (else | |
260 | (error "Wrong number of arguments:" inst nargs)))) | |
efbd5892 AW |
261 | (error "Unknown instruction:" inst))) |
262 | ||
263 | ((<glil-mv-call> nargs ra) | |
264 | (push (list 'mv-call nargs ra) stack)))) | |
265 | ||
17e90c5e KN |
266 | ;; |
267 | ;; main | |
17e90c5e | 268 | (for-each generate-code body) |
02b1883e | 269 | (finish-bindings!) |
2d80426a | 270 | ; (format #t "codegen: stack = ~a~%" (reverse stack)) |
41f248a8 KN |
271 | (let ((bytes (stack->bytes (reverse! stack) label-alist))) |
272 | (if toplevel | |
024e1862 | 273 | (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars)) |
1a1a10d3 | 274 | (make-bytespec #:vars vars #:bytes bytes |
02b1883e AW |
275 | #:meta (make-meta closed-bindings |
276 | (reverse! source-alist) | |
277 | meta) | |
1a1a10d3 | 278 | #:objs (let ((objs (map car (reverse! object-alist)))) |
849cefac | 279 | (if (null? objs) #f (list->vector objs))) |
1a1a10d3 | 280 | #:closure? (venv-closure? venv)))))))))) |
17e90c5e | 281 | |
880ed584 | 282 | (define (object-assoc x alist) |
1aa0dd2b | 283 | (record-case x |
6297d229 AW |
284 | ((<vlink-now>) (assoc x alist)) |
285 | ((<vlink-later>) (assoc x alist)) | |
ac99cb0c | 286 | (else (assq x alist)))) |
880ed584 | 287 | |
efbd5892 AW |
288 | (define (check-length len u8v) |
289 | (or (= len (u8vector-length u8v)) | |
290 | (error "the badness!" len u8v)) | |
291 | u8v) | |
292 | ||
41f248a8 | 293 | (define (stack->bytes stack label-alist) |
880ed584 | 294 | (let loop ((result '()) (stack stack) (addr 0)) |
206a0622 | 295 | (if (null? stack) |
efbd5892 AW |
296 | (check-length |
297 | addr | |
298 | (list->u8vector | |
299 | (append-map u8vector->list (reverse! result)))) | |
300 | (let ((elt (car stack))) | |
301 | (cond | |
302 | ((u8vector? elt) | |
303 | (loop (cons elt result) | |
304 | (cdr stack) | |
305 | (+ addr (byte-length elt)))) | |
306 | ((symbol? (car (last-pair elt))) | |
307 | ;; not yet code because labels needed to be resolved | |
308 | (let* ((head (list-head elt (1- (length elt)))) | |
309 | (label-addr (assq-ref label-alist (car (last-pair elt)))) | |
310 | (offset (- label-addr (+ addr (byte-length elt)))) | |
311 | (n (if (< offset 0) (+ offset 65536) offset))) | |
312 | (loop (cons (code->bytes | |
313 | (append head (list (quotient n 256) (modulo n 256)))) | |
314 | result) | |
315 | (cdr stack) | |
316 | (+ addr (byte-length elt))))) | |
317 | (else (error "bad code" elt))))))) | |
17e90c5e KN |
318 | |
319 | \f | |
320 | ;;; | |
4bfb26f5 | 321 | ;;; Object dump |
17e90c5e KN |
322 | ;;; |
323 | ||
23b587b0 | 324 | ;; NOTE: undumpped in vm_system.c |
17e90c5e | 325 | |
f0c99935 | 326 | (define (dump-object! push-code! x) |
23b587b0 LC |
327 | (define (too-long x) |
328 | (error (string-append x " too long"))) | |
329 | ||
bd098a1a KN |
330 | (let dump! ((x x)) |
331 | (cond | |
332 | ((object->code x) => push-code!) | |
1aa0dd2b AW |
333 | ((record? x) |
334 | (record-case x | |
335 | ((<bytespec> vars bytes meta objs closure?) | |
4bfb26f5 | 336 | ;; dump parameters |
024e1862 AW |
337 | (let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars)) |
338 | (nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars))) | |
ac99cb0c | 339 | (cond |
ac99cb0c KN |
340 | ((and (< nargs 16) (< nlocs 128) (< nexts 16)) |
341 | ;; 16-bit representation | |
97f1153a AW |
342 | (let ((x (logior |
343 | (ash nargs 12) (ash nrest 11) (ash nlocs 4) nexts))) | |
344 | (push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8))))))) | |
ac99cb0c KN |
345 | (else |
346 | ;; Other cases | |
347 | (push-code! (object->code nargs)) | |
348 | (push-code! (object->code nrest)) | |
349 | (push-code! (object->code nlocs)) | |
350 | (push-code! (object->code nexts)) | |
351 | (push-code! (object->code #f))))) | |
4bfb26f5 | 352 | ;; dump object table |
ac99cb0c KN |
353 | (if objs (dump! objs)) |
354 | ;; dump meta data | |
355 | (if meta (dump! meta)) | |
4bfb26f5 | 356 | ;; dump bytecode |
13906f97 | 357 | (push-code! `(load-program ,bytes))) |
fd358575 AW |
358 | ((<vlink-later> key) |
359 | (dump! key)) | |
360 | ((<vlink-now> key) | |
361 | (dump! key) | |
6297d229 | 362 | (push-code! '(link-now))) |
a1122f8c | 363 | ((<vdefine> name) |
cd9d95d7 | 364 | (push-code! `(define ,(symbol->string name)))) |
1aa0dd2b | 365 | (else |
7f52f9e3 | 366 | (error "assemble: unknown record type" (record-type-descriptor x))))) |
1aa0dd2b AW |
367 | ((and (integer? x) (exact? x)) |
368 | (let ((str (do ((n x (quotient n 256)) | |
369 | (l '() (cons (modulo n 256) l))) | |
370 | ((= n 0) | |
371 | (apply u8vector l))))) | |
372 | (push-code! `(load-integer ,str)))) | |
373 | ((number? x) | |
374 | (push-code! `(load-number ,(number->string x)))) | |
375 | ((string? x) | |
376 | (push-code! `(load-string ,x))) | |
377 | ((symbol? x) | |
378 | (push-code! `(load-symbol ,(symbol->string x)))) | |
379 | ((keyword? x) | |
a52b96a7 | 380 | (push-code! `(load-keyword ,(symbol->string (keyword->symbol x))))) |
1aa0dd2b AW |
381 | ((list? x) |
382 | (for-each dump! x) | |
383 | (let ((len (length x))) | |
384 | (if (>= len 65536) (too-long 'list)) | |
385 | (push-code! `(list ,(quotient len 256) ,(modulo len 256))))) | |
386 | ((pair? x) | |
387 | (dump! (car x)) | |
388 | (dump! (cdr x)) | |
389 | (push-code! `(cons))) | |
390 | ((vector? x) | |
391 | (for-each dump! (vector->list x)) | |
392 | (let ((len (vector-length x))) | |
393 | (if (>= len 65536) (too-long 'vector)) | |
394 | (push-code! `(vector ,(quotient len 256) ,(modulo len 256))))) | |
395 | (else | |
396 | (error "assemble: unrecognized object" x))))) |