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) | |
bd098a1a | 33 | (optimizing-dump (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 '()) | |
75 | (object-alist '()) | |
76 | (nvars (+ nargs nlocs -1))) | |
17e90c5e KN |
77 | (define (push-code! code) |
78 | (set! stack (optimizing-push code stack))) | |
206a0622 KN |
79 | (define (push-object! x) |
80 | (let ((index (or ((if (vlink? x) assoc-ref assq-ref) object-alist x) | |
81 | (let ((index (length object-alist))) | |
82 | (set! object-alist (acons x index object-alist)) | |
83 | index)))) | |
84 | (push-code! `(object-ref ,index)))) | |
17e90c5e KN |
85 | (define (label-ref key) |
86 | (assq-ref label-alist key)) | |
206a0622 KN |
87 | (define (label-set key) |
88 | (let ((addr (apply + (map length stack)))) | |
89 | (set! label-alist (assq-set! label-alist key addr)))) | |
17e90c5e KN |
90 | (define (generate-code x) |
91 | (match x | |
bd098a1a KN |
92 | (($ <vm-asm> venv) |
93 | (let ((spec (codegen x #f))) | |
94 | (if toplevel | |
95 | (dump-object! spec push-code!) | |
96 | (push-object! spec))) | |
97 | (if (venv-closure? venv) (push-code! `(make-closure)))) | |
17e90c5e KN |
98 | |
99 | (($ <glil-void>) | |
100 | (push-code! `(void))) | |
101 | ||
102 | (($ <glil-const> x) | |
103 | (if toplevel | |
bd098a1a | 104 | (dump-object! x push-code!) |
17e90c5e | 105 | (cond ((object->code x) => push-code!) |
206a0622 | 106 | (else (push-object! x))))) |
17e90c5e KN |
107 | |
108 | (($ <glil-argument> op index) | |
206a0622 | 109 | (push-code! `(,(symbol-append 'local- op) ,(- nvars index)))) |
17e90c5e KN |
110 | |
111 | (($ <glil-local> op index) | |
206a0622 KN |
112 | (push-code! `(,(symbol-append 'local- op) |
113 | ,(- nvars (+ nargs index))))) | |
17e90c5e KN |
114 | |
115 | (($ <glil-external> op depth index) | |
116 | (do ((e venv (venv-parent e)) | |
117 | (d depth (1- d)) | |
118 | (i 0 (+ i (venv-nexts e)))) | |
119 | ((= d 0) | |
206a0622 | 120 | (push-code! `(,(symbol-append 'external- op) ,(+ index i)))))) |
17e90c5e KN |
121 | |
122 | (($ <glil-module> op module name) | |
bd098a1a KN |
123 | ;; (let ((vlink (make-vlink (make-vmod module) name))) |
124 | (let ((vlink (make-vlink #f name))) | |
125 | (if toplevel | |
126 | (dump-object! vlink push-code!) | |
127 | (push-object! vlink))) | |
d4ae3ae6 | 128 | (push-code! (list (symbol-append 'variable- op)))) |
17e90c5e KN |
129 | |
130 | (($ <glil-label> label) | |
206a0622 | 131 | (label-set label)) |
17e90c5e KN |
132 | |
133 | (($ <glil-branch> inst label) | |
206a0622 | 134 | (let ((setter (lambda (addr) (- (label-ref label) addr)))) |
17e90c5e KN |
135 | (push-code! (list inst setter)))) |
136 | ||
46cd9a34 | 137 | (($ <glil-call> inst nargs) |
17e90c5e | 138 | (if (instruction? inst) |
46cd9a34 KN |
139 | (let ((pops (instruction-pops inst))) |
140 | (cond ((< pops 0) | |
141 | (push-code! (list inst nargs))) | |
142 | ((= pops nargs) | |
143 | (push-code! (list inst))) | |
144 | (else | |
145 | (error "Wrong number of arguments:" inst nargs)))) | |
17e90c5e KN |
146 | (error "Unknown instruction:" inst))))) |
147 | ;; | |
148 | ;; main | |
17e90c5e | 149 | (for-each generate-code body) |
206a0622 | 150 | (let ((bytes (apply string-append (stack-finalize (reverse! stack)))) |
17e90c5e | 151 | (objs (map car (reverse! object-alist)))) |
3d5ee0cd | 152 | (make-bytespec nargs nrest nlocs nexts bytes objs)))))) |
17e90c5e | 153 | |
206a0622 KN |
154 | (define (stack-finalize stack) |
155 | (let loop ((list '()) (stack stack) (addr 0)) | |
156 | (if (null? stack) | |
157 | (reverse! list) | |
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))) | |
163 | (loop (cons (code->bytes code) list) (cdr stack) addr))))) | |
17e90c5e KN |
164 | |
165 | ;; Optimization | |
166 | ||
167 | (define *optimize-table* | |
168 | '((not (not . not-not) | |
169 | (eq? . not-eq?) | |
170 | (null? . not-null?) | |
171 | (not-not . not) | |
172 | (not-eq? . eq?) | |
173 | (not-null? . null?)) | |
174 | (br-if (not . br-if-not) | |
175 | (eq? . br-if-eq) | |
176 | (null? . br-if-null) | |
177 | (not-not . br-if) | |
178 | (not-eq? . br-if-not-eq) | |
179 | (not-null? . br-if-not-null)) | |
180 | (br-if-not (not . br-if) | |
181 | (eq? . br-if-not-eq) | |
182 | (null? . br-if-not-null) | |
183 | (not-not . br-if-not) | |
184 | (not-eq? . br-if-eq) | |
185 | (not-null? . br-if-null)))) | |
186 | ||
187 | (define (optimizing-push code stack) | |
188 | (let ((alist (assq-ref *optimize-table* (car code)))) | |
206a0622 KN |
189 | (cond ((and alist (pair? stack) (assq-ref alist (caar stack))) => |
190 | (lambda (inst) (cons (cons inst (cdr code)) (cdr stack)))) | |
191 | (else (cons (code-pack code) stack))))) | |
17e90c5e KN |
192 | |
193 | \f | |
194 | ;;; | |
bd098a1a | 195 | ;;; Stage3: Dump optimization |
17e90c5e KN |
196 | ;;; |
197 | ||
bd098a1a KN |
198 | (define (optimizing-dump bytespec) |
199 | ;; no optimization yet | |
200 | (bytespec-bytes bytespec)) | |
17e90c5e | 201 | |
bd098a1a KN |
202 | (define (dump-object! x push-code!) |
203 | (let dump! ((x x)) | |
204 | (cond | |
205 | ((object->code x) => push-code!) | |
206 | ((bytespec? x) | |
207 | (let ((nargs (bytespec-nargs x)) | |
208 | (nrest (bytespec-nrest x)) | |
209 | (nlocs (bytespec-nlocs x)) | |
3d5ee0cd | 210 | (nexts (bytespec-nexts x)) |
bd098a1a KN |
211 | (bytes (bytespec-bytes x)) |
212 | (objs (bytespec-objs x))) | |
206a0622 | 213 | ;; dump parameters |
3d5ee0cd KN |
214 | (cond ((and (< nargs 4) (< nlocs 8) (< nexts 4)) |
215 | ;; 8-bit representation | |
216 | (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts))) | |
217 | (push-code! `(make-int8 ,x)))) | |
218 | ((and (< nargs 16) (< nlocs 128) (< nexts 16)) | |
219 | ;; 16-bit representation | |
220 | (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts))) | |
221 | (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256))))) | |
222 | (else | |
223 | ;; Other cases | |
224 | (push-code! (object->code nargs)) | |
225 | (push-code! (object->code nrest)) | |
226 | (push-code! (object->code nlocs)) | |
227 | (push-code! (object->code nexts)) | |
228 | (push-code! (object->code #f)))) | |
206a0622 KN |
229 | ;; dump object table |
230 | (cond ((not (null? objs)) | |
bd098a1a | 231 | (for-each dump! objs) |
206a0622 | 232 | (push-code! `(vector ,(length objs))))) |
17e90c5e | 233 | ;; dump bytecode |
bd098a1a KN |
234 | (push-code! `(load-program ,bytes)))) |
235 | ((vlink? x) | |
236 | ;; (push-code! `(local-ref ,(object-index (vlink-module x)))) | |
237 | (dump! (vlink-name x)) | |
238 | (push-code! `(link/current-module))) | |
239 | ;;((vmod? x) | |
240 | ;; (push-code! `(load-module ,(vmod-id x)))) | |
241 | ((integer? x) | |
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)))) | |
247 | ((string? x) | |
248 | (push-code! `(load-string ,x))) | |
249 | ((symbol? x) | |
250 | (push-code! `(load-symbol ,(symbol->string x)))) | |
251 | ((keyword? x) | |
252 | (push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x))))) | |
253 | ((list? x) | |
254 | (for-each dump! x) | |
255 | (push-code! `(list ,(length x)))) | |
256 | ((pair? x) | |
257 | (dump! (car x)) | |
258 | (dump! (cdr x)) | |
259 | (push-code! `(cons))) | |
260 | ((vector? x) | |
261 | (for-each dump! (vector->list x)) | |
262 | (push-code! `(vector ,(vector-length x)))) | |
263 | (else | |
264 | (error "Cannot dump:" x))))) | |
17e90c5e | 265 | |
bd098a1a KN |
266 | ;;;(define (dump-table-object! obj+index) |
267 | ;;; (let dump! ((x (car obj+index))) | |
268 | ;;; (cond | |
269 | ;;; (else | |
270 | ;;; (for-each push-code! (dump-object! x))))) | |
271 | ;;; (push-code! `(local-set ,(cdr obj+index)))) |