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