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) | |
33 | (dump (codegen (preprocess glil #f) #t))) | |
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)) | |
44 | (define-structure (bytespec nargs nrest nlocs bytes objs)) | |
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 | |
92 | (($ <vm-asm> env) | |
206a0622 | 93 | (push-object! (codegen x #f)) |
17e90c5e KN |
94 | (if (venv-closure? env) (push-code! `(make-closure)))) |
95 | ||
96 | (($ <glil-void>) | |
97 | (push-code! `(void))) | |
98 | ||
99 | (($ <glil-const> x) | |
100 | (if toplevel | |
101 | (for-each push-code! (object->dump-code x)) | |
102 | (cond ((object->code x) => push-code!) | |
206a0622 | 103 | (else (push-object! x))))) |
17e90c5e KN |
104 | |
105 | (($ <glil-argument> op index) | |
206a0622 | 106 | (push-code! `(,(symbol-append 'local- op) ,(- nvars index)))) |
17e90c5e KN |
107 | |
108 | (($ <glil-local> op index) | |
206a0622 KN |
109 | (push-code! `(,(symbol-append 'local- op) |
110 | ,(- nvars (+ nargs index))))) | |
17e90c5e KN |
111 | |
112 | (($ <glil-external> op depth index) | |
113 | (do ((e venv (venv-parent e)) | |
114 | (d depth (1- d)) | |
115 | (i 0 (+ i (venv-nexts e)))) | |
116 | ((= d 0) | |
206a0622 | 117 | (push-code! `(,(symbol-append 'external- op) ,(+ index i)))))) |
17e90c5e KN |
118 | |
119 | (($ <glil-module> op module name) | |
d4ae3ae6 KN |
120 | (if toplevel |
121 | (begin | |
122 | ;; (push-code! `(load-module ,module)) | |
206a0622 | 123 | (for-each push-code! (object->dump-code name)) |
d4ae3ae6 KN |
124 | (push-code! `(link/current-module))) |
125 | ;; (let ((vlink (make-vlink (make-vmod module) name))) | |
206a0622 | 126 | (push-object! (make-vlink #f name))) |
d4ae3ae6 | 127 | (push-code! (list (symbol-append 'variable- op)))) |
17e90c5e KN |
128 | |
129 | (($ <glil-label> label) | |
206a0622 | 130 | (label-set label)) |
17e90c5e KN |
131 | |
132 | (($ <glil-branch> inst label) | |
206a0622 | 133 | (let ((setter (lambda (addr) (- (label-ref label) addr)))) |
17e90c5e KN |
134 | (push-code! (list inst setter)))) |
135 | ||
46cd9a34 | 136 | (($ <glil-call> inst nargs) |
17e90c5e | 137 | (if (instruction? inst) |
46cd9a34 KN |
138 | (let ((pops (instruction-pops inst))) |
139 | (cond ((< pops 0) | |
140 | (push-code! (list inst nargs))) | |
141 | ((= pops nargs) | |
142 | (push-code! (list inst))) | |
143 | (else | |
144 | (error "Wrong number of arguments:" inst nargs)))) | |
17e90c5e KN |
145 | (error "Unknown instruction:" inst))))) |
146 | ;; | |
147 | ;; main | |
148 | (if (> nexts 0) (push-code! `(external ,nexts))) | |
149 | (for-each generate-code body) | |
206a0622 | 150 | (let ((bytes (apply string-append (stack-finalize (reverse! stack)))) |
17e90c5e KN |
151 | (objs (map car (reverse! object-alist)))) |
152 | (make-bytespec nargs nrest nlocs bytes objs)))))) | |
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 | ;;; | |
195 | ;;; Stage3: Dumpcode generation | |
196 | ;;; | |
197 | ||
198 | (define (dump bytespec) | |
199 | (let* ((table (build-object-table bytespec)) | |
200 | (bytes (bytespec->bytecode bytespec table '(return)))) | |
201 | (if (null? table) | |
202 | bytes | |
203 | (let ((spec (make-bytespec 0 0 (length table) bytes '()))) | |
204 | (bytespec->bytecode spec '() '(tail-call 0)))))) | |
205 | ||
206 | (define (bytespec->bytecode bytespec object-table last-code) | |
207 | (let ((stack '())) | |
208 | (define (push-code! x) | |
209 | (set! stack (cons x stack))) | |
210 | (define (object-index x) | |
211 | (cond ((object-find object-table x) => cdr) | |
212 | (else #f))) | |
213 | (define (dump-table-object! obj+index) | |
214 | (let dump! ((x (car obj+index))) | |
215 | (cond | |
216 | ((vlink? x) | |
fdcedea6 | 217 | ;; (push-code! `(local-ref ,(object-index (vlink-module x)))) |
206a0622 | 218 | (for-each push-code! (object->dump-code (vlink-name x))) |
fdcedea6 | 219 | (push-code! `(link/current-module))) |
206a0622 KN |
220 | ;;((vmod? x) |
221 | ;; (push-code! `(load-module ,(vmod-id x)))) | |
17e90c5e KN |
222 | (else |
223 | (for-each push-code! (object->dump-code x))))) | |
224 | (push-code! `(local-set ,(cdr obj+index)))) | |
225 | (define (dump-object! x) | |
226 | (let dump! ((x x)) | |
227 | (cond | |
228 | ((bytespec? x) (dump-bytecode! x)) | |
229 | ((object-index x) => (lambda (i) (push-code! `(local-ref ,i)))) | |
230 | (else | |
231 | (error "Cannot dump:" x))))) | |
232 | (define (dump-bytecode! spec) | |
233 | (let ((nargs (bytespec-nargs spec)) | |
234 | (nrest (bytespec-nrest spec)) | |
235 | (nlocs (bytespec-nlocs spec)) | |
236 | (objs (bytespec-objs spec))) | |
206a0622 KN |
237 | ;; dump parameters |
238 | (if (and (< nargs 4) (< nlocs 16)) | |
17e90c5e KN |
239 | (push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs))) |
240 | (begin | |
17e90c5e KN |
241 | (push-code! (object->code nargs)) |
242 | (push-code! (object->code nrest)) | |
243 | (push-code! (object->code nlocs)) | |
206a0622 KN |
244 | (push-code! (object->code #f)))) |
245 | ;; dump object table | |
246 | (cond ((not (null? objs)) | |
247 | (for-each dump-object! objs) | |
248 | (push-code! `(vector ,(length objs))))) | |
17e90c5e KN |
249 | ;; dump bytecode |
250 | (push-code! `(load-program ,(bytespec-bytes spec))))) | |
251 | ;; | |
252 | ;; main | |
253 | (for-each dump-table-object! object-table) | |
254 | (dump-bytecode! bytespec) | |
255 | (push-code! last-code) | |
206a0622 KN |
256 | (apply string-append |
257 | (map code->bytes (map code-pack (reverse! stack)))))) | |
17e90c5e KN |
258 | |
259 | (define (object-find table x) | |
260 | ((if (or (vlink? x) (vmod? x)) assoc assq) x table)) | |
261 | ||
262 | (define (build-object-table bytespec) | |
263 | (let ((table '()) (index 0)) | |
264 | (define (insert! x) | |
d4ae3ae6 | 265 | ;; (if (vlink? x) (begin (insert! (vlink-module x)))) |
17e90c5e KN |
266 | (if (not (object-find table x)) |
267 | (begin | |
268 | (set! table (acons x index table)) | |
269 | (set! index (1+ index))))) | |
270 | (let loop ((spec bytespec)) | |
271 | (for-each (lambda (x) | |
272 | (if (bytespec? x) (loop x) (insert! x))) | |
273 | (bytespec-objs spec))) | |
274 | (reverse! table))) |