1 | ;;; jvm.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003 Peter Graves |
---|
4 | ;;; $Id: jvm.lisp,v 1.28 2003-11-14 17:54:23 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | (in-package "JVM") |
---|
21 | |
---|
22 | (export '(jvm-compile jvm-compile-package)) |
---|
23 | |
---|
24 | (shadow 'method) |
---|
25 | |
---|
26 | (defvar *instructions* |
---|
27 | '(nop aconst_null iconst_m1 iconst_0 iconst_1 ; 0 |
---|
28 | iconst_2 iconst_3 iconst_4 iconst_5 lconst_0 ; 5 |
---|
29 | lconst_1 fconst_0 fconst_1 fconst_2 dconst_0 ; 10 |
---|
30 | dconst_1 bipush sipush ldc ldc_w ; 15 |
---|
31 | ldc2_w iload lload fload dload ; 20 |
---|
32 | aload iload_0 iload_1 iload_2 iload_3 ; 25 |
---|
33 | lload_0 lload_1 lload_2 lload_3 fload_0 ; 30 |
---|
34 | fload_1 fload_2 fload_3 dload_0 dload_1 ; 35 |
---|
35 | dload_2 dload_3 aload_0 aload_1 aload_2 ; 40 |
---|
36 | aload_3 iaload laload faload daload ; 45 |
---|
37 | aaload baload caload saload istore ; 50 |
---|
38 | lstore fstore dstore astore istore_0 ; 55 |
---|
39 | istore_1 istore_2 istore_3 lstore_0 lstore_1 ; 60 |
---|
40 | lstore_2 lstore_3 fstore_0 fstore_1 fstore_2 ; 65 |
---|
41 | fstore_3 dstore_0 dstore_1 dstore_2 dstore_3 ; 70 |
---|
42 | astore_0 astore_1 astore_2 astore_3 iastore ; 75 |
---|
43 | lastore fastore dastore aastore bastore ; 80 |
---|
44 | castore sastore pop pop2 dup ; 85 |
---|
45 | dup_x1 dup_x2 dup2 dup2_x1 dup2_x2 ; 90 |
---|
46 | swap iadd ladd fadd dadd ; 95 |
---|
47 | isub lsub fsub dsub imul ; 100 |
---|
48 | lmul fmul dmul idiv ldiv ; 105 |
---|
49 | fdiv ddiv irem lrem frem ; 110 |
---|
50 | drem ineg lneg fneg dneg ; 115 |
---|
51 | ishl lshl ishr lshr iushr ; 120 |
---|
52 | lushr iand land ior lor ; 125 |
---|
53 | ixor lxor iinc i2l i2f ; 130 |
---|
54 | i2d l2i l2f l2d f2i ; 135 |
---|
55 | f2l f2d d2i d2l d2f ; 140 |
---|
56 | i2b i2c i2s lcmp fcmpl ; 145 |
---|
57 | fcmpg dcmpl dcmpg ifeq ifne ; 150 |
---|
58 | iflt ifge ifgt ifle if_icmpeq ; 155 |
---|
59 | if_icmpne if_icmplt if_icmpge if_icmpgt if_icmple ; 160 |
---|
60 | if_acmpeq if_acmpne goto jsr ret ; 165 |
---|
61 | tableswitch lookupswitch ireturn lreturn freturn ; 170 |
---|
62 | dreturn areturn return getstatic putstatic ; 175 |
---|
63 | getfield putfield invokevirtual invokespecial invokestatic ; 180 |
---|
64 | invokeinterface unused new newarray anewarray ; 185 |
---|
65 | arraylength athrow checkcast instanceof monitorenter ; 190 |
---|
66 | monitorexit wide multianewarray ifnull ifnonnull ; 195 |
---|
67 | goto_w jsr_w label ; 200 |
---|
68 | )) |
---|
69 | |
---|
70 | (unless (vectorp *instructions*) |
---|
71 | (let* ((list *instructions*) |
---|
72 | (vector (make-array (length *instructions*))) |
---|
73 | (index 0)) |
---|
74 | (dolist (instr list) |
---|
75 | (setf (get instr 'opcode) index) |
---|
76 | (setf (svref vector index) instr) |
---|
77 | (incf index)) |
---|
78 | (setq *instructions* vector))) |
---|
79 | |
---|
80 | (defun instr (opcode) |
---|
81 | (svref *instructions* opcode)) |
---|
82 | |
---|
83 | (defparameter *opcode-size* |
---|
84 | ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 |
---|
85 | '#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 3 2 3 ;; 000-019 |
---|
86 | 3 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ;; 020-039 |
---|
87 | 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 1 ;; 040-059 |
---|
88 | 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ;; 060-079 |
---|
89 | 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ;; 080-099 |
---|
90 | 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ;; 100-119 |
---|
91 | 1 1 1 1 1 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1 ;; 120-139 |
---|
92 | 1 1 1 1 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3 ;; 140-159 |
---|
93 | 3 3 3 3 3 3 3 3 3 2 0 0 1 1 1 1 1 1 3 3 ;; 160-179 |
---|
94 | 3 3 3 3 3 5 0 3 2 3 1 1 3 3 1 1 0 4 3 3 ;; 180-199 |
---|
95 | 5 5 0 ;; 200-202 |
---|
96 | )) |
---|
97 | |
---|
98 | (defun opcode-size (opcode) |
---|
99 | (svref *opcode-size* opcode)) |
---|
100 | |
---|
101 | (defvar *pool* nil) |
---|
102 | |
---|
103 | (defun read-u1 (stream) |
---|
104 | (read-byte stream)) |
---|
105 | |
---|
106 | (defun read-u2 (stream) |
---|
107 | (+ (ash (read-byte stream) 8) (read-byte stream))) |
---|
108 | |
---|
109 | (defun read-u4 (stream) |
---|
110 | (+ (ash (read-u2 stream) 16) (read-u2 stream))) |
---|
111 | |
---|
112 | (defun lookup-utf8 (index) |
---|
113 | (let ((entry (svref *pool* index))) |
---|
114 | (when (eql (car entry) 1) |
---|
115 | (caddr entry)))) |
---|
116 | |
---|
117 | (defun read-constant-pool-entry (stream) |
---|
118 | (let ((tag (read-u1 stream)) |
---|
119 | info) |
---|
120 | (case tag |
---|
121 | ((7 8) |
---|
122 | (list tag (read-u2 stream))) |
---|
123 | (1 |
---|
124 | (let* ((len (read-u2 stream)) |
---|
125 | (s (make-string len))) |
---|
126 | (dotimes (i len) |
---|
127 | ;; (setf (char s i) (coerce (read-u1 stream) 'character))) |
---|
128 | (setf (char s i) (code-char (read-u1 stream)))) |
---|
129 | (list tag len s))) |
---|
130 | ((3 4) |
---|
131 | (list tag (read-u4 stream))) |
---|
132 | ((5 6) |
---|
133 | (list tag (read-u4 stream) (read-u4 stream))) |
---|
134 | ((12 9 10 11) |
---|
135 | (list tag (read-u2 stream) (read-u2 stream))) |
---|
136 | (t |
---|
137 | (error "READ-CONSTANT-POOL-ENTRY unhandled tag ~D" tag))))) |
---|
138 | |
---|
139 | (defvar *indent* 0) |
---|
140 | |
---|
141 | (defparameter *spaces* (make-string 256 :initial-element #\space)) |
---|
142 | |
---|
143 | (defmacro out (&rest args) |
---|
144 | `(progn (format t (subseq *spaces* 0 *indent*)) (format t ,@args))) |
---|
145 | |
---|
146 | (defun dump-code (code) |
---|
147 | (let ((code-length (length code))) |
---|
148 | (do ((i 0)) |
---|
149 | ((>= i code-length)) |
---|
150 | (let* ((opcode (svref code i)) |
---|
151 | (size (opcode-size opcode))) |
---|
152 | (out "~D (#x~X) ~A~%" opcode opcode (instr opcode)) |
---|
153 | (incf i) |
---|
154 | (dotimes (j (1- size)) |
---|
155 | (let ((byte (svref code i))) |
---|
156 | (out "~D (#x~X)~%" byte byte)) |
---|
157 | (incf i)))))) |
---|
158 | |
---|
159 | (defun dump-code-attribute (stream) |
---|
160 | (let ((*indent* (+ *indent* 2))) |
---|
161 | (out "Stack: ~D~%" (read-u2 stream)) |
---|
162 | (out "Locals: ~D~%" (read-u2 stream)) |
---|
163 | (let* ((code-length (read-u4 stream)) |
---|
164 | (code (make-array code-length))) |
---|
165 | (out "Code length: ~D~%" code-length) |
---|
166 | (out "Code:~%") |
---|
167 | (dotimes (i code-length) |
---|
168 | (setf (svref code i) (read-u1 stream))) |
---|
169 | (let ((*indent* (+ *indent* 2))) |
---|
170 | (dump-code code))) |
---|
171 | (let ((exception-table-length (read-u2 stream))) |
---|
172 | (out "Exception table length: ~D~%" exception-table-length) |
---|
173 | (let ((*indent* (+ *indent* 2))) |
---|
174 | (dotimes (i exception-table-length) |
---|
175 | (out "Start PC: ~D~%" (read-u2 stream)) |
---|
176 | (out "End PC: ~D~%" (read-u2 stream)) |
---|
177 | (out "Handler PC: ~D~%" (read-u2 stream)) |
---|
178 | (out "Catch type: ~D~%" (read-u2 stream))))) |
---|
179 | (let ((attributes-count (read-u2 stream))) |
---|
180 | (out "Number of attributes: ~D~%" attributes-count) |
---|
181 | (let ((*indent* (+ *indent* 2))) |
---|
182 | (dotimes (i attributes-count) |
---|
183 | (read-attribute i stream)))))) |
---|
184 | |
---|
185 | (defun dump-exceptions (stream) |
---|
186 | ) |
---|
187 | |
---|
188 | (defun read-attribute (index stream) |
---|
189 | (let* ((name-index (read-u2 stream)) |
---|
190 | (length (read-u4 stream)) |
---|
191 | (*indent (+ *indent* 2))) |
---|
192 | (setq name (lookup-utf8 name-index)) |
---|
193 | (out "Attribute ~D: Name index: ~D (~S)~%" index name-index name) |
---|
194 | (out "Attribute ~D: Length: ~D~%" index length) |
---|
195 | (cond ((string= name "Code") |
---|
196 | (dump-code-attribute stream)) |
---|
197 | ((string= name "Exceptions") |
---|
198 | (let ((count (read-u2 stream))) |
---|
199 | (out "Attribute ~D: Number of exceptions: ~D~%" index count) |
---|
200 | (let ((*indent* (+ *indent* 2))) |
---|
201 | (dotimes (i count) |
---|
202 | (out "Exception ~D: ~D~%" i (read-u2 stream)))))) |
---|
203 | (t |
---|
204 | (dotimes (i length) |
---|
205 | (read-u1 stream)))))) |
---|
206 | |
---|
207 | (defun read-info (index stream type) |
---|
208 | (let* ((access-flags (read-u2 stream)) |
---|
209 | (name-index (read-u2 stream)) |
---|
210 | (descriptor-index (read-u2 stream)) |
---|
211 | (attributes-count (read-u2 stream)) |
---|
212 | (*indent* (+ *indent* 2)) |
---|
213 | (type (case type |
---|
214 | ('field "Field") |
---|
215 | ('method "Method"))) |
---|
216 | name) |
---|
217 | (out "~A ~D: Access flags: #x~X~%" type index access-flags) |
---|
218 | (out "~A ~D: Name index: ~D (~S)~%" type index name-index (lookup-utf8 name-index)) |
---|
219 | (out "~A ~D: Descriptor index: ~D~%" type index descriptor-index) |
---|
220 | (out "~A ~D: Number of attributes: ~D~%" type index attributes-count) |
---|
221 | (let ((*indent* (+ *indent* 2))) |
---|
222 | (dotimes (i attributes-count) |
---|
223 | (read-attribute i stream))))) |
---|
224 | |
---|
225 | (defun dump-class (filename) |
---|
226 | (let ((*indent* 0) |
---|
227 | (*pool* nil)) |
---|
228 | (with-open-file (stream filename :direction :input :element-type 'unsigned-byte) |
---|
229 | (handler-bind ((end-of-file |
---|
230 | #'(lambda (c) (return-from dump-class c)))) |
---|
231 | (out "Magic number: #x~X~%" (read-u4 stream)) |
---|
232 | (let ((minor (read-u2 stream)) |
---|
233 | (major (read-u2 stream))) |
---|
234 | (out "Version: ~D.~D~%" major minor)) |
---|
235 | ;; Constant pool. |
---|
236 | (let ((count (read-u2 stream)) |
---|
237 | entry type) |
---|
238 | (out "Constant pool (~D entries):~%" count) |
---|
239 | (setq *pool* (make-array count)) |
---|
240 | (let ((*indent* (+ *indent* 2))) |
---|
241 | (dotimes (index (1- count)) |
---|
242 | (setq entry (read-constant-pool-entry stream)) |
---|
243 | (setf (svref *pool* (1+ index)) entry) |
---|
244 | (setq type (case (car entry) |
---|
245 | (7 'class) |
---|
246 | (9 'field) |
---|
247 | (10 'method) |
---|
248 | (11 'interface) |
---|
249 | (8 'string) |
---|
250 | (3 'integer) |
---|
251 | (4 'float) |
---|
252 | (5 'long) |
---|
253 | (6 'double) |
---|
254 | (12 'name-and-type) |
---|
255 | (1 'utf8))) |
---|
256 | (out "~D: ~A ~S~%" (1+ index) type entry)))) |
---|
257 | (out "Access flags: #x~X~%" (read-u2 stream)) |
---|
258 | (out "This class: ~D~%" (read-u2 stream)) |
---|
259 | (out "Superclass: ~D~%" (read-u2 stream)) |
---|
260 | ;; Interfaces. |
---|
261 | (let ((count (read-u2 stream))) |
---|
262 | (cond ((zerop count) |
---|
263 | (out "No interfaces~%")) |
---|
264 | (t |
---|
265 | (out "Interfaces (~D):~%" count) |
---|
266 | (dotimes (i count) |
---|
267 | (out " ~D: ~D~%" i (read-u2 stream)))))) |
---|
268 | ;; Fields. |
---|
269 | (let ((count (read-u2 stream))) |
---|
270 | (cond ((zerop count) |
---|
271 | (out "No fields~%")) |
---|
272 | (t |
---|
273 | (out "Fields (~D):~%" count))) |
---|
274 | (dotimes (index count) |
---|
275 | (read-info index stream 'field))) |
---|
276 | ;; Methods. |
---|
277 | (let ((count (read-u2 stream))) |
---|
278 | (cond ((zerop count) |
---|
279 | (out "No methods~%")) |
---|
280 | (t |
---|
281 | (out "Methods (~D):~%" count))) |
---|
282 | (dotimes (index count) |
---|
283 | (read-info index stream 'method))) |
---|
284 | (let ((count (read-u2 stream))) |
---|
285 | (cond ((zerop count) |
---|
286 | (out "No attributes~%")) |
---|
287 | (t |
---|
288 | (out "Attributes (~D):~%" count))))))) |
---|
289 | t) |
---|
290 | |
---|
291 | (defvar *stream* nil) |
---|
292 | (defvar *defun-name* nil) |
---|
293 | (defvar *this-class* nil) |
---|
294 | (defvar *pool-count* 1) |
---|
295 | |
---|
296 | (defvar *code* ()) |
---|
297 | (defvar *static-code* ()) |
---|
298 | (defvar *fields* ()) |
---|
299 | |
---|
300 | (defvar *blocks* ()) |
---|
301 | (defvar *locals* ()) |
---|
302 | (defvar *max-locals* 0) |
---|
303 | |
---|
304 | ;; (defun allocate-local () |
---|
305 | ;; (let ((index (fill-pointer *locals*))) |
---|
306 | ;; (incf (fill-pointer *locals*)) |
---|
307 | ;; (setf *max-locals* (fill-pointer *locals*)) |
---|
308 | ;; index)) |
---|
309 | |
---|
310 | (defvar *args* nil) |
---|
311 | (defvar *using-arg-array* nil) |
---|
312 | (defvar *hairy-arglist-p* nil) |
---|
313 | |
---|
314 | (defvar *val* nil) ; index of value register |
---|
315 | |
---|
316 | (defun clear () |
---|
317 | (setq *pool* nil |
---|
318 | *pool-count* 1 |
---|
319 | *code* nil) |
---|
320 | t) |
---|
321 | |
---|
322 | (defun dump-pool () |
---|
323 | (let ((pool (reverse *pool*)) |
---|
324 | entry) |
---|
325 | (dotimes (index (1- *pool-count*)) |
---|
326 | (setq entry (car pool)) |
---|
327 | (setq type (case (car entry) |
---|
328 | (7 'class) |
---|
329 | (9 'field) |
---|
330 | (10 'method) |
---|
331 | (11 'interface) |
---|
332 | (8 'string) |
---|
333 | (3 'integer) |
---|
334 | (4 'float) |
---|
335 | (5 'long) |
---|
336 | (6 'double) |
---|
337 | (12 'name-and-type) |
---|
338 | (1 'utf8))) |
---|
339 | (format t "~D: ~A ~S~%" (1+ index) type entry) |
---|
340 | (setq pool (cdr pool)))) |
---|
341 | t) |
---|
342 | |
---|
343 | ;; Returns index of entry (1-based). |
---|
344 | (defun pool-add (entry) |
---|
345 | (setq *pool* (cons entry *pool*)) |
---|
346 | (prog1 |
---|
347 | *pool-count* |
---|
348 | (incf *pool-count*))) |
---|
349 | |
---|
350 | ;; Returns index of entry (1-based). |
---|
351 | (defun pool-find-entry (entry) |
---|
352 | (do* ((remaining *pool* (cdr remaining)) |
---|
353 | (i 0 (1+ i)) |
---|
354 | (current (car remaining) (car remaining))) |
---|
355 | ((null remaining) nil) |
---|
356 | (when (equal current entry) |
---|
357 | (return-from pool-find-entry (- *pool-count* 1 i))))) |
---|
358 | |
---|
359 | ;; Adds entry if not already in pool. Returns index of entry (1-based). |
---|
360 | (defun pool-get (entry) |
---|
361 | (or (pool-find-entry entry) (pool-add entry))) |
---|
362 | |
---|
363 | (defun pool-name (name) |
---|
364 | (pool-get (list 1 (length name) name))) |
---|
365 | |
---|
366 | ;; "org.armedbear.lisp.LispObject" => "Lorg/armedbear/lisp/LispObject;" |
---|
367 | ;; (defun type-descriptor (type) |
---|
368 | ;; (unless (find #\. type) |
---|
369 | ;; (setq type (concatenate 'string "org.armedbear.lisp." type))) |
---|
370 | ;; (let ((res (concatenate 'string "L" type ";"))) |
---|
371 | ;; (dotimes (i (length res)) |
---|
372 | ;; (when (eql (char res i) #\.) |
---|
373 | ;; (setf (char res i) #\/))) |
---|
374 | ;; res)) |
---|
375 | |
---|
376 | (defun pool-name-and-type (name type) |
---|
377 | (let* ((name-index (pool-name name)) |
---|
378 | (type-index (pool-name type))) |
---|
379 | (pool-get (list 12 name-index type-index)))) |
---|
380 | |
---|
381 | (defun pool-class (class-name) |
---|
382 | (let ((class-name class-name)) |
---|
383 | (dotimes (i (length class-name)) |
---|
384 | (when (eql (char class-name i) #\.) |
---|
385 | (setf (char class-name i) #\/))) |
---|
386 | (pool-get (list 7 (pool-name class-name))))) |
---|
387 | |
---|
388 | ;; (tag class-index name-and-type-index) |
---|
389 | (defun pool-field (class-name field-name type-name) |
---|
390 | (let* ((class-index (pool-class class-name)) |
---|
391 | (name-and-type-index (pool-name-and-type field-name type-name))) |
---|
392 | (pool-get (list 9 class-index name-and-type-index)))) |
---|
393 | |
---|
394 | ;; (tag class-index name-and-type-index) |
---|
395 | (defun pool-method (class-name method-name type-name) |
---|
396 | (let* ((class-index (pool-class class-name)) |
---|
397 | (name-and-type-index (pool-name-and-type method-name type-name))) |
---|
398 | (pool-get (list 10 class-index name-and-type-index)))) |
---|
399 | |
---|
400 | (defun pool-string (string) |
---|
401 | (pool-get (list 8 (pool-name string)))) |
---|
402 | |
---|
403 | (defun u2 (n) |
---|
404 | (list (ash n -8) (logand n #xff))) |
---|
405 | |
---|
406 | (defstruct instruction opcode args stack depth) |
---|
407 | |
---|
408 | (defun inst (opcode &optional args) |
---|
409 | (unless (listp args) |
---|
410 | (setq args (list args))) |
---|
411 | (make-instruction :opcode opcode :args args :stack nil :depth nil)) |
---|
412 | |
---|
413 | (defun emit (instr &rest args) |
---|
414 | (unless (numberp instr) |
---|
415 | (setq instr (get instr 'opcode))) |
---|
416 | (let ((instruction (inst instr args))) |
---|
417 | (setq *code* (cons instruction *code*)) |
---|
418 | instruction)) |
---|
419 | |
---|
420 | (defmacro emit-store-value () |
---|
421 | `(case *val* |
---|
422 | (0 |
---|
423 | (emit 'astore_0)) |
---|
424 | (1 |
---|
425 | (emit 'astore_1)) |
---|
426 | (2 |
---|
427 | (emit 'astore_2)) |
---|
428 | (3 |
---|
429 | (emit 'astore_3)) |
---|
430 | (t |
---|
431 | (emit 'astore *val*)))) |
---|
432 | |
---|
433 | (defmacro emit-push-value () |
---|
434 | `(case *val* |
---|
435 | (0 |
---|
436 | (emit 'aload_0)) |
---|
437 | (1 |
---|
438 | (emit 'aload_1)) |
---|
439 | (2 |
---|
440 | (emit 'aload_2)) |
---|
441 | (3 |
---|
442 | (emit 'aload_3)) |
---|
443 | (t |
---|
444 | (emit 'aload *val*)))) |
---|
445 | |
---|
446 | (defun remove-store-value () |
---|
447 | (let* ((instruction (car *code*)) |
---|
448 | (opcode (instruction-opcode instruction)) |
---|
449 | slot) |
---|
450 | (case opcode |
---|
451 | (75 |
---|
452 | (setf slot 0)) |
---|
453 | (76 |
---|
454 | (setf slot 1)) |
---|
455 | (77 |
---|
456 | (setf slot 2)) |
---|
457 | (78 |
---|
458 | (setf slot 3)) |
---|
459 | (58 |
---|
460 | (setf slot (car (instruction-args instruction))))) |
---|
461 | (when (and slot (= slot *val*)) |
---|
462 | (setf *code* (cdr *code*)) |
---|
463 | t))) |
---|
464 | |
---|
465 | (defconstant +lisp-class+ "org/armedbear/lisp/Lisp") |
---|
466 | (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") |
---|
467 | (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") |
---|
468 | (defconstant +lisp-string+ "Lorg/armedbear/lisp/LispString;") |
---|
469 | (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") |
---|
470 | (defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread") |
---|
471 | |
---|
472 | (defun emit-push-nil () |
---|
473 | (emit 'getstatic |
---|
474 | +lisp-class+ |
---|
475 | "NIL" |
---|
476 | +lisp-object+)) |
---|
477 | |
---|
478 | (defun emit-push-t () |
---|
479 | (emit 'getstatic |
---|
480 | +lisp-class+ |
---|
481 | "T" |
---|
482 | "Lorg/armedbear/lisp/Symbol;")) |
---|
483 | |
---|
484 | (defun emit-invokestatic (class-name method-name descriptor stack) |
---|
485 | (assert stack) |
---|
486 | (let ((instruction (emit 'invokestatic class-name method-name descriptor))) |
---|
487 | (setf (instruction-stack instruction) stack) |
---|
488 | (assert (eql (instruction-stack instruction) stack)))) |
---|
489 | |
---|
490 | (defun emit-invokespecial (class-name method-name descriptor stack) |
---|
491 | (let ((instruction (emit 'invokespecial class-name method-name descriptor))) |
---|
492 | (setf (instruction-stack instruction) stack))) |
---|
493 | |
---|
494 | (defun emit-invokevirtual (class-name method-name descriptor stack) |
---|
495 | (let ((instruction (emit 'invokevirtual class-name method-name descriptor))) |
---|
496 | (setf (instruction-stack instruction) stack))) |
---|
497 | |
---|
498 | ;; Index of local variable used to hold the current thread. |
---|
499 | (defvar *thread* nil) |
---|
500 | (defvar *thread-var-initialized* nil) |
---|
501 | |
---|
502 | (defun ensure-thread-var-initialized () |
---|
503 | (unless *thread-var-initialized* |
---|
504 | ;; Put the code to initialize the local at the very beginning of the |
---|
505 | ;; function, to guarantee that the local gets initialized even if the code |
---|
506 | ;; at our current location is never executed, since the local may be |
---|
507 | ;; referenced elsewhere too. |
---|
508 | (let ((code *code*)) |
---|
509 | (setf *code* ()) |
---|
510 | (emit-invokestatic +lisp-thread-class+ |
---|
511 | "currentThread" |
---|
512 | "()Lorg/armedbear/lisp/LispThread;" |
---|
513 | 1) |
---|
514 | (emit 'astore *thread*) |
---|
515 | (setf *code* (append code *code*))) |
---|
516 | (setf *thread-var-initialized* t))) |
---|
517 | |
---|
518 | (defun emit-clear-values () |
---|
519 | (ensure-thread-var-initialized) |
---|
520 | (emit 'aload *thread*) |
---|
521 | (emit-invokevirtual +lisp-thread-class+ "clearValues" "()V" -1)) |
---|
522 | |
---|
523 | (defun emit-invoke-method (method-name) |
---|
524 | (unless (remove-store-value) |
---|
525 | (emit-push-value)) |
---|
526 | (emit-invokevirtual +lisp-object-class+ |
---|
527 | method-name |
---|
528 | "()Lorg/armedbear/lisp/LispObject;" |
---|
529 | 0) |
---|
530 | (emit-store-value)) |
---|
531 | |
---|
532 | ;; CODE is a list. |
---|
533 | (defun resolve-args (instruction) |
---|
534 | (let ((opcode (instruction-opcode instruction)) |
---|
535 | (args (instruction-args instruction))) |
---|
536 | (case opcode |
---|
537 | ((1 ; ACONST_NULL |
---|
538 | 42 ; ALOAD_0 |
---|
539 | 43 ; ALOAD_1 |
---|
540 | 44 ; ALOAD_2 |
---|
541 | 45 ; ALOAD_3 |
---|
542 | 50 ; AALOAD |
---|
543 | 75 ; ASTORE_0 |
---|
544 | 76 ; ASTORE_1 |
---|
545 | 77 ; ASTORE_2 |
---|
546 | 78 ; ASTORE_3 |
---|
547 | 83 ; AASTORE |
---|
548 | 87 ; POP |
---|
549 | 89 ; DUP |
---|
550 | 95 ; SWAP |
---|
551 | 153 ; IFEQ |
---|
552 | 154 ; IFNE |
---|
553 | 166 ; IF_ACMPNE |
---|
554 | 165 ; IF_ACMPEQ |
---|
555 | 167 ; GOTO |
---|
556 | 176 ; ARETURN |
---|
557 | 177 ; RETURN |
---|
558 | 202 ; LABEL |
---|
559 | ) |
---|
560 | instruction) |
---|
561 | (25 ; ALOAD |
---|
562 | (let ((index (car args))) |
---|
563 | (cond ((= index 0) |
---|
564 | (inst 42)) ; ALOAD_O |
---|
565 | ((= index 1) |
---|
566 | (inst 43)) ; ALOAD_1 |
---|
567 | ((= index 2) |
---|
568 | (inst 44)) ; ALOAD_2 |
---|
569 | ((= index 3) |
---|
570 | (inst 45)) ; ALOAD_3 |
---|
571 | ((<= 0 index 255) |
---|
572 | (inst 25 index)) |
---|
573 | (t |
---|
574 | (error "ALOAD unsupported case"))))) |
---|
575 | (58 ; ASTORE |
---|
576 | (let ((index (car args))) |
---|
577 | (cond ((= index 0) |
---|
578 | (inst 75)) ; ASTORE_O |
---|
579 | ((= index 1) |
---|
580 | (inst 76)) ; ASTORE_1 |
---|
581 | ((= index 2) |
---|
582 | (inst 77)) ; ASTORE_2 |
---|
583 | ((= index 3) |
---|
584 | (inst 78)) ; ASTORE_3 |
---|
585 | ((<= 0 index 255) |
---|
586 | (inst 58 index)) |
---|
587 | (t |
---|
588 | (error "ASTORE unsupported case"))))) |
---|
589 | ((178 ; GETSTATIC class-name field-name type-name |
---|
590 | 179 ; PUTSTATIC class-name field-name type-name |
---|
591 | ) |
---|
592 | (let ((index (pool-field (first args) (second args) (third args)))) |
---|
593 | (inst opcode (u2 index)))) |
---|
594 | ((182 ; INVOKEVIRTUAL class-name method-name descriptor |
---|
595 | 183 ; INVOKESPECIAL class-name method-name descriptor |
---|
596 | 184 ; INVOKESTATIC class-name method-name descriptor |
---|
597 | ) |
---|
598 | (let ((index (pool-method (first args) (second args) (third args)))) |
---|
599 | ;; (inst opcode (u2 index)))) |
---|
600 | (setf (instruction-args instruction) (u2 index)) |
---|
601 | instruction)) |
---|
602 | ((189 ; ANEWARRAY class-name |
---|
603 | ) |
---|
604 | (let ((index (pool-class (first args)))) |
---|
605 | (inst opcode (u2 index)))) |
---|
606 | ((16 ; BIPUSH |
---|
607 | 17 ; SIPUSH |
---|
608 | ) |
---|
609 | (let ((n (first args))) |
---|
610 | (cond ((= n 0) |
---|
611 | (inst 3)) ; ICONST_0 |
---|
612 | ((= n 1) |
---|
613 | (inst 4)) ; ICONST_1 |
---|
614 | ((= n 2) |
---|
615 | (inst 5)) ; ICONST_2 |
---|
616 | ((= n 3) |
---|
617 | (inst 6)) ; ICONST_3 |
---|
618 | ((= n 4) |
---|
619 | (inst 7)) ; ICONST_4 |
---|
620 | ((= n 5) |
---|
621 | (inst 8)) ; ICONST_5 |
---|
622 | ((<= -128 n 127) |
---|
623 | (inst 16 (logand n #xff))) ; BIPUSH |
---|
624 | (t ; SIPUSH |
---|
625 | (inst 17 (u2 n)))))) |
---|
626 | (18 ; LDC |
---|
627 | (unless (= (length args) 1) |
---|
628 | (error "wrong number of args for LDC")) |
---|
629 | (if (> (car args) 255) |
---|
630 | (inst 19 (u2 (car args))) ; LDC_W |
---|
631 | (inst opcode args))) |
---|
632 | (t |
---|
633 | (error "RESOLVE-ARGS unsupported opcode ~D" opcode))))) |
---|
634 | |
---|
635 | ;; CODE is a list of INSTRUCTIONs. |
---|
636 | (defun resolve-opcodes (code) |
---|
637 | (map 'vector #'resolve-args code)) |
---|
638 | |
---|
639 | (defun branch-opcode-p (opcode) |
---|
640 | (member opcode |
---|
641 | '(153 ; IFEQ |
---|
642 | 154 ; IFNE |
---|
643 | 165 ; IF_ACMPEQ |
---|
644 | 166 ; IF_ACMPNE |
---|
645 | 167 ; GOTO |
---|
646 | ))) |
---|
647 | |
---|
648 | (defun stack-effect (opcode) |
---|
649 | (case opcode |
---|
650 | ((25 ; ALOAD |
---|
651 | 42 ; ALOAD_0 |
---|
652 | 43 ; ALOAD_1 |
---|
653 | 44 ; ALOAD_2 |
---|
654 | 45 ; ALOAD_3 |
---|
655 | ) |
---|
656 | 1) |
---|
657 | ((58 ; ASTORE |
---|
658 | 75 ; ASTORE_0 |
---|
659 | 76 ; ASTORE_1 |
---|
660 | 77 ; ASTORE_2 |
---|
661 | 78 ; ASTORE_3 |
---|
662 | ) |
---|
663 | -1) |
---|
664 | (50 ; AALOAD |
---|
665 | -1) |
---|
666 | (83 ; AASTORE |
---|
667 | -3) |
---|
668 | ((1 ; ACONST_NULL |
---|
669 | 3 4 5 6 7 8 ; ICONST_0 ... ICONST_5 |
---|
670 | 16 ; BIPUSH |
---|
671 | 17 ; SIPUSH |
---|
672 | ) |
---|
673 | 1) |
---|
674 | (18 ; LDC |
---|
675 | 1) |
---|
676 | (178 ; GETSTATIC |
---|
677 | 1) |
---|
678 | (179 ; PUTSTATIC |
---|
679 | -1) |
---|
680 | (189 ; ANEWARRAY |
---|
681 | 0) |
---|
682 | ((153 ; IFEQ |
---|
683 | ) |
---|
684 | -1) |
---|
685 | ((165 ; IF_ACMPEQ |
---|
686 | 166 ; IF_ACMPNE |
---|
687 | ) |
---|
688 | -2) |
---|
689 | ((167 ; GOTO |
---|
690 | 202 ; LABEL |
---|
691 | ) |
---|
692 | 0) |
---|
693 | (89 ; DUP |
---|
694 | 1) |
---|
695 | (95 ; SWAP |
---|
696 | 0) |
---|
697 | (87 ; POP |
---|
698 | -1) |
---|
699 | (176 ; ARETURN |
---|
700 | -1) |
---|
701 | (177 ; RETURN |
---|
702 | 0) |
---|
703 | (t |
---|
704 | (format t "STACK-EFFECT unsupported opcode ~S~%" |
---|
705 | (instruction-opcode instruction)) |
---|
706 | 0))) |
---|
707 | |
---|
708 | (defun walk-code (code start-index depth) |
---|
709 | (do* ((i start-index (1+ i)) |
---|
710 | (limit (length code))) |
---|
711 | ((>= i limit) depth) |
---|
712 | (let ((instruction (svref code i))) |
---|
713 | (when (instruction-depth instruction) |
---|
714 | (return-from walk-code)) |
---|
715 | (setf (instruction-depth instruction) depth) |
---|
716 | (setf depth (+ depth (instruction-stack instruction))) |
---|
717 | (if (branch-opcode-p (instruction-opcode instruction)) |
---|
718 | (let ((label (car (instruction-args instruction)))) |
---|
719 | ;; (format t "target = ~S~%" target) |
---|
720 | (walk-code code (symbol-value label) depth) |
---|
721 | ) |
---|
722 | ())))) |
---|
723 | |
---|
724 | (defun analyze-stack () |
---|
725 | (sys::require-type *code* 'vector) |
---|
726 | (dotimes (i (length *code*)) |
---|
727 | (let* ((instruction (svref *code* i)) |
---|
728 | (opcode (instruction-opcode instruction))) |
---|
729 | (when (eql opcode 202) |
---|
730 | (let ((label (car (instruction-args instruction)))) |
---|
731 | (set label i))) |
---|
732 | (unless (instruction-stack instruction) |
---|
733 | (setf (instruction-stack instruction) (stack-effect opcode))))) |
---|
734 | (walk-code *code* 0 0) |
---|
735 | (let ((max-stack 0)) |
---|
736 | (dotimes (i (length *code*)) |
---|
737 | (let ((instruction (svref *code* i))) |
---|
738 | (setf max-stack (max max-stack (instruction-depth instruction))))) |
---|
739 | ;; (format t "max-stack = ~D~%" max-stack) |
---|
740 | max-stack)) |
---|
741 | |
---|
742 | (defun finalize-code () |
---|
743 | (setf *code* (nreverse (coerce *code* 'vector)))) |
---|
744 | |
---|
745 | (defun optimize-code () |
---|
746 | (dotimes (i (length *code*)) |
---|
747 | (let ((instruction (svref *code* i))) |
---|
748 | (when (and (< i (1- (length *code*))) |
---|
749 | (= (instruction-opcode instruction) 167) ; GOTO |
---|
750 | (let ((next-instruction (svref *code* (1+ i)))) |
---|
751 | (when (and (= (instruction-opcode next-instruction) 202) ; LABEL |
---|
752 | (eq (car (instruction-args instruction)) |
---|
753 | (car (instruction-args next-instruction)))) |
---|
754 | (setf (instruction-opcode instruction) 0))))))) |
---|
755 | |
---|
756 | (setf *code* (delete 0 *code* :key #'instruction-opcode)) |
---|
757 | ) |
---|
758 | |
---|
759 | (defvar *max-stack*) |
---|
760 | |
---|
761 | ;; CODE is a list of INSTRUCTIONs. |
---|
762 | (defun code-bytes (code) |
---|
763 | |
---|
764 | ;; (fresh-line) |
---|
765 | ;; (format t "-- begin code --~%") |
---|
766 | ;; (dotimes (i (length code)) |
---|
767 | ;; (format t "~S~%" (svref code i))) |
---|
768 | ;; (format t "--- end code ---~%") |
---|
769 | |
---|
770 | ;; ;; Make a list of the labels that are actually branched to. |
---|
771 | ;; (let ((branch-targets ())) |
---|
772 | ;; (dotimes (i (length code)) |
---|
773 | ;; (let ((instruction (svref code i))) |
---|
774 | ;; (when (branch-opcode-p (instruction-opcode instruction)) |
---|
775 | ;; (push branch-targets (car (instruction-args instruction)))))) |
---|
776 | ;; (format t "branch-targets = ~S~%" branch-targets) |
---|
777 | |
---|
778 | ;; ;; Remove labels that are not used as branch targets. |
---|
779 | ;; (dotimes (i (length code)) |
---|
780 | ;; (let ((instruction (svref code i))) |
---|
781 | ;; (when (= (instruction-opcode instruction) 202) ; LABEL |
---|
782 | ;; (let ((label (car (instruction-args instruction)))) |
---|
783 | ;; (unless (member label branch-targets) |
---|
784 | ;; (setf (instruction-opcode instruction) 0))))))) |
---|
785 | |
---|
786 | ;; (dotimes (i (length code)) |
---|
787 | ;; (let ((instruction (svref code i))) |
---|
788 | ;; (when (and (< i (1- (length code))) |
---|
789 | ;; (= (instruction-opcode instruction) 167) ; GOTO |
---|
790 | ;; (let ((next-instruction (svref code (1+ i)))) |
---|
791 | ;; (when (and (= (instruction-opcode next-instruction) 202) ; LABEL |
---|
792 | ;; (eq (car (instruction-args instruction)) |
---|
793 | ;; (car (instruction-args next-instruction)))) |
---|
794 | ;; (setf (instruction-opcode instruction) 0))))))) |
---|
795 | |
---|
796 | ;; (setf code (delete 0 code :key #'instruction-opcode)) |
---|
797 | |
---|
798 | ;; (fresh-line) |
---|
799 | ;; (format t "-- begin code --~%") |
---|
800 | ;; (dotimes (i (length code)) |
---|
801 | ;; (format t "~S~%" (svref code i))) |
---|
802 | ;; (format t "--- end code ---~%") |
---|
803 | |
---|
804 | ;; (setf code (coerce code 'list)) |
---|
805 | |
---|
806 | ;; FIXME Do stack analysis here! |
---|
807 | ;; (setf *max-stack* (analyze-stack code)) |
---|
808 | |
---|
809 | (let ((code (resolve-opcodes code)) |
---|
810 | (length 0)) |
---|
811 | ;; Pass 1: calculate label offsets and overall length. |
---|
812 | (dotimes (i (length code)) |
---|
813 | (let* ((instruction (aref code i)) |
---|
814 | (opcode (instruction-opcode instruction))) |
---|
815 | (if (= opcode 202) ; LABEL |
---|
816 | (let ((label (car (instruction-args instruction)))) |
---|
817 | (set label length)) |
---|
818 | (incf length (opcode-size opcode))))) |
---|
819 | ;; Pass 2: replace labels with calculated offsets. |
---|
820 | (let ((index 0)) |
---|
821 | (dotimes (i (length code)) |
---|
822 | (let ((instruction (aref code i))) |
---|
823 | (when (branch-opcode-p (instruction-opcode instruction)) |
---|
824 | (let* ((label (car (instruction-args instruction))) |
---|
825 | (offset (- (symbol-value `,label) index))) |
---|
826 | (setf (instruction-args instruction) (u2 offset)))) |
---|
827 | (unless (= (instruction-opcode instruction) 202) ; LABEL |
---|
828 | (incf index (opcode-size (instruction-opcode instruction))))))) |
---|
829 | |
---|
830 | ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. |
---|
831 | (let ((bytes (make-array length)) |
---|
832 | (index 0)) |
---|
833 | (dotimes (i (length code)) |
---|
834 | (let ((instruction (aref code i))) |
---|
835 | (unless (= (instruction-opcode instruction) 202) ; LABEL |
---|
836 | (setf (svref bytes index) (instruction-opcode instruction)) |
---|
837 | (incf index) |
---|
838 | (dolist (byte (instruction-args instruction)) |
---|
839 | (setf (svref bytes index) byte) |
---|
840 | (incf index))))) |
---|
841 | bytes))) |
---|
842 | |
---|
843 | (defun write-u1 (n) |
---|
844 | (write-byte (logand n #xFF) *stream*)) |
---|
845 | |
---|
846 | (defun write-u2 (n) |
---|
847 | (write-byte (ash n -8) *stream*) |
---|
848 | (write-byte (logand n #xFF) *stream*)) |
---|
849 | |
---|
850 | (defun write-u4 (n) |
---|
851 | (write-u2 (ash n -16)) |
---|
852 | (write-u2 (logand n #xFFFF))) |
---|
853 | |
---|
854 | (defun write-utf8 (string) |
---|
855 | (dotimes (i (length string)) |
---|
856 | (write-u1 (char-int (char string i))))) |
---|
857 | |
---|
858 | (defun write-cp-entry (entry) |
---|
859 | (write-u1 (first entry)) |
---|
860 | (case (first entry) |
---|
861 | (1 |
---|
862 | (write-u2 (second entry)) |
---|
863 | (write-utf8 (third entry))) |
---|
864 | ((5 6) |
---|
865 | (write-u4 (second entry)) |
---|
866 | (write-u4 (third entry))) |
---|
867 | ((9 10 11 12) |
---|
868 | (write-u2 (second entry)) |
---|
869 | (write-u2 (third entry))) |
---|
870 | ((7 8) |
---|
871 | (write-u2 (second entry))) |
---|
872 | (t |
---|
873 | (error "WRITE-CP-ENTRY unhandled tag ~D~%" (car entry))) |
---|
874 | )) |
---|
875 | |
---|
876 | (defun write-pool () |
---|
877 | (write-u2 *pool-count*) |
---|
878 | (dolist (entry (reverse *pool*)) |
---|
879 | (write-cp-entry entry))) |
---|
880 | |
---|
881 | (defstruct field |
---|
882 | access-flags |
---|
883 | name |
---|
884 | descriptor |
---|
885 | name-index |
---|
886 | descriptor-index) |
---|
887 | |
---|
888 | (defstruct method |
---|
889 | access-flags |
---|
890 | name |
---|
891 | descriptor |
---|
892 | name-index |
---|
893 | descriptor-index |
---|
894 | max-stack |
---|
895 | max-locals |
---|
896 | code) |
---|
897 | |
---|
898 | (defun make-constructor (super name args body) |
---|
899 | (let* ((constructor (make-method :name "<init>" |
---|
900 | :descriptor "()V")) |
---|
901 | (*code* ())) |
---|
902 | (setf (method-name-index constructor) (pool-name (method-name constructor))) |
---|
903 | (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor))) |
---|
904 | (setf (method-max-locals constructor) 1) |
---|
905 | (cond (*hairy-arglist-p* |
---|
906 | (emit 'aload_0) ;; this |
---|
907 | (emit 'aconst_null) ;; name |
---|
908 | (let ((s (format nil "~S" args))) |
---|
909 | (emit 'ldc |
---|
910 | (pool-string s)) |
---|
911 | (emit-invokestatic "org/armedbear/lisp/Lisp" |
---|
912 | "readObjectFromString" |
---|
913 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
914 | 0)) |
---|
915 | (emit-push-nil) ;; body |
---|
916 | (emit 'aconst_null) ;; environment |
---|
917 | (emit-invokespecial super |
---|
918 | "<init>" |
---|
919 | "(Ljava/lang/String;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V" |
---|
920 | -4)) |
---|
921 | (t |
---|
922 | (emit 'aload_0) |
---|
923 | (emit-invokespecial super |
---|
924 | "<init>" |
---|
925 | "()V" |
---|
926 | 0))) |
---|
927 | (setf *code* (append *static-code* *code*)) |
---|
928 | (emit 'return) |
---|
929 | (finalize-code) |
---|
930 | (optimize-code) |
---|
931 | (setf (method-max-stack constructor) (analyze-stack)) |
---|
932 | (setf (method-code constructor) (code-bytes *code*)) |
---|
933 | constructor)) |
---|
934 | |
---|
935 | (defun write-code-attr (method) |
---|
936 | (let* ((name-index (pool-name "Code")) |
---|
937 | (code (method-code method)) |
---|
938 | (code-length (length code)) |
---|
939 | (length (+ code-length 12)) |
---|
940 | (max-stack (or (method-max-stack method) 20)) |
---|
941 | (max-locals (or (method-max-locals method) 1))) |
---|
942 | (write-u2 name-index) |
---|
943 | (write-u4 length) |
---|
944 | (write-u2 max-stack) |
---|
945 | (write-u2 max-locals) |
---|
946 | (write-u4 code-length) |
---|
947 | (dotimes (i code-length) |
---|
948 | (write-u1 (svref code i))) |
---|
949 | (write-u2 0) ; exception table length |
---|
950 | (write-u2 0) ; attributes count |
---|
951 | )) |
---|
952 | |
---|
953 | (defun write-method (method) |
---|
954 | (write-u2 (or (method-access-flags method) #x1)) ; access flags |
---|
955 | (write-u2 (method-name-index method)) |
---|
956 | (write-u2 (method-descriptor-index method)) |
---|
957 | (write-u2 1) ; attributes count |
---|
958 | (write-code-attr method)) |
---|
959 | |
---|
960 | (defun write-field (field) |
---|
961 | (write-u2 (or (field-access-flags field) #x1)) ; access flags |
---|
962 | (write-u2 (field-name-index field)) |
---|
963 | (write-u2 (field-descriptor-index field)) |
---|
964 | (write-u2 0)) ; attributes count |
---|
965 | |
---|
966 | (defun declare-field (name descriptor) |
---|
967 | (let ((field (make-field :name name :descriptor descriptor))) |
---|
968 | (setf (field-access-flags field) (logior #x8 #x2)) ; private static |
---|
969 | (setf (field-name-index field) (pool-name (field-name field))) |
---|
970 | (setf (field-descriptor-index field) (pool-name (field-descriptor field))) |
---|
971 | (setq *fields* (cons field *fields*)))) |
---|
972 | |
---|
973 | (defun sanitize (symbol) |
---|
974 | (let* ((input (symbol-name symbol)) |
---|
975 | (output (make-array (length input) :fill-pointer 0 :element-type 'character))) |
---|
976 | (dotimes (i (length input)) |
---|
977 | (let ((c (char-upcase (char input i)))) |
---|
978 | (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z)) |
---|
979 | (vector-push c output)) |
---|
980 | ((eql c #\-) |
---|
981 | (vector-push #\_ output))))) |
---|
982 | (when (plusp (length output)) |
---|
983 | output))) |
---|
984 | |
---|
985 | (defvar *declared-symbols* ()) |
---|
986 | (defvar *declared-functions* ()) |
---|
987 | |
---|
988 | (defun declare-symbol (symbol) |
---|
989 | (let ((g (gethash symbol *declared-symbols*))) |
---|
990 | (unless g |
---|
991 | (let ((*code* *static-code*) |
---|
992 | (s (sanitize symbol))) |
---|
993 | (setq g (symbol-name (gensym))) |
---|
994 | (when s |
---|
995 | (setq g (concatenate 'string g "_" s))) |
---|
996 | (declare-field g "Lorg/armedbear/lisp/Symbol;") |
---|
997 | (emit 'ldc |
---|
998 | (pool-string (symbol-name symbol))) |
---|
999 | (emit 'ldc |
---|
1000 | (pool-string (package-name (symbol-package symbol)))) |
---|
1001 | (emit-invokestatic +lisp-class+ |
---|
1002 | "internInPackage" |
---|
1003 | "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" |
---|
1004 | -1) |
---|
1005 | (emit 'putstatic |
---|
1006 | *this-class* |
---|
1007 | g |
---|
1008 | "Lorg/armedbear/lisp/Symbol;") |
---|
1009 | (setq *static-code* *code*) |
---|
1010 | (setf (gethash symbol *declared-symbols*) g))) |
---|
1011 | g)) |
---|
1012 | |
---|
1013 | (defun declare-function (symbol) |
---|
1014 | (let ((f (gethash symbol *declared-functions*))) |
---|
1015 | (unless f |
---|
1016 | (setf f (symbol-name (gensym))) |
---|
1017 | (let ((s (sanitize symbol))) |
---|
1018 | (when s |
---|
1019 | (setf f (concatenate 'string f "_" s)))) |
---|
1020 | (let ((*code* *static-code*) |
---|
1021 | (g (gethash symbol *declared-symbols*))) |
---|
1022 | (cond (g |
---|
1023 | (emit 'getstatic |
---|
1024 | *this-class* |
---|
1025 | g |
---|
1026 | "Lorg/armedbear/lisp/Symbol;")) |
---|
1027 | (t |
---|
1028 | (emit 'ldc |
---|
1029 | (pool-string (symbol-name symbol))) |
---|
1030 | (emit 'ldc |
---|
1031 | (pool-string (package-name (symbol-package symbol)))) |
---|
1032 | (emit-invokestatic +lisp-class+ |
---|
1033 | "internInPackage" |
---|
1034 | "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" |
---|
1035 | -1))) |
---|
1036 | (declare-field f "Lorg/armedbear/lisp/LispObject;") |
---|
1037 | (emit-invokevirtual +lisp-symbol-class+ |
---|
1038 | "getSymbolFunctionOrDie" |
---|
1039 | "()Lorg/armedbear/lisp/LispObject;" |
---|
1040 | 0) |
---|
1041 | (emit 'putstatic |
---|
1042 | *this-class* |
---|
1043 | f |
---|
1044 | "Lorg/armedbear/lisp/LispObject;") |
---|
1045 | (setq *static-code* *code*) |
---|
1046 | (setf (gethash symbol *declared-functions*) f))) |
---|
1047 | f)) |
---|
1048 | |
---|
1049 | (defun declare-keyword (symbol) |
---|
1050 | (let ((g (symbol-name (gensym))) |
---|
1051 | (*code* *static-code*)) |
---|
1052 | (declare-field g "Lorg/armedbear/lisp/Symbol;") |
---|
1053 | (emit 'ldc |
---|
1054 | (pool-string (symbol-name symbol))) |
---|
1055 | (emit-invokestatic "org/armedbear/lisp/Keyword" |
---|
1056 | "internKeyword" |
---|
1057 | "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" |
---|
1058 | 0) |
---|
1059 | (emit 'putstatic |
---|
1060 | *this-class* |
---|
1061 | g |
---|
1062 | "Lorg/armedbear/lisp/Symbol;") |
---|
1063 | (setq *static-code* *code*) |
---|
1064 | g)) |
---|
1065 | |
---|
1066 | (defun declare-object-as-string (obj) |
---|
1067 | (let ((g (symbol-name (gensym))) |
---|
1068 | (s (format nil "~S" obj)) |
---|
1069 | (*code* *static-code*)) |
---|
1070 | (declare-field g +lisp-object+) |
---|
1071 | (emit 'ldc |
---|
1072 | (pool-string s)) |
---|
1073 | (emit-invokestatic +lisp-class+ |
---|
1074 | "readObjectFromString" |
---|
1075 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" |
---|
1076 | 0) |
---|
1077 | (emit 'putstatic |
---|
1078 | *this-class* |
---|
1079 | g |
---|
1080 | +lisp-object+) |
---|
1081 | (setq *static-code* *code*) |
---|
1082 | g)) |
---|
1083 | |
---|
1084 | (defun declare-object (obj) |
---|
1085 | (let ((key (symbol-name (gensym)))) |
---|
1086 | (sys::remember key obj) |
---|
1087 | (let* ((g1 (declare-string key)) |
---|
1088 | (g2 (symbol-name (gensym))) |
---|
1089 | (*code* *static-code*)) |
---|
1090 | (declare-field g2 +lisp-object+) |
---|
1091 | (emit 'getstatic |
---|
1092 | *this-class* |
---|
1093 | g1 |
---|
1094 | +lisp-string+) |
---|
1095 | (emit 'dup) |
---|
1096 | (emit-invokestatic +lisp-class+ |
---|
1097 | "recall" |
---|
1098 | "(Lorg/armedbear/lisp/LispString;)Lorg/armedbear/lisp/LispObject;" |
---|
1099 | 0) |
---|
1100 | (emit 'putstatic |
---|
1101 | *this-class* |
---|
1102 | g2 |
---|
1103 | +lisp-object+) |
---|
1104 | (emit-invokestatic +lisp-class+ |
---|
1105 | "forget" |
---|
1106 | "(Lorg/armedbear/lisp/LispString;)V" |
---|
1107 | -1) |
---|
1108 | (setq *static-code* *code*) |
---|
1109 | g2))) |
---|
1110 | |
---|
1111 | (defun declare-string (string) |
---|
1112 | (let ((g (symbol-name (gensym))) |
---|
1113 | (*code* *static-code*)) |
---|
1114 | (declare-field g "Lorg/armedbear/lisp/LispString;") |
---|
1115 | (emit 'ldc |
---|
1116 | (pool-string string)) |
---|
1117 | (emit-invokestatic "org/armedbear/lisp/LispString" |
---|
1118 | "getInstance" |
---|
1119 | "(Ljava/lang/String;)Lorg/armedbear/lisp/LispString;" |
---|
1120 | 0) |
---|
1121 | (emit 'putstatic |
---|
1122 | *this-class* |
---|
1123 | g |
---|
1124 | +lisp-string+) |
---|
1125 | (setq *static-code* *code*) |
---|
1126 | g)) |
---|
1127 | |
---|
1128 | (defun compile-constant (form) |
---|
1129 | (cond |
---|
1130 | ((sys::fixnump form) |
---|
1131 | (let ((n form)) |
---|
1132 | (cond ((zerop n) |
---|
1133 | (emit 'getstatic |
---|
1134 | "org/armedbear/lisp/Fixnum" |
---|
1135 | "ZERO" |
---|
1136 | "Lorg/armedbear/lisp/Fixnum;") |
---|
1137 | (emit-store-value)) |
---|
1138 | ((= n 1) |
---|
1139 | (emit 'getstatic |
---|
1140 | "org/armedbear/lisp/Fixnum" |
---|
1141 | "ONE" |
---|
1142 | "Lorg/armedbear/lisp/Fixnum;") |
---|
1143 | (emit-store-value)) |
---|
1144 | ((= n 2) |
---|
1145 | (emit 'getstatic |
---|
1146 | "org/armedbear/lisp/Fixnum" |
---|
1147 | "TWO" |
---|
1148 | "Lorg/armedbear/lisp/Fixnum;") |
---|
1149 | (emit-store-value)) |
---|
1150 | (t |
---|
1151 | (let ((g (declare-object-as-string n))) |
---|
1152 | (emit 'getstatic |
---|
1153 | *this-class* |
---|
1154 | g |
---|
1155 | "Lorg/armedbear/lisp/LispObject;") |
---|
1156 | (emit-store-value)))))) |
---|
1157 | ((numberp form) |
---|
1158 | (let ((g (declare-object-as-string form))) |
---|
1159 | (emit 'getstatic |
---|
1160 | *this-class* |
---|
1161 | g |
---|
1162 | "Lorg/armedbear/lisp/LispObject;") |
---|
1163 | (emit-store-value))) |
---|
1164 | ((vectorp form) |
---|
1165 | (let ((g (declare-object-as-string form))) |
---|
1166 | (emit 'getstatic |
---|
1167 | *this-class* |
---|
1168 | g |
---|
1169 | "Lorg/armedbear/lisp/LispObject;") |
---|
1170 | (emit-store-value))) |
---|
1171 | ((stringp form) |
---|
1172 | (let ((g (declare-string form))) |
---|
1173 | (emit 'getstatic |
---|
1174 | *this-class* |
---|
1175 | g |
---|
1176 | "Lorg/armedbear/lisp/LispString;") |
---|
1177 | (emit-store-value))) |
---|
1178 | ((characterp form) |
---|
1179 | (let ((g (declare-object-as-string form))) |
---|
1180 | (emit 'getstatic |
---|
1181 | *this-class* |
---|
1182 | g |
---|
1183 | "Lorg/armedbear/lisp/LispObject;") |
---|
1184 | (emit-store-value))) |
---|
1185 | ((symbolp form) |
---|
1186 | (when (null (symbol-package form)) |
---|
1187 | ;; An uninterned symbol. |
---|
1188 | (let ((g (declare-object form))) |
---|
1189 | (emit 'getstatic |
---|
1190 | *this-class* |
---|
1191 | g |
---|
1192 | "Lorg/armedbear/lisp/LispObject;") |
---|
1193 | (emit-store-value)))) |
---|
1194 | (t |
---|
1195 | (error "COMPILE-CONSTANT unhandled case ~S" form)))) |
---|
1196 | |
---|
1197 | (defun compile-binary-operation (op args) |
---|
1198 | (compile-form (first args)) |
---|
1199 | (unless (remove-store-value) |
---|
1200 | (emit-push-value)) |
---|
1201 | (compile-form (second args)) |
---|
1202 | (unless (remove-store-value) |
---|
1203 | (emit-push-value)) |
---|
1204 | (emit-invokevirtual +lisp-object-class+ |
---|
1205 | op |
---|
1206 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
1207 | -1) |
---|
1208 | (emit-store-value)) |
---|
1209 | |
---|
1210 | (defparameter unary-operators (make-hash-table)) |
---|
1211 | |
---|
1212 | (setf (gethash '1+ unary-operators) "incr") |
---|
1213 | (setf (gethash '1- unary-operators) "decr") |
---|
1214 | (setf (gethash 'ATOM unary-operators) "ATOM") |
---|
1215 | (setf (gethash 'BIT-VECTOR-P unary-operators) "BIT_VECTOR_P") |
---|
1216 | (setf (gethash 'CADR unary-operators) "cadr") |
---|
1217 | (setf (gethash 'CAR unary-operators) "car") |
---|
1218 | (setf (gethash 'CDDR unary-operators) "cddr") |
---|
1219 | (setf (gethash 'CDR unary-operators) "cdr") |
---|
1220 | (setf (gethash 'COMPLEXP unary-operators) "COMPLEXP") |
---|
1221 | (setf (gethash 'CONSTANTP unary-operators) "CONSTANTP") |
---|
1222 | (setf (gethash 'DENOMINATOR unary-operators) "DENOMINATOR") |
---|
1223 | (setf (gethash 'ENDP unary-operators) "ENDP") |
---|
1224 | (setf (gethash 'EVENP unary-operators) "EVENP") |
---|
1225 | (setf (gethash 'FIRST unary-operators) "car") |
---|
1226 | (setf (gethash 'FLOATP unary-operators) "FLOATP") |
---|
1227 | (setf (gethash 'INTEGERP unary-operators) "INTEGERP") |
---|
1228 | (setf (gethash 'LENGTH unary-operators) "LENGTH") |
---|
1229 | (setf (gethash 'LISTP unary-operators) "LISTP") |
---|
1230 | (setf (gethash 'MINUSP unary-operators) "MINUSP") |
---|
1231 | (setf (gethash 'NOT unary-operators) "NOT") |
---|
1232 | (setf (gethash 'NREVERSE unary-operators) "nreverse") |
---|
1233 | (setf (gethash 'NULL unary-operators) "NOT") |
---|
1234 | (setf (gethash 'NUMBERP unary-operators) "NUMBERP") |
---|
1235 | (setf (gethash 'NUMERATOR unary-operators) "NUMERATOR") |
---|
1236 | (setf (gethash 'ODDP unary-operators) "ODDP") |
---|
1237 | (setf (gethash 'PLUSP unary-operators) "PLUSP") |
---|
1238 | (setf (gethash 'RATIONALP unary-operators) "RATIONALP") |
---|
1239 | (setf (gethash 'REALP unary-operators) "REALP") |
---|
1240 | (setf (gethash 'REST unary-operators) "cdr") |
---|
1241 | (setf (gethash 'SECOND unary-operators) "cadr") |
---|
1242 | (setf (gethash 'SIMPLE-STRING-P unary-operators) "SIMPLE_STRING_P") |
---|
1243 | (setf (gethash 'STRINGP unary-operators) "STRINGP") |
---|
1244 | (setf (gethash 'SYMBOLP unary-operators) "SYMBOLP") |
---|
1245 | (setf (gethash 'VECTORP unary-operators) "VECTORP") |
---|
1246 | (setf (gethash 'ZEROP unary-operators) "ZEROP") |
---|
1247 | |
---|
1248 | |
---|
1249 | (defun compile-function-call-1 (fun args) |
---|
1250 | (let ((s (gethash fun unary-operators))) |
---|
1251 | (when s |
---|
1252 | (compile-form (first args)) |
---|
1253 | (emit-invoke-method s) |
---|
1254 | (return-from compile-function-call-1 t))) |
---|
1255 | nil) |
---|
1256 | |
---|
1257 | (defun compile-function-call-2 (fun args) |
---|
1258 | (case fun |
---|
1259 | (EQ |
---|
1260 | (compile-form (first args)) |
---|
1261 | (unless (remove-store-value) |
---|
1262 | (emit-push-value)) |
---|
1263 | (compile-form (second args)) |
---|
1264 | (unless (remove-store-value) |
---|
1265 | (emit-push-value)) |
---|
1266 | (let ((label1 (gensym)) |
---|
1267 | (label2 (gensym))) |
---|
1268 | (emit 'if_acmpeq `,label1) |
---|
1269 | (emit-push-nil) |
---|
1270 | (emit 'goto `,label2) |
---|
1271 | (emit 'label `,label1) |
---|
1272 | (emit-push-t) |
---|
1273 | (emit 'label `,label2)) |
---|
1274 | (emit-store-value) |
---|
1275 | t) |
---|
1276 | (EQL |
---|
1277 | (compile-binary-operation "EQL" args) |
---|
1278 | t) |
---|
1279 | (+ |
---|
1280 | (compile-binary-operation "add" args) |
---|
1281 | t) |
---|
1282 | (- |
---|
1283 | (compile-binary-operation "subtract" args) |
---|
1284 | t) |
---|
1285 | (/ |
---|
1286 | (compile-binary-operation "divideBy" args) |
---|
1287 | t) |
---|
1288 | (* |
---|
1289 | (compile-binary-operation "multiplyBy" args) |
---|
1290 | t) |
---|
1291 | (< |
---|
1292 | (compile-binary-operation "IS_LT" args) |
---|
1293 | t) |
---|
1294 | (<= |
---|
1295 | (compile-binary-operation "IS_LE" args) |
---|
1296 | t) |
---|
1297 | (> |
---|
1298 | (compile-binary-operation "IS_GT" args) |
---|
1299 | t) |
---|
1300 | (>= |
---|
1301 | (compile-binary-operation "IS_GE" args) |
---|
1302 | t) |
---|
1303 | (= |
---|
1304 | (compile-binary-operation "IS_E" args) |
---|
1305 | t) |
---|
1306 | (/= |
---|
1307 | (compile-binary-operation "IS_NE" args) |
---|
1308 | t) |
---|
1309 | (AREF |
---|
1310 | (compile-binary-operation "AREF" args) |
---|
1311 | t) |
---|
1312 | (LIST |
---|
1313 | (compile-form (first args)) |
---|
1314 | (unless (remove-store-value) |
---|
1315 | (emit-push-value)) |
---|
1316 | (compile-form (second args)) |
---|
1317 | (unless (remove-store-value) |
---|
1318 | (emit-push-value)) |
---|
1319 | (emit-invokestatic +lisp-class+ |
---|
1320 | "list2" |
---|
1321 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;" |
---|
1322 | -1) |
---|
1323 | (emit-store-value) |
---|
1324 | t) |
---|
1325 | (SYS::SIMPLE-TYPEP |
---|
1326 | (compile-binary-operation "typep" args)) |
---|
1327 | (t |
---|
1328 | nil))) |
---|
1329 | |
---|
1330 | (defun compile-function-call-3 (fun args) |
---|
1331 | (case fun |
---|
1332 | (LIST |
---|
1333 | (compile-form (first args)) |
---|
1334 | (unless (remove-store-value) |
---|
1335 | (emit-push-value)) |
---|
1336 | (compile-form (second args)) |
---|
1337 | (unless (remove-store-value) |
---|
1338 | (emit-push-value)) |
---|
1339 | (compile-form (third args)) |
---|
1340 | (unless (remove-store-value) |
---|
1341 | (emit-push-value)) |
---|
1342 | (emit-invokestatic +lisp-class+ |
---|
1343 | "list3" |
---|
1344 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;" |
---|
1345 | -2) |
---|
1346 | (emit-store-value) |
---|
1347 | t) |
---|
1348 | (t |
---|
1349 | nil))) |
---|
1350 | |
---|
1351 | (defconstant +known-packages+ (list (find-package "COMMON-LISP") |
---|
1352 | (find-package "SYSTEM") |
---|
1353 | (find-package "EXTENSIONS"))) |
---|
1354 | |
---|
1355 | (defun compile-function-call (fun args &optional for-effect) |
---|
1356 | ;; (format t "compile-function-call fun = ~S args = ~S~%" fun args) |
---|
1357 | (unless (symbolp fun) |
---|
1358 | (error "COMPILE-FUNCTION-CALL ~S is not a symbol" fun)) |
---|
1359 | (let ((numargs (length args))) |
---|
1360 | (cond ((= numargs 1) |
---|
1361 | (when (compile-function-call-1 fun args) |
---|
1362 | (return-from compile-function-call))) |
---|
1363 | ((= numargs 2) |
---|
1364 | (when (compile-function-call-2 fun args) |
---|
1365 | (return-from compile-function-call))) |
---|
1366 | ((= numargs 3) |
---|
1367 | (when (compile-function-call-3 fun args) |
---|
1368 | (return-from compile-function-call)))) |
---|
1369 | |
---|
1370 | ;; FIXME This shouldn't go here! Do this in the constructor of the |
---|
1371 | ;; compiled function! |
---|
1372 | (resolve fun) |
---|
1373 | |
---|
1374 | (cond |
---|
1375 | ((eq fun *defun-name*) |
---|
1376 | (emit 'aload 0)) ; this |
---|
1377 | ((memq (symbol-package fun) +known-packages+) |
---|
1378 | (let ((f (declare-function fun))) |
---|
1379 | (emit 'getstatic |
---|
1380 | *this-class* |
---|
1381 | f |
---|
1382 | "Lorg/armedbear/lisp/LispObject;"))) |
---|
1383 | (t |
---|
1384 | (let ((g (declare-symbol fun))) |
---|
1385 | (emit 'getstatic |
---|
1386 | *this-class* |
---|
1387 | g |
---|
1388 | "Lorg/armedbear/lisp/Symbol;")) |
---|
1389 | (emit-invokevirtual +lisp-symbol-class+ |
---|
1390 | "getSymbolFunctionOrDie" |
---|
1391 | "()Lorg/armedbear/lisp/LispObject;" |
---|
1392 | 0))) |
---|
1393 | (case numargs |
---|
1394 | (0 |
---|
1395 | (emit-invokevirtual +lisp-object-class+ |
---|
1396 | "execute" |
---|
1397 | "()Lorg/armedbear/lisp/LispObject;" |
---|
1398 | 0)) |
---|
1399 | (1 |
---|
1400 | (compile-form (first args)) |
---|
1401 | (unless (remove-store-value) |
---|
1402 | (emit-push-value)) |
---|
1403 | (emit-invokevirtual +lisp-object-class+ |
---|
1404 | "execute" |
---|
1405 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
1406 | -1)) |
---|
1407 | (2 |
---|
1408 | (compile-form (first args)) |
---|
1409 | (unless (remove-store-value) |
---|
1410 | (emit-push-value)) |
---|
1411 | (compile-form (second args)) |
---|
1412 | (unless (remove-store-value) |
---|
1413 | (emit-push-value)) |
---|
1414 | (emit-invokevirtual +lisp-object-class+ |
---|
1415 | "execute" |
---|
1416 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
1417 | -2)) |
---|
1418 | (3 |
---|
1419 | (compile-form (first args)) |
---|
1420 | (unless (remove-store-value) |
---|
1421 | (emit-push-value)) |
---|
1422 | (compile-form (second args)) |
---|
1423 | (unless (remove-store-value) |
---|
1424 | (emit-push-value)) |
---|
1425 | (compile-form (third args)) |
---|
1426 | (unless (remove-store-value) |
---|
1427 | (emit-push-value)) |
---|
1428 | (emit-invokevirtual +lisp-object-class+ |
---|
1429 | "execute" |
---|
1430 | "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
1431 | -3)) |
---|
1432 | (t |
---|
1433 | (emit 'sipush (length args)) |
---|
1434 | (emit 'anewarray "org/armedbear/lisp/LispObject") |
---|
1435 | (let ((i 0)) |
---|
1436 | (dolist (form args) |
---|
1437 | (emit 'dup) |
---|
1438 | (emit 'sipush i) |
---|
1439 | (compile-form form) |
---|
1440 | (unless (remove-store-value) |
---|
1441 | (emit-push-value)) ; leaves value on stack |
---|
1442 | (emit 'aastore) ; store value in array |
---|
1443 | (incf i))) ; array left on stack here |
---|
1444 | ;; Stack: function array-ref |
---|
1445 | (emit-invokevirtual +lisp-object-class+ |
---|
1446 | "execute" |
---|
1447 | "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
1448 | -1))) |
---|
1449 | (if for-effect |
---|
1450 | (emit 'pop) |
---|
1451 | (emit-store-value)))) |
---|
1452 | |
---|
1453 | (defun compile-test (form) |
---|
1454 | ;; Use a Java boolean if possible. |
---|
1455 | (when (consp form) |
---|
1456 | (case (length form) |
---|
1457 | (2 (when (memq (car form) '(NOT NULL)) |
---|
1458 | (compile-form (second form)) |
---|
1459 | (unless (remove-store-value) |
---|
1460 | (emit-push-value)) |
---|
1461 | (emit-push-nil) |
---|
1462 | (return-from compile-test 'if_acmpne)) |
---|
1463 | (let ((s (cdr (assoc (car form) |
---|
1464 | '((ATOM . "atom") |
---|
1465 | (EVENP . "evenp") |
---|
1466 | (FLOATP . "floatp") |
---|
1467 | (INTEGERP . "integerp") |
---|
1468 | (MINUSP . "minusp") |
---|
1469 | (LISTP . "listp") |
---|
1470 | (NUMBERP . "numberp") |
---|
1471 | (ODDP . "oddp") |
---|
1472 | (PLUSP . "plusp") |
---|
1473 | (RATIONALP . "rationalp") |
---|
1474 | (REALP . "realp") |
---|
1475 | (VECTORP . "vectorp") |
---|
1476 | (ZEROP . "zerop") |
---|
1477 | ))))) |
---|
1478 | (when s |
---|
1479 | (compile-form (second form)) |
---|
1480 | (unless (remove-store-value) |
---|
1481 | (emit-push-value)) |
---|
1482 | (emit-invokevirtual +lisp-object-class+ |
---|
1483 | s |
---|
1484 | "()Z" |
---|
1485 | 0) |
---|
1486 | (return-from compile-test 'ifeq)))) |
---|
1487 | (3 (when (eq (car form) 'EQ) |
---|
1488 | (compile-form (second form)) |
---|
1489 | (unless (remove-store-value) |
---|
1490 | (emit-push-value)) |
---|
1491 | (compile-form (third form)) |
---|
1492 | (unless (remove-store-value) |
---|
1493 | (emit-push-value)) |
---|
1494 | (return-from compile-test 'if_acmpne)) |
---|
1495 | (let ((s (cdr (assoc (car form) |
---|
1496 | '((= . "isEqualTo") |
---|
1497 | (/= . "isNotEqualTo") |
---|
1498 | (< . "isLessThan") |
---|
1499 | (<= . "isLessThanOrEqualTo") |
---|
1500 | (> . "isGreaterThan") |
---|
1501 | (>= . "isGreaterThanOrEqualTo") |
---|
1502 | (EQL . "eql") |
---|
1503 | (EQUAL . "equal") |
---|
1504 | (EQUALP . "equalp") |
---|
1505 | ))))) |
---|
1506 | (when s |
---|
1507 | (compile-form (second form)) |
---|
1508 | (unless (remove-store-value) |
---|
1509 | (emit-push-value)) |
---|
1510 | (compile-form (third form)) |
---|
1511 | (unless (remove-store-value) |
---|
1512 | (emit-push-value)) |
---|
1513 | (emit-invokevirtual +lisp-object-class+ |
---|
1514 | s |
---|
1515 | "(Lorg/armedbear/lisp/LispObject;)Z" |
---|
1516 | -1) |
---|
1517 | (return-from compile-test 'ifeq)))))) |
---|
1518 | ;; Otherwise... |
---|
1519 | (compile-form form) |
---|
1520 | (unless (remove-store-value) |
---|
1521 | (emit-push-value)) |
---|
1522 | (emit-push-nil) |
---|
1523 | 'if_acmpeq) |
---|
1524 | |
---|
1525 | (defun compile-if (form for-effect) |
---|
1526 | (let* ((test (second form)) |
---|
1527 | (consequent (third form)) |
---|
1528 | (alternate (fourth form)) |
---|
1529 | (label1 (gensym)) |
---|
1530 | (label2 (gensym)) |
---|
1531 | (instr (compile-test test))) |
---|
1532 | (emit-clear-values) |
---|
1533 | (emit instr `,label1) |
---|
1534 | (compile-form consequent) |
---|
1535 | (emit 'goto `,label2) |
---|
1536 | (emit 'label `,label1) |
---|
1537 | (compile-form alternate) |
---|
1538 | (emit 'label `,label2))) |
---|
1539 | |
---|
1540 | (defun compile-multiple-value-list (form for-effect) |
---|
1541 | (compile-form (second form)) |
---|
1542 | (unless (remove-store-value) |
---|
1543 | (emit-push-value)) |
---|
1544 | (emit-invokestatic +lisp-class+ |
---|
1545 | "multipleValueList" |
---|
1546 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
1547 | 0) |
---|
1548 | (emit-store-value)) |
---|
1549 | |
---|
1550 | (defun compile-let/let* (form for-effect) |
---|
1551 | (let* ((saved-fp (fill-pointer *locals*)) |
---|
1552 | (varlist (second form)) |
---|
1553 | (specialp nil) |
---|
1554 | env-var) |
---|
1555 | ;; Are we going to bind any special variables? |
---|
1556 | (dolist (varspec varlist) |
---|
1557 | (let ((var (if (consp varspec) (car varspec) varspec))) |
---|
1558 | (when (special-variable-p var) |
---|
1559 | (setq specialp t) |
---|
1560 | (return)))) |
---|
1561 | ;; If so... |
---|
1562 | (when specialp |
---|
1563 | ;; Save current dynamic environment. |
---|
1564 | (setq env-var (vector-push nil *locals*)) |
---|
1565 | (setq *max-locals* (max *max-locals* (fill-pointer *locals*))) |
---|
1566 | (ensure-thread-var-initialized) |
---|
1567 | (emit 'aload *thread*) |
---|
1568 | (emit-invokevirtual +lisp-thread-class+ |
---|
1569 | "getDynamicEnvironment" |
---|
1570 | "()Lorg/armedbear/lisp/Environment;" |
---|
1571 | 0) |
---|
1572 | (emit 'astore env-var)) |
---|
1573 | (ecase (car form) |
---|
1574 | (LET |
---|
1575 | (compile-let-vars varlist)) |
---|
1576 | (LET* |
---|
1577 | (compile-let*-vars varlist))) |
---|
1578 | ;; Body of LET. |
---|
1579 | (do ((body (cddr form) (cdr body))) |
---|
1580 | ((null (cdr body)) |
---|
1581 | (compile-form (car body) nil)) |
---|
1582 | (compile-form (car body) t)) |
---|
1583 | (when specialp |
---|
1584 | ;; Restore dynamic environment. |
---|
1585 | (emit 'aload *thread*) |
---|
1586 | (emit 'aload env-var) |
---|
1587 | (emit-invokevirtual +lisp-thread-class+ |
---|
1588 | "setDynamicEnvironment" |
---|
1589 | "(Lorg/armedbear/lisp/Environment;)V" |
---|
1590 | -2)) |
---|
1591 | ;; Restore fill pointer to its saved value so the slots used by these |
---|
1592 | ;; bindings will again be available. |
---|
1593 | (setf (fill-pointer *locals*) saved-fp))) |
---|
1594 | |
---|
1595 | (defun compile-let-vars (varlist) |
---|
1596 | ;; Generate code to evaluate the initforms and leave the resulting values |
---|
1597 | ;; on the stack. |
---|
1598 | (let ((last-push-was-nil nil)) |
---|
1599 | (dolist (varspec varlist) |
---|
1600 | (let (var initform) |
---|
1601 | (if (consp varspec) |
---|
1602 | (setq var (car varspec) |
---|
1603 | initform (cadr varspec)) |
---|
1604 | (setq var varspec |
---|
1605 | initform nil)) |
---|
1606 | (cond (initform |
---|
1607 | (compile-form initform) |
---|
1608 | (emit-push-value) |
---|
1609 | (setf last-push-was-nil nil)) |
---|
1610 | (t |
---|
1611 | (if last-push-was-nil |
---|
1612 | (emit 'dup) |
---|
1613 | (emit-push-nil)) |
---|
1614 | (setf last-push-was-nil t)))))) |
---|
1615 | ;; Add local variables to local variables vector. |
---|
1616 | (dolist (varspec varlist) |
---|
1617 | (let ((var (if (consp varspec) (car varspec) varspec))) |
---|
1618 | (unless (special-variable-p var) |
---|
1619 | (vector-push var *locals*)))) |
---|
1620 | (setq *max-locals* (max *max-locals* (fill-pointer *locals*))) |
---|
1621 | ;; At this point the initial values are on the stack. Now generate code to |
---|
1622 | ;; pop them off one by one and store each one in the corresponding local or |
---|
1623 | ;; special variable. In order to do this, we must process the variable list |
---|
1624 | ;; in reverse order. |
---|
1625 | (do* ((varlist (reverse varlist) (cdr varlist)) |
---|
1626 | (varspec (car varlist) (car varlist)) |
---|
1627 | (var (if (consp varspec) (car varspec) varspec)) |
---|
1628 | (i (1- (fill-pointer *locals*)) (1- i))) |
---|
1629 | ((null varlist)) |
---|
1630 | (cond ((special-variable-p var) |
---|
1631 | (let ((g (declare-symbol var))) |
---|
1632 | (emit 'getstatic |
---|
1633 | *this-class* |
---|
1634 | g |
---|
1635 | "Lorg/armedbear/lisp/Symbol;") |
---|
1636 | (emit 'swap) |
---|
1637 | (emit-invokestatic +lisp-class+ |
---|
1638 | "bindSpecialVariable" |
---|
1639 | "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" |
---|
1640 | -2))) |
---|
1641 | (t |
---|
1642 | (emit 'astore i))))) |
---|
1643 | |
---|
1644 | (defun compile-let*-vars (varlist) |
---|
1645 | ;; Generate code to evaluate initforms and bind variables. |
---|
1646 | (let ((i (fill-pointer *locals*))) |
---|
1647 | (dolist (varspec varlist) |
---|
1648 | (let (var initform) |
---|
1649 | (if (consp varspec) |
---|
1650 | (setq var (car varspec) |
---|
1651 | initform (cadr varspec)) |
---|
1652 | (setq var varspec |
---|
1653 | initform nil)) |
---|
1654 | (cond (initform |
---|
1655 | (compile-form initform) |
---|
1656 | (emit-push-value)) |
---|
1657 | (t |
---|
1658 | (emit-push-nil))) |
---|
1659 | (cond ((special-variable-p var) |
---|
1660 | (let ((g (declare-symbol var))) |
---|
1661 | (emit 'getstatic |
---|
1662 | *this-class* |
---|
1663 | g |
---|
1664 | "Lorg/armedbear/lisp/Symbol;") |
---|
1665 | (emit 'swap) |
---|
1666 | (emit-invokestatic +lisp-class+ |
---|
1667 | "bindSpecialVariable" |
---|
1668 | "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" |
---|
1669 | -2))) |
---|
1670 | (t |
---|
1671 | (emit 'astore i) |
---|
1672 | (vector-push var *locals*) |
---|
1673 | (incf i)))))) |
---|
1674 | (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))) |
---|
1675 | |
---|
1676 | (defvar *tags* ()) |
---|
1677 | |
---|
1678 | (defstruct tag name label) |
---|
1679 | |
---|
1680 | (defun label-for-tag (name) |
---|
1681 | (let ((index (position name *tags* :from-end t :key #'tag-name))) |
---|
1682 | ;; (format t "find-tag index = ~S~%" index) |
---|
1683 | (when index |
---|
1684 | (tag-label (aref *tags* index))))) |
---|
1685 | |
---|
1686 | (defun compile-tagbody (form for-effect) |
---|
1687 | (let ((saved-fp (fill-pointer *tags*)) |
---|
1688 | (body (cdr form))) |
---|
1689 | ;; Scan for tags. |
---|
1690 | (dolist (f body) |
---|
1691 | (when (atom f) |
---|
1692 | (let ((name f) |
---|
1693 | (label (gensym))) |
---|
1694 | (vector-push (make-tag :name name :label label) *tags*)))) |
---|
1695 | (dolist (f body) |
---|
1696 | (cond ((atom f) |
---|
1697 | (let ((label (label-for-tag f))) |
---|
1698 | (unless label |
---|
1699 | (error "COMPILE-TAGBODY: tag not found: ~S" f)) |
---|
1700 | (emit 'label label))) |
---|
1701 | (t |
---|
1702 | (compile-form f t)))) |
---|
1703 | (setf (fill-pointer *tags*) saved-fp)) |
---|
1704 | ;; TAGBODY returns NIL. |
---|
1705 | (emit-push-nil) |
---|
1706 | (emit-store-value)) |
---|
1707 | |
---|
1708 | (defun compile-go (form for-effect) |
---|
1709 | (let* ((name (cadr form)) |
---|
1710 | (label (label-for-tag name))) |
---|
1711 | (unless label |
---|
1712 | (error "COMPILE-GO: tag not found: ~S" name)) |
---|
1713 | (emit 'goto label))) |
---|
1714 | |
---|
1715 | (defun compile-block (form for-effect) |
---|
1716 | (let* ((rest (cdr form)) |
---|
1717 | (block-label (car rest)) |
---|
1718 | (block-exit (gensym)) |
---|
1719 | (*blocks* (acons block-label block-exit *blocks*))) |
---|
1720 | (do ((forms (cdr rest) (cdr forms))) |
---|
1721 | ((null forms)) |
---|
1722 | (compile-form (car forms) (cdr forms))) |
---|
1723 | (emit 'label `,block-exit))) |
---|
1724 | |
---|
1725 | (defun compile-progn (form for-effect) |
---|
1726 | (do ((forms (cdr form) (cdr forms))) |
---|
1727 | ((null forms)) |
---|
1728 | (compile-form (car forms) (cdr forms)))) |
---|
1729 | |
---|
1730 | (defun compile-setq (form for-effect) |
---|
1731 | (unless (= (length form) 3) |
---|
1732 | (error "COMPILE-SETQ too many args for SETQ")) |
---|
1733 | (let* ((rest (cdr form)) |
---|
1734 | (sym (car rest)) |
---|
1735 | (index (position sym *locals* :from-end t))) |
---|
1736 | (when index |
---|
1737 | (compile-form (cadr rest)) |
---|
1738 | (unless (remove-store-value) |
---|
1739 | (emit-push-value)) |
---|
1740 | (cond (for-effect |
---|
1741 | (emit 'astore index)) |
---|
1742 | (t |
---|
1743 | (emit 'dup) |
---|
1744 | (emit 'astore index) |
---|
1745 | (emit-store-value))) |
---|
1746 | (return-from compile-setq)) |
---|
1747 | ;; index is NIL, look in *args* ... |
---|
1748 | (setq index (position sym *args*)) |
---|
1749 | (when index |
---|
1750 | (cond (*using-arg-array* |
---|
1751 | (emit 'aload 1) |
---|
1752 | (emit 'bipush index) |
---|
1753 | (compile-form (cadr rest)) |
---|
1754 | (emit-push-value) |
---|
1755 | (emit 'aastore)) |
---|
1756 | (t |
---|
1757 | (compile-form (cadr rest)) |
---|
1758 | (emit-push-value) |
---|
1759 | (emit 'astore (1+ index)))) |
---|
1760 | (return-from compile-setq)) |
---|
1761 | ;; still not found |
---|
1762 | ;; must be a global variable |
---|
1763 | (let ((g (declare-symbol sym))) |
---|
1764 | (emit 'getstatic |
---|
1765 | *this-class* |
---|
1766 | g |
---|
1767 | "Lorg/armedbear/lisp/Symbol;") |
---|
1768 | (compile-form (cadr rest)) |
---|
1769 | (unless (remove-store-value) |
---|
1770 | (emit-push-value)) |
---|
1771 | (emit-invokestatic +lisp-class+ |
---|
1772 | "setSpecialVariable" |
---|
1773 | "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" |
---|
1774 | -1) |
---|
1775 | (emit-store-value)))) |
---|
1776 | |
---|
1777 | (defun compile-quote (form for-effect) |
---|
1778 | (let ((obj (second form))) |
---|
1779 | (cond ((null obj) |
---|
1780 | (emit-push-nil) |
---|
1781 | (emit-store-value)) |
---|
1782 | ((symbolp obj) |
---|
1783 | (if (symbol-package obj) |
---|
1784 | (let ((g (declare-symbol obj))) |
---|
1785 | (emit 'getstatic |
---|
1786 | *this-class* |
---|
1787 | g |
---|
1788 | "Lorg/armedbear/lisp/Symbol;") |
---|
1789 | (emit-store-value)) |
---|
1790 | (compile-constant obj))) |
---|
1791 | ((listp obj) |
---|
1792 | (let ((g (declare-object-as-string obj))) |
---|
1793 | (emit 'getstatic |
---|
1794 | *this-class* |
---|
1795 | g |
---|
1796 | +lisp-object+) |
---|
1797 | (emit-store-value))) |
---|
1798 | ((constantp obj) |
---|
1799 | (compile-constant obj)) |
---|
1800 | (t |
---|
1801 | (error "COMPILE-QUOTE: unsupported case: ~S" form))))) |
---|
1802 | |
---|
1803 | (defun compile-declare (form for-effect) |
---|
1804 | ;; Nothing to do. |
---|
1805 | ) |
---|
1806 | |
---|
1807 | (defun compile-function (form for-effect) |
---|
1808 | (let ((obj (second form))) |
---|
1809 | (cond ((symbolp obj) |
---|
1810 | (let ((g (declare-symbol obj))) |
---|
1811 | (emit 'getstatic |
---|
1812 | *this-class* |
---|
1813 | g |
---|
1814 | "Lorg/armedbear/lisp/Symbol;") |
---|
1815 | (emit-invokevirtual +lisp-object-class+ |
---|
1816 | "getSymbolFunctionOrDie" |
---|
1817 | "()Lorg/armedbear/lisp/LispObject;" |
---|
1818 | 0) |
---|
1819 | (emit-store-value))) |
---|
1820 | #+nil |
---|
1821 | ((and (consp obj) (eq (car obj) 'LAMBDA)) |
---|
1822 | ;; FIXME We need to construct a proper lexical environment here |
---|
1823 | ;; and pass it to coerceToFunction(). |
---|
1824 | (let ((g (declare-object-as-string obj))) |
---|
1825 | (emit 'getstatic |
---|
1826 | *this-class* |
---|
1827 | g |
---|
1828 | +lisp-object+) |
---|
1829 | (emit-invokestatic +lisp-class+ |
---|
1830 | "coerceToFunction" |
---|
1831 | "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Function;" |
---|
1832 | 0) |
---|
1833 | (emit-store-value))) |
---|
1834 | (t |
---|
1835 | (error "COMPILE-FUNCTION: unsupported case: ~S" form))))) |
---|
1836 | |
---|
1837 | (defun compile-return-from (form for-effect) |
---|
1838 | (let* ((rest (cdr form)) |
---|
1839 | (block-label (car rest)) |
---|
1840 | (block-exit (cdr (assoc block-label *blocks*))) |
---|
1841 | (result-form (cadr rest))) |
---|
1842 | (unless block-exit |
---|
1843 | (error "no block named ~S is currently visible" block-label)) |
---|
1844 | (compile-form result-form) |
---|
1845 | (emit 'goto `,block-exit))) |
---|
1846 | |
---|
1847 | (defun compile-plus (form for-effect) |
---|
1848 | (let* ((args (cdr form)) |
---|
1849 | (len (length args))) |
---|
1850 | (case len |
---|
1851 | (2 |
---|
1852 | (let ((first (first args)) |
---|
1853 | (second (second args))) |
---|
1854 | (cond |
---|
1855 | ((eql first 1) |
---|
1856 | (compile-form second) |
---|
1857 | (emit-invoke-method "incr")) |
---|
1858 | ((eql second 1) |
---|
1859 | (compile-form first) |
---|
1860 | (emit-invoke-method "incr")) |
---|
1861 | (t |
---|
1862 | (compile-binary-operation "add" args))))) |
---|
1863 | (t |
---|
1864 | (compile-function-call '+ args))))) |
---|
1865 | |
---|
1866 | (defun compile-minus (form for-effect) |
---|
1867 | (let* ((args (cdr form)) |
---|
1868 | (len (length args))) |
---|
1869 | (case len |
---|
1870 | (2 |
---|
1871 | (let ((first (first args)) |
---|
1872 | (second (second args))) |
---|
1873 | (cond |
---|
1874 | ((eql second 1) |
---|
1875 | (compile-form first) |
---|
1876 | (emit-invoke-method "decr")) |
---|
1877 | (t |
---|
1878 | (compile-binary-operation "subtract" args))))) |
---|
1879 | (t |
---|
1880 | (compile-function-call '- args))))) |
---|
1881 | |
---|
1882 | (defun compile-variable-ref (form) |
---|
1883 | (let ((index (position form *locals* :from-end t))) |
---|
1884 | (when index |
---|
1885 | (emit 'aload index) |
---|
1886 | (emit-store-value) |
---|
1887 | (return-from compile-variable-ref))) |
---|
1888 | ;; Not found in locals; look in args. |
---|
1889 | (let ((index (position form *args*))) |
---|
1890 | (when index |
---|
1891 | (cond (*using-arg-array* |
---|
1892 | (emit 'aload 1) |
---|
1893 | (emit 'bipush index) |
---|
1894 | (emit 'aaload) |
---|
1895 | (emit-store-value) |
---|
1896 | (return-from compile-variable-ref)) |
---|
1897 | (t |
---|
1898 | (emit 'aload (1+ index)) |
---|
1899 | (emit-store-value) |
---|
1900 | (return-from compile-variable-ref))))) |
---|
1901 | |
---|
1902 | ;; Otherwise it must be a global variable. |
---|
1903 | (let ((g (declare-symbol form))) |
---|
1904 | (emit 'getstatic |
---|
1905 | *this-class* |
---|
1906 | g |
---|
1907 | "Lorg/armedbear/lisp/Symbol;") |
---|
1908 | (emit-invokevirtual +lisp-symbol-class+ |
---|
1909 | "symbolValue" |
---|
1910 | "()Lorg/armedbear/lisp/LispObject;" |
---|
1911 | 0) |
---|
1912 | (emit-store-value) |
---|
1913 | (return-from compile-variable-ref))) |
---|
1914 | |
---|
1915 | ;; If for-effect is true, no value needs to be left on the stack. |
---|
1916 | (defun compile-form (form &optional for-effect) |
---|
1917 | (cond |
---|
1918 | ((consp form) |
---|
1919 | (let ((op (car form)) |
---|
1920 | (args (cdr form))) |
---|
1921 | (when (macro-function op) |
---|
1922 | (compile-form (macroexpand form)) |
---|
1923 | (return-from compile-form)) |
---|
1924 | (when (symbolp op) |
---|
1925 | (let ((handler (get op 'jvm-compile-handler))) |
---|
1926 | (when handler |
---|
1927 | (funcall handler form for-effect) |
---|
1928 | (return-from compile-form)))) |
---|
1929 | (cond |
---|
1930 | ((special-operator-p op) |
---|
1931 | (error "COMPILE-FORM unhandled special operator ~S" op)) |
---|
1932 | (t ; Function call. |
---|
1933 | (compile-function-call op args for-effect))))) |
---|
1934 | ((eq form '()) |
---|
1935 | (unless for-effect |
---|
1936 | (emit-push-nil) |
---|
1937 | (emit-store-value))) |
---|
1938 | ((eq form t) |
---|
1939 | (unless for-effect |
---|
1940 | (emit-push-t) |
---|
1941 | (emit-store-value))) |
---|
1942 | ((symbolp form) |
---|
1943 | (when (keywordp form) |
---|
1944 | (let ((g (declare-keyword form))) |
---|
1945 | (emit 'getstatic |
---|
1946 | *this-class* |
---|
1947 | g |
---|
1948 | "Lorg/armedbear/lisp/Symbol;")) |
---|
1949 | (emit-store-value) |
---|
1950 | (return-from compile-form)) |
---|
1951 | |
---|
1952 | (compile-variable-ref form)) |
---|
1953 | ((constantp form) |
---|
1954 | (unless for-effect |
---|
1955 | (compile-constant form))) |
---|
1956 | (t |
---|
1957 | (error "COMPILE-FORM unhandled case ~S" form)))) |
---|
1958 | |
---|
1959 | ;; Returns descriptor. |
---|
1960 | (defun analyze-args (args) |
---|
1961 | (assert (not (memq '&AUX args))) |
---|
1962 | (when (or (memq '&KEY args) |
---|
1963 | (memq '&OPTIONAL args) |
---|
1964 | (memq '&REST args)) |
---|
1965 | (setq *using-arg-array* t) |
---|
1966 | (setq *hairy-arglist-p* t) |
---|
1967 | (return-from analyze-args #.(format nil "([~A)~A" +lisp-object+ +lisp-object+))) |
---|
1968 | (case (length args) |
---|
1969 | (0 #.(format nil "()~A" +lisp-object+)) |
---|
1970 | (1 #.(format nil "(~A)~A" +lisp-object+ +lisp-object+)) |
---|
1971 | (2 #.(format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+)) |
---|
1972 | (3 #.(format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+)) |
---|
1973 | (t (setq *using-arg-array* t) |
---|
1974 | #.(format nil "([~A)~A" +lisp-object+ +lisp-object+)))) |
---|
1975 | |
---|
1976 | (defun compile-defun (name form) |
---|
1977 | (unless (eq (car form) 'LAMBDA) |
---|
1978 | (return-from compile-defun nil)) |
---|
1979 | (setf form (precompile-form form t)) |
---|
1980 | (let* ((*defun-name* name) |
---|
1981 | (*declared-symbols* (make-hash-table)) |
---|
1982 | (*declared-functions* (make-hash-table)) |
---|
1983 | (*this-class* "org/armedbear/lisp/out") |
---|
1984 | (args (cadr form)) |
---|
1985 | (body (cddr form)) |
---|
1986 | (*using-arg-array* nil) |
---|
1987 | (*hairy-arglist-p* nil) |
---|
1988 | (descriptor (analyze-args args)) |
---|
1989 | (execute-method (make-method :name "execute" |
---|
1990 | :descriptor descriptor)) |
---|
1991 | (*code* ()) |
---|
1992 | (*static-code* ()) |
---|
1993 | (*fields* ()) |
---|
1994 | (*blocks* ()) |
---|
1995 | (*tags* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit! |
---|
1996 | (*args* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit! |
---|
1997 | (*locals* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit! |
---|
1998 | (*max-locals* 0) |
---|
1999 | (*pool* ()) |
---|
2000 | (*pool-count* 1) |
---|
2001 | (*val* nil) |
---|
2002 | (*thread* nil) |
---|
2003 | (*thread-var-initialized* nil)) |
---|
2004 | (setf (method-name-index execute-method) |
---|
2005 | (pool-name (method-name execute-method))) |
---|
2006 | (setf (method-descriptor-index execute-method) |
---|
2007 | (pool-name (method-descriptor execute-method))) |
---|
2008 | (if *hairy-arglist-p* |
---|
2009 | (let* ((fun (sys::make-compiled-function nil args body)) |
---|
2010 | (vars (sys::varlist fun))) |
---|
2011 | (dolist (var vars) |
---|
2012 | (vector-push var *args*))) |
---|
2013 | (dolist (arg args) |
---|
2014 | (vector-push arg *args*))) |
---|
2015 | (if *using-arg-array* |
---|
2016 | ;; Using arg array: slot 0 is "this" pointer, slot 1 is arg array, |
---|
2017 | ;; first available slot is 2. |
---|
2018 | (setf (fill-pointer *locals*) 2) |
---|
2019 | ;; Not using arg array: slot 0 is "this" pointer, next N slots are used |
---|
2020 | ;; for args. |
---|
2021 | (setf (fill-pointer *locals*) (1+ (length args)))) |
---|
2022 | ;; Reserve the next available slot for the value register. |
---|
2023 | (setq *val* (fill-pointer *locals*)) |
---|
2024 | (incf (fill-pointer *locals*)) |
---|
2025 | (setf *max-locals* (fill-pointer *locals*)) |
---|
2026 | ;; Reserve the next available slot for the thread register. |
---|
2027 | (setq *thread* (fill-pointer *locals*)) |
---|
2028 | (incf (fill-pointer *locals*)) |
---|
2029 | (setf *max-locals* (fill-pointer *locals*)) |
---|
2030 | (when *hairy-arglist-p* |
---|
2031 | (emit 'aload_0) |
---|
2032 | (emit 'aload_1) |
---|
2033 | (emit-invokevirtual *this-class* |
---|
2034 | "processArgs" |
---|
2035 | "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;" |
---|
2036 | -1) |
---|
2037 | (emit 'astore_1)) |
---|
2038 | (dolist (f body) |
---|
2039 | (compile-form f)) |
---|
2040 | (unless (remove-store-value) |
---|
2041 | (emit-push-value)) ; leave result on stack |
---|
2042 | (emit 'areturn) |
---|
2043 | (finalize-code) |
---|
2044 | (optimize-code) |
---|
2045 | (setf (method-max-stack execute-method) (analyze-stack)) |
---|
2046 | (setf (method-code execute-method) (code-bytes *code*)) |
---|
2047 | ;; (setf (method-max-stack execute-method) *max-stack*) |
---|
2048 | (setf (method-max-locals execute-method) *max-locals*) |
---|
2049 | |
---|
2050 | (let* ((super |
---|
2051 | (if *hairy-arglist-p* |
---|
2052 | "org.armedbear.lisp.CompiledFunction" |
---|
2053 | (case (length args) |
---|
2054 | (0 "org.armedbear.lisp.Primitive0") |
---|
2055 | (1 "org.armedbear.lisp.Primitive1") |
---|
2056 | (2 "org.armedbear.lisp.Primitive2") |
---|
2057 | (3 "org.armedbear.lisp.Primitive3") |
---|
2058 | (t "org.armedbear.lisp.Primitive")))) |
---|
2059 | (this-index (pool-class *this-class*)) |
---|
2060 | (super-index (pool-class super)) |
---|
2061 | (constructor (make-constructor super *defun-name* args body))) |
---|
2062 | (pool-name "Code") ; Must be in pool! |
---|
2063 | |
---|
2064 | ;; Write class file (out.class in current directory). |
---|
2065 | (with-open-file (*stream* "out.class" |
---|
2066 | :direction :output |
---|
2067 | :element-type 'unsigned-byte |
---|
2068 | :if-exists :supersede) |
---|
2069 | (write-u4 #xCAFEBABE) |
---|
2070 | (write-u2 3) |
---|
2071 | (write-u2 45) |
---|
2072 | (write-pool) |
---|
2073 | ;; access flags |
---|
2074 | (write-u2 #x21) |
---|
2075 | (write-u2 this-index) |
---|
2076 | (write-u2 super-index) |
---|
2077 | ;; interfaces count |
---|
2078 | (write-u2 0) |
---|
2079 | ;; fields count |
---|
2080 | (write-u2 (length *fields*)) |
---|
2081 | ;; fields |
---|
2082 | (dolist (field *fields*) |
---|
2083 | (write-field field)) |
---|
2084 | ;; methods count |
---|
2085 | (write-u2 2) |
---|
2086 | ;; methods |
---|
2087 | (write-method execute-method) |
---|
2088 | (write-method constructor) |
---|
2089 | ;; attributes count |
---|
2090 | (write-u2 0)))) |
---|
2091 | (sys::load-compiled-function "out.class")) |
---|
2092 | |
---|
2093 | (defun get-lambda-to-compile (definition-designator) |
---|
2094 | (if (and (consp definition-designator) |
---|
2095 | (eq (car definition-designator) 'LAMBDA)) |
---|
2096 | definition-designator |
---|
2097 | (multiple-value-bind (lambda-expression closure-p) |
---|
2098 | (function-lambda-expression definition-designator) |
---|
2099 | (when closure-p |
---|
2100 | (error "unable to compile function defined in non-null lexical environment")) |
---|
2101 | (unless lambda-expression |
---|
2102 | (error "can't find a definition")) |
---|
2103 | lambda-expression))) |
---|
2104 | |
---|
2105 | (defun load-verbose-prefix () |
---|
2106 | (with-output-to-string (s) |
---|
2107 | (princ #\; s) |
---|
2108 | (dotimes (i (1- sys::*load-depth*)) |
---|
2109 | (princ #\space s)))) |
---|
2110 | |
---|
2111 | (defun jvm-compile (name &optional definition) |
---|
2112 | (let ((prefix (load-verbose-prefix))) |
---|
2113 | (when name |
---|
2114 | (format t "~A Compiling ~S ...~%" prefix name) |
---|
2115 | (when (and (fboundp name) (typep (fdefinition name) 'generic-function)) |
---|
2116 | (format t "~A Unable to compile generic function ~S~%" prefix name) |
---|
2117 | (return-from jvm-compile (values name nil t))) |
---|
2118 | (unless (symbolp name) |
---|
2119 | (format t "~A Unable to compile ~S~%" prefix name) |
---|
2120 | (return-from jvm-compile (values name nil t)))) |
---|
2121 | (unless definition |
---|
2122 | (resolve name) |
---|
2123 | (setf definition (fdefinition name)) |
---|
2124 | (when (compiled-function-p definition) |
---|
2125 | (when name |
---|
2126 | (format t "~A Already compiled ~S~%" prefix name)) |
---|
2127 | (return-from jvm-compile (values name nil nil)))) |
---|
2128 | (handler-case |
---|
2129 | (let* ((*package* (if (and name (symbol-package name)) |
---|
2130 | (symbol-package name) |
---|
2131 | *package*)) |
---|
2132 | (expr (get-lambda-to-compile definition)) |
---|
2133 | (compiled-definition (compile-defun name expr))) |
---|
2134 | (when (and name (functionp compiled-definition)) |
---|
2135 | (sys::%set-lambda-name compiled-definition name) |
---|
2136 | (sys::%set-call-count compiled-definition (sys::%call-count definition)) |
---|
2137 | (sys::%set-arglist compiled-definition (sys::arglist definition)) |
---|
2138 | (if (macro-function name) |
---|
2139 | (setf (fdefinition name) (sys::make-macro compiled-definition)) |
---|
2140 | (setf (fdefinition name) compiled-definition))) |
---|
2141 | (when name |
---|
2142 | (format t "~A Compiled ~S~%" prefix name)) |
---|
2143 | (values (or name compiled-definition) nil nil)) |
---|
2144 | (error (c) |
---|
2145 | (format t "Error: ~S~%" c) |
---|
2146 | (when name (format t "~A Unable to compile ~S~%" prefix name)) |
---|
2147 | (values (or name (sys::coerce-to-function definition)) nil t))))) |
---|
2148 | |
---|
2149 | (defun jvm-compile-package (package-designator) |
---|
2150 | (let ((pkg (if (packagep package-designator) |
---|
2151 | package-designator |
---|
2152 | (find-package package-designator)))) |
---|
2153 | (dolist (sym (sys::package-symbols pkg)) |
---|
2154 | (when (fboundp sym) |
---|
2155 | (unless (or (special-operator-p sym) (macro-function sym)) |
---|
2156 | ;; Force autoload to be resolved. |
---|
2157 | (resolve sym) |
---|
2158 | (let ((f (fdefinition sym))) |
---|
2159 | (unless (compiled-function-p f) |
---|
2160 | (jvm-compile sym))))))) |
---|
2161 | t) |
---|
2162 | |
---|
2163 | (defun install-handler (fun &optional handler) |
---|
2164 | (let ((handler (or handler |
---|
2165 | (find-symbol (concatenate 'string "COMPILE-" (symbol-name fun)) 'jvm)))) |
---|
2166 | (unless (and handler (fboundp handler)) |
---|
2167 | (error "no handler for ~S" fun)) |
---|
2168 | (setf (get fun 'jvm-compile-handler) handler))) |
---|
2169 | |
---|
2170 | (mapc #'install-handler '(block |
---|
2171 | declare |
---|
2172 | function |
---|
2173 | go |
---|
2174 | if |
---|
2175 | multiple-value-list |
---|
2176 | progn |
---|
2177 | quote |
---|
2178 | return-from |
---|
2179 | setq |
---|
2180 | tagbody)) |
---|
2181 | |
---|
2182 | (install-handler 'let 'compile-let/let*) |
---|
2183 | (install-handler 'let* 'compile-let/let*) |
---|
2184 | (install-handler '+ 'compile-plus) |
---|
2185 | (install-handler '- 'compile-minus) |
---|
2186 | |
---|
2187 | (defun process-optimization-declarations (forms) |
---|
2188 | (let (alist ()) |
---|
2189 | (dolist (form forms) |
---|
2190 | (unless (and (consp form) (eq (car form) 'declare)) |
---|
2191 | (return)) |
---|
2192 | (let ((decl (cadr form))) |
---|
2193 | (when (eq (car decl) 'optimize) |
---|
2194 | (dolist (spec (cdr decl)) |
---|
2195 | (let ((val 3) |
---|
2196 | (quantity spec)) |
---|
2197 | (if (consp spec) |
---|
2198 | (setq quantity (car spec) val (cadr spec))) |
---|
2199 | (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed))) |
---|
2200 | (push (cons quantity val) alist))))))) |
---|
2201 | alist)) |
---|
2202 | |
---|
2203 | (defun compile (name &optional definition) |
---|
2204 | (if (consp name) |
---|
2205 | (return-from compile (values name nil nil))) |
---|
2206 | (if (and name (fboundp name) (typep (symbol-function name) 'generic-function)) |
---|
2207 | (return-from compile (values name nil nil))) |
---|
2208 | (unless definition |
---|
2209 | (setq definition (or (and (symbolp name) (macro-function name)) |
---|
2210 | (fdefinition name)))) |
---|
2211 | (let ((expr (get-lambda-to-compile definition)) |
---|
2212 | (speed nil)) |
---|
2213 | (when (eq (car expr) 'lambda) |
---|
2214 | (let ((decls (process-optimization-declarations (cddr expr)))) |
---|
2215 | (setf speed (cdr (assoc 'speed decls))))) |
---|
2216 | (if (eql speed 3) |
---|
2217 | (progn |
---|
2218 | (precompile name definition) |
---|
2219 | (jvm-compile name definition)) |
---|
2220 | (progn |
---|
2221 | (precompile name definition) |
---|
2222 | )))) |
---|
2223 | |
---|
2224 | (defmacro defun (name lambda-list &rest body) |
---|
2225 | `(progn |
---|
2226 | (sys::%defun ',name ',lambda-list ',body) |
---|
2227 | (compile ',name) |
---|
2228 | ',name)) |
---|
2229 | |
---|
2230 | (mapc #'jvm-compile '(pool-add |
---|
2231 | pool-find-entry |
---|
2232 | pool-name |
---|
2233 | pool-get |
---|
2234 | compile-form)) |
---|