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) | |
ac99cb0c | 23 | :use-syntax (system base syntax) |
17e90c5e KN |
24 | :use-module (system il glil) |
25 | :use-module (system vm core) | |
26 | :use-module (system vm conv) | |
27 | :use-module (ice-9 match) | |
28 | :use-module (ice-9 regex) | |
29 | :use-module (ice-9 common-list) | |
d8eeb67c | 30 | :export (preprocess assemble)) |
17e90c5e KN |
31 | |
32 | (define (assemble glil env . opts) | |
4bfb26f5 | 33 | (codegen (preprocess glil #f) #t)) |
17e90c5e KN |
34 | |
35 | \f | |
36 | ;;; | |
37 | ;;; Types | |
38 | ;;; | |
39 | ||
ac99cb0c KN |
40 | (define-record (<vm-asm> venv glil body)) |
41 | (define-record (<venv> parent nexts closure?)) | |
42 | (define-record (<vmod> id)) | |
43 | (define-record (<vlink> module name)) | |
44 | (define-record (<bytespec> vars bytes meta objs closure?)) | |
17e90c5e KN |
45 | |
46 | \f | |
47 | ;;; | |
48 | ;;; Stage 1: Preprocess | |
49 | ;;; | |
50 | ||
51 | (define (preprocess x e) | |
52 | (match x | |
ac99cb0c KN |
53 | (($ <glil-asm> vars body) |
54 | (let* ((venv (<venv> :parent e :nexts vars.nexts :closure? #f)) | |
17e90c5e | 55 | (body (map (lambda (x) (preprocess x venv)) body))) |
ac99cb0c | 56 | (<vm-asm> :venv venv :glil x :body body))) |
17e90c5e KN |
57 | (($ <glil-external> op depth index) |
58 | (do ((d depth (1- d)) | |
ac99cb0c | 59 | (e e e.parent)) |
17e90c5e | 60 | ((= d 0)) |
ac99cb0c | 61 | (set! e.closure? #t)) |
17e90c5e KN |
62 | x) |
63 | (else x))) | |
64 | ||
65 | \f | |
66 | ;;; | |
67 | ;;; Stage 2: Bytecode generation | |
68 | ;;; | |
69 | ||
70 | (define (codegen glil toplevel) | |
71 | (match glil | |
ac99cb0c | 72 | (($ <vm-asm> venv ($ <glil-asm> vars _) body) |
17e90c5e | 73 | (let ((stack '()) |
af988bbf | 74 | (binding-alist '()) |
ac99cb0c | 75 | (source-alist '()) |
17e90c5e | 76 | (label-alist '()) |
3616e9e9 | 77 | (object-alist '())) |
17e90c5e | 78 | (define (push-code! code) |
41f248a8 | 79 | (set! stack (cons (code->bytes code) stack))) |
206a0622 | 80 | (define (push-object! x) |
880ed584 | 81 | (cond ((object->code x) => push-code!) |
41f248a8 | 82 | (toplevel (dump-object! push-code! x)) |
f0c99935 | 83 | (else |
880ed584 KN |
84 | (let ((i (cond ((object-assoc x object-alist) => cdr) |
85 | (else | |
86 | (let ((i (length object-alist))) | |
87 | (set! object-alist (acons x i object-alist)) | |
88 | i))))) | |
89 | (push-code! `(object-ref ,i)))))) | |
ac99cb0c KN |
90 | (define (current-address) |
91 | (define (byte-length x) | |
92 | (cond ((string? x) (string-length x)) | |
93 | (else 3))) | |
94 | (apply + (map byte-length stack))) | |
17e90c5e KN |
95 | (define (generate-code x) |
96 | (match x | |
bd098a1a | 97 | (($ <vm-asm> venv) |
f0c99935 | 98 | (push-object! (codegen x #f)) |
ac99cb0c KN |
99 | (if venv.closure? (push-code! `(make-closure)))) |
100 | ||
101 | (($ <glil-bind> binds) | |
af988bbf KN |
102 | (let ((bindings |
103 | (map (lambda (v) | |
104 | (let ((name (car v)) (type (cadr v)) (i (caddr v))) | |
105 | (case type | |
106 | ((argument) (make-binding name #f i)) | |
107 | ((local) (make-binding name #f (+ vars.nargs i))) | |
108 | ((external) (make-binding name #t i))))) | |
109 | binds))) | |
110 | (set! binding-alist | |
111 | (acons (current-address) bindings binding-alist)))) | |
ac99cb0c KN |
112 | |
113 | (($ <glil-unbind>) | |
af988bbf | 114 | (set! binding-alist (acons (current-address) #f binding-alist))) |
ac99cb0c KN |
115 | |
116 | (($ <glil-source> loc) | |
117 | (set! source-alist (acons (current-address) loc source-alist))) | |
17e90c5e KN |
118 | |
119 | (($ <glil-void>) | |
41f248a8 | 120 | (push-code! '(void))) |
17e90c5e KN |
121 | |
122 | (($ <glil-const> x) | |
f0c99935 | 123 | (push-object! x)) |
17e90c5e KN |
124 | |
125 | (($ <glil-argument> op index) | |
f0c99935 | 126 | (if (eq? op 'ref) |
532565b0 KN |
127 | (push-code! `(local-ref ,index)) |
128 | (push-code! `(local-set ,index)))) | |
17e90c5e KN |
129 | |
130 | (($ <glil-local> op index) | |
f0c99935 | 131 | (if (eq? op 'ref) |
ac99cb0c KN |
132 | (push-code! `(local-ref ,(+ vars.nargs index))) |
133 | (push-code! `(local-set ,(+ vars.nargs index))))) | |
17e90c5e KN |
134 | |
135 | (($ <glil-external> op depth index) | |
ac99cb0c | 136 | (do ((e venv e.parent) |
17e90c5e | 137 | (d depth (1- d)) |
ac99cb0c | 138 | (n 0 (+ n e.nexts))) |
17e90c5e | 139 | ((= d 0) |
f0c99935 KN |
140 | (if (eq? op 'ref) |
141 | (push-code! `(external-ref ,(+ n index))) | |
142 | (push-code! `(external-set ,(+ n index))))))) | |
17e90c5e KN |
143 | |
144 | (($ <glil-module> op module name) | |
ac99cb0c | 145 | (push-object! (<vlink> :module #f :name name)) |
f0c99935 KN |
146 | (if (eq? op 'ref) |
147 | (push-code! '(variable-ref)) | |
148 | (push-code! '(variable-set)))) | |
17e90c5e KN |
149 | |
150 | (($ <glil-label> label) | |
ac99cb0c | 151 | (set! label-alist (assq-set! label-alist label (current-address)))) |
17e90c5e KN |
152 | |
153 | (($ <glil-branch> inst label) | |
41f248a8 | 154 | (set! stack (cons (list inst label) stack))) |
17e90c5e | 155 | |
46cd9a34 | 156 | (($ <glil-call> inst nargs) |
17e90c5e | 157 | (if (instruction? inst) |
46cd9a34 KN |
158 | (let ((pops (instruction-pops inst))) |
159 | (cond ((< pops 0) | |
160 | (push-code! (list inst nargs))) | |
161 | ((= pops nargs) | |
162 | (push-code! (list inst))) | |
163 | (else | |
164 | (error "Wrong number of arguments:" inst nargs)))) | |
17e90c5e KN |
165 | (error "Unknown instruction:" inst))))) |
166 | ;; | |
167 | ;; main | |
17e90c5e | 168 | (for-each generate-code body) |
41f248a8 KN |
169 | (let ((bytes (stack->bytes (reverse! stack) label-alist))) |
170 | (if toplevel | |
ac99cb0c KN |
171 | (bytecode->objcode bytes vars.nlocs vars.nexts) |
172 | (<bytespec> :vars vars :bytes bytes | |
af988bbf | 173 | :meta (if (and (null? binding-alist) |
ac99cb0c KN |
174 | (null? source-alist)) |
175 | #f | |
af988bbf | 176 | (cons (reverse! binding-alist) |
ac99cb0c KN |
177 | (reverse! source-alist))) |
178 | :objs (let ((objs (map car (reverse! object-alist)))) | |
179 | (if (null? objs) #f (list->vector objs))) | |
180 | :closure? venv.closure?))))))) | |
17e90c5e | 181 | |
880ed584 | 182 | (define (object-assoc x alist) |
ac99cb0c KN |
183 | (match x |
184 | (($ <vlink>) (assoc x alist)) | |
185 | (else (assq x alist)))) | |
880ed584 | 186 | |
41f248a8 | 187 | (define (stack->bytes stack label-alist) |
880ed584 | 188 | (let loop ((result '()) (stack stack) (addr 0)) |
206a0622 | 189 | (if (null? stack) |
4bfb26f5 | 190 | (apply string-append (reverse! result)) |
41f248a8 KN |
191 | (let ((bytes (car stack))) |
192 | (if (pair? bytes) | |
193 | (let* ((offset (- (assq-ref label-alist (cadr bytes)) | |
194 | (+ addr 3))) | |
195 | (n (if (< offset 0) (+ offset 65536) offset))) | |
196 | (set! bytes (code->bytes (list (car bytes) | |
197 | (quotient n 256) | |
198 | (modulo n 256)))))) | |
199 | (loop (cons bytes result) | |
200 | (cdr stack) | |
201 | (+ addr (string-length bytes))))))) | |
17e90c5e KN |
202 | |
203 | \f | |
204 | ;;; | |
4bfb26f5 | 205 | ;;; Object dump |
17e90c5e KN |
206 | ;;; |
207 | ||
4bfb26f5 | 208 | ;; NOTE: undumpped in vm_load.c. |
17e90c5e | 209 | |
f0c99935 | 210 | (define (dump-object! push-code! x) |
bd098a1a KN |
211 | (let dump! ((x x)) |
212 | (cond | |
213 | ((object->code x) => push-code!) | |
ac99cb0c | 214 | (else |
4bfb26f5 | 215 | (match x |
ac99cb0c | 216 | (($ <bytespec> vars bytes meta objs closure?) |
4bfb26f5 | 217 | ;; dump parameters |
ac99cb0c KN |
218 | (let ((nargs vars.nargs) (nrest vars.nrest) |
219 | (nlocs vars.nlocs) (nexts vars.nexts)) | |
220 | (cond | |
221 | ((and (< nargs 4) (< nlocs 8) (< nexts 4)) | |
222 | ;; 8-bit representation | |
223 | (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts))) | |
224 | (push-code! `(make-int8 ,x)))) | |
225 | ((and (< nargs 16) (< nlocs 128) (< nexts 16)) | |
226 | ;; 16-bit representation | |
227 | (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts))) | |
228 | (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256))))) | |
229 | (else | |
230 | ;; Other cases | |
231 | (push-code! (object->code nargs)) | |
232 | (push-code! (object->code nrest)) | |
233 | (push-code! (object->code nlocs)) | |
234 | (push-code! (object->code nexts)) | |
235 | (push-code! (object->code #f))))) | |
4bfb26f5 | 236 | ;; dump object table |
ac99cb0c KN |
237 | (if objs (dump! objs)) |
238 | ;; dump meta data | |
239 | (if meta (dump! meta)) | |
4bfb26f5 | 240 | ;; dump bytecode |
ac99cb0c KN |
241 | (push-code! `(load-program ,bytes))) |
242 | (($ <vlink> module name) | |
243 | ;; FIXME: dump module | |
244 | (push-code! `(link ,(symbol->string name)))) | |
245 | (($ <vmod> id) | |
246 | (push-code! `(load-module ,id))) | |
247 | ((and ($ integer) ($ exact)) | |
248 | (let ((str (do ((n x (quotient n 256)) | |
249 | (l '() (cons (modulo n 256) l))) | |
250 | ((= n 0) | |
251 | (list->string (map integer->char l)))))) | |
252 | (push-code! `(load-integer ,str)))) | |
253 | (($ number) | |
254 | (push-code! `(load-number ,(number->string x)))) | |
255 | (($ string) | |
256 | (push-code! `(load-string ,x))) | |
257 | (($ symbol) | |
258 | (push-code! `(load-symbol ,(symbol->string x)))) | |
259 | (($ keyword) | |
260 | (push-code! `(load-keyword | |
261 | ,(symbol->string (keyword-dash-symbol x))))) | |
262 | (($ list) | |
263 | (for-each dump! x) | |
264 | (push-code! `(list ,(length x)))) | |
265 | (($ pair) | |
266 | (dump! (car x)) | |
267 | (dump! (cdr x)) | |
268 | (push-code! `(cons))) | |
269 | (($ vector) | |
270 | (for-each dump! (vector->list x)) | |
271 | (push-code! `(vector ,(vector-length x)))) | |
272 | (else | |
273 | (error "Cannot dump:" x))))))) |