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