source: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp @ 14858

Last change on this file since 14858 was 14858, checked in by Mark Evenson, 5 years ago

[PATCH 4/5] Runtime class improvements.
From faceaa2be78d92b6a6c43f5925fae926f9607bce Mon Sep 17 00:00:00 2001
Work in progress to get to a more functioning runtime class support.

  • Make static functions and :int parameters work.
  • Fix return conversion for null.
  • Ensure that the same classloader is used.

Because otherwise the name of the superclass couldn't be found as it's
not cached anywhere.

It would probably make sense to make the normal classloader a caching
one, so that custom classes can be found by other parts of the (Java)
system?

---

src/org/armedbear/lisp/LispObject.java | 3 +
src/org/armedbear/lisp/Nil.java | 15 +++
src/org/armedbear/lisp/jvm-instructions.lisp | 27 ++++++
src/org/armedbear/lisp/runtime-class.lisp | 139 +++++++++++++++++++--------
test/lisp/abcl/runtime-class.lisp | 101 +++++++++----------
5 files changed, 186 insertions(+), 99 deletions(-)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 39.1 KB
Line 
1;;; jvm-instructions.lisp
2;;;
3;;; Copyright (C) 2003-2006 Peter Graves
4;;; Copyright (C) 2010 Erik Huelsmann
5;;; $Id: jvm-instructions.lisp 14858 2016-09-04 07:01:04Z mevenson $
6;;;
7;;; This program is free software; you can redistribute it and/or
8;;; modify it under the terms of the GNU General Public License
9;;; as published by the Free Software Foundation; either version 2
10;;; of the License, or (at your option) any later version.
11;;;
12;;; This program is distributed in the hope that it will be useful,
13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with this program; if not, write to the Free Software
19;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20;;;
21;;; As a special exception, the copyright holders of this library give you
22;;; permission to link this library with independent modules to produce an
23;;; executable, regardless of the license terms of these independent
24;;; modules, and to copy and distribute the resulting executable under
25;;; terms of your choice, provided that you also meet, for each linked
26;;; independent module, the terms and conditions of the license of that
27;;; module.  An independent module is a module which is not derived from
28;;; or based on this library.  If you modify this library, you may extend
29;;; this exception to your version of the library, but you are not
30;;; obligated to do so.  If you do not wish to do so, delete this
31;;; exception statement from your version.
32
33(in-package #:jvm)
34
35(require "COMPILER-ERROR")
36
37
38(declaim (inline u2 s1 s2))
39
40(defknown u2 (fixnum) cons)
41(defun u2 (n)
42  (declare (optimize speed))
43  (declare (type (unsigned-byte 16) n))
44  (when (not (<= 0 n 65535))
45    (error "u2 argument ~A out of 65k range." n))
46  (list (logand (ash n -8) #xff)
47        (logand n #xff)))
48
49(defknown s1 (fixnum) fixnum)
50(defun s1 (n)
51  (declare (optimize speed))
52  (declare (type (signed-byte 8) n))
53  (when (not (<= -128 n 127))
54    (error "s1 argument ~A out of 8-bit signed range." n))
55  (if (< n 0)
56      (1+ (logxor (- n) #xFF))
57      n))
58
59
60(defknown s2 (fixnum) cons)
61(defun s2 (n)
62  (declare (optimize speed))
63  (declare (type (signed-byte 16) n))
64  (when (not (<= -32768 n 32767))
65    (error "s2 argument ~A out of 16-bit signed range." n))
66  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
67          n)))
68
69;;    OPCODES
70
71(defconst *opcode-table* (make-array 256))
72
73(defconst *opcodes* (make-hash-table :test 'equalp))
74
75;; instruction arguments are encoded as part of the instruction,
76;; we're not talking stack values here.
77
78;; b = signed byte (8-bit)
79;; B = unsigned byte (8-bit)
80;; w = signed word (16-bit)
81;; W = unsigned word (16-bit)
82;; i = signed int (32-bit)
83;; I = unsigend int (32-bit)
84
85;; o = signed offset (relative code pointer) (16-bit)
86;; p = pool index (unsigned 8-bit)
87;; P = pool index (unsigned 16-bit)
88;; l = local variable (8-bit)
89;; L = local variable (16-bit)
90
91;; z = zero padding (1 to 3 bytes) to guarantee 4-byte alignment
92;;      of the following arguments
93;; q = lookupswitch variable length instruction arguments
94;; Q = tableswitch variable length instruction arguments
95
96;; t = 8-bit java builtin type designator (in {4,5,6,7,8,9,10,11})
97
98
99(defstruct jvm-opcode name number size stack-effect register-used
100           (args-spec ""))
101
102(defun %define-opcode (name number size stack-effect register
103                       &optional args-spec)
104  (declare (type fixnum number size))
105  (let* ((name (string name))
106         (opcode (make-jvm-opcode :name name
107                                  :number number
108                                  :size size
109                                  :stack-effect stack-effect
110                                  :register-used register
111                                  :args-spec args-spec)))
112     (setf (svref *opcode-table* number) opcode)
113     (setf (gethash name *opcodes*) opcode)
114     (setf (gethash number *opcodes*) opcode)))
115
116(defmacro define-opcode (name number size stack-effect register
117                         &optional args-spec)
118  `(%define-opcode ',name ,number ,size ,stack-effect ,register
119                   ,@(when args-spec
120                           (list args-spec))))
121
122;; name number size stack-effect register-used
123(define-opcode nop 0 1 0 nil)
124(define-opcode aconst_null 1 1 1 nil)
125(define-opcode iconst_m1 2 1 1 nil)
126(define-opcode iconst_0 3 1 1 nil)
127(define-opcode iconst_1 4 1 1 nil)
128(define-opcode iconst_2 5 1 1 nil)
129(define-opcode iconst_3 6 1 1 nil)
130(define-opcode iconst_4 7 1 1 nil)
131(define-opcode iconst_5 8 1 1 nil)
132(define-opcode lconst_0 9 1 2 nil)
133(define-opcode lconst_1 10 1 2 nil)
134(define-opcode fconst_0 11 1 1 nil)
135(define-opcode fconst_1 12 1 1 nil)
136(define-opcode fconst_2 13 1 1 nil)
137(define-opcode dconst_0 14 1 2 nil)
138(define-opcode dconst_1 15 1 2 nil)
139(define-opcode bipush 16 2 1 nil)
140(define-opcode sipush 17 3 1 nil)
141(define-opcode ldc 18 2 1 nil "p")
142(define-opcode ldc_w 19 3 1 nil "P")
143(define-opcode ldc2_w 20 3 2 nil "P")
144(define-opcode iload 21 2 1 t)
145(define-opcode lload 22 2 2 t)
146(define-opcode fload 23 2 nil t)
147(define-opcode dload 24 2 nil t)
148(define-opcode aload 25 2 1 t)
149(define-opcode iload_0 26 1 1 0)
150(define-opcode iload_1 27 1 1 1)
151(define-opcode iload_2 28 1 1 2)
152(define-opcode iload_3 29 1 1 3)
153(define-opcode lload_0 30 1 2 0)
154(define-opcode lload_1 31 1 2 1)
155(define-opcode lload_2 32 1 2 2)
156(define-opcode lload_3 33 1 2 3)
157(define-opcode fload_0 34 1 nil 0)
158(define-opcode fload_1 35 1 nil 1)
159(define-opcode fload_2 36 1 nil 2)
160(define-opcode fload_3 37 1 nil 3)
161(define-opcode dload_0 38 1 nil 0)
162(define-opcode dload_1 39 1 nil 1)
163(define-opcode dload_2 40 1 nil 2)
164(define-opcode dload_3 41 1 nil 3)
165(define-opcode aload_0 42 1 1 0)
166(define-opcode aload_1 43 1 1 1)
167(define-opcode aload_2 44 1 1 2)
168(define-opcode aload_3 45 1 1 3)
169(define-opcode iaload 46 1 -1 nil)
170(define-opcode laload 47 1 0 nil)
171(define-opcode faload 48 1 -1 nil)
172(define-opcode daload 49 1 0 nil)
173(define-opcode aaload 50 1 -1 nil)
174(define-opcode baload 51 1 nil nil)
175(define-opcode caload 52 1 nil nil)
176(define-opcode saload 53 1 nil nil)
177(define-opcode istore 54 2 -1 t)
178(define-opcode lstore 55 2 -2 t)
179(define-opcode fstore 56 2 nil t)
180(define-opcode dstore 57 2 nil t)
181(define-opcode astore 58 2 -1 t)
182(define-opcode istore_0 59 1 -1 0)
183(define-opcode istore_1 60 1 -1 1)
184(define-opcode istore_2 61 1 -1 2)
185(define-opcode istore_3 62 1 -1 3)
186(define-opcode lstore_0 63 1 -2 0)
187(define-opcode lstore_1 64 1 -2 1)
188(define-opcode lstore_2 65 1 -2 2)
189(define-opcode lstore_3 66 1 -2 3)
190(define-opcode fstore_0 67 1 nil 0)
191(define-opcode fstore_1 68 1 nil 1)
192(define-opcode fstore_2 69 1 nil 2)
193(define-opcode fstore_3 70 1 nil 3)
194(define-opcode dstore_0 71 1 nil 0)
195(define-opcode dstore_1 72 1 nil 1)
196(define-opcode dstore_2 73 1 nil 2)
197(define-opcode dstore_3 74 1 nil 3)
198(define-opcode astore_0 75 1 -1 0)
199(define-opcode astore_1 76 1 -1 1)
200(define-opcode astore_2 77 1 -1 2)
201(define-opcode astore_3 78 1 -1 3)
202(define-opcode iastore 79 1 -3 nil)
203(define-opcode lastore 80 1 -4 nil)
204(define-opcode fastore 81 1 -3 nil)
205(define-opcode dastore 82 1 -4 nil)
206(define-opcode aastore 83 1 -3 nil)
207(define-opcode bastore 84 1 nil nil)
208(define-opcode castore 85 1 nil nil)
209(define-opcode sastore 86 1 nil nil)
210(define-opcode pop 87 1 -1 nil)
211(define-opcode pop2 88 1 -2 nil)
212(define-opcode dup 89 1 1 nil)
213(define-opcode dup_x1 90 1 1 nil)
214(define-opcode dup_x2 91 1 1 nil)
215(define-opcode dup2 92 1 2 nil)
216(define-opcode dup2_x1 93 1 2 nil)
217(define-opcode dup2_x2 94 1 2 nil)
218(define-opcode swap 95 1 0 nil)
219(define-opcode iadd 96 1 -1 nil)
220(define-opcode ladd 97 1 -2 nil)
221(define-opcode fadd 98 1 -1 nil)
222(define-opcode dadd 99 1 -2 nil)
223(define-opcode isub 100 1 -1 nil)
224(define-opcode lsub 101 1 -2 nil)
225(define-opcode fsub 102 1 -1 nil)
226(define-opcode dsub 103 1 -2 nil)
227(define-opcode imul 104 1 -1 nil)
228(define-opcode lmul 105 1 -2 nil)
229(define-opcode fmul 106 1 -1 nil)
230(define-opcode dmul 107 1 -2 nil)
231(define-opcode idiv 108 1 nil nil)
232(define-opcode ldiv 109 1 nil nil)
233(define-opcode fdiv 110 1 nil nil)
234(define-opcode ddiv 111 1 nil nil)
235(define-opcode irem 112 1 nil nil)
236(define-opcode lrem 113 1 nil nil)
237(define-opcode frem 114 1 nil nil)
238(define-opcode drem 115 1 nil nil)
239(define-opcode ineg 116 1 0 nil)
240(define-opcode lneg 117 1 0 nil)
241(define-opcode fneg 118 1 0 nil)
242(define-opcode dneg 119 1 0 nil)
243(define-opcode ishl 120 1 -1 nil)
244(define-opcode lshl 121 1 -1 nil)
245(define-opcode ishr 122 1 -1 nil)
246(define-opcode lshr 123 1 -1 nil)
247(define-opcode iushr 124 1 nil nil)
248(define-opcode lushr 125 1 nil nil)
249(define-opcode iand 126 1 -1 nil)
250(define-opcode land 127 1 -2 nil)
251(define-opcode ior 128 1 -1 nil)
252(define-opcode lor 129 1 -2 nil)
253(define-opcode ixor 130 1 -1 nil)
254(define-opcode lxor 131 1 -2 nil)
255(define-opcode iinc 132 3 0 t)
256(define-opcode i2l 133 1 1 nil)
257(define-opcode i2f 134 1 0 nil)
258(define-opcode i2d 135 1 1 nil)
259(define-opcode l2i 136 1 -1 nil)
260(define-opcode l2f 137 1 -1 nil)
261(define-opcode l2d 138 1 0 nil)
262(define-opcode f2i 139 1 nil nil)
263(define-opcode f2l 140 1 nil nil)
264(define-opcode f2d 141 1 1 nil)
265(define-opcode d2i 142 1 nil nil)
266(define-opcode d2l 143 1 nil nil)
267(define-opcode d2f 144 1 -1 nil)
268(define-opcode i2b 145 1 nil nil)
269(define-opcode i2c 146 1 nil nil)
270(define-opcode i2s 147 1 nil nil)
271(define-opcode lcmp 148 1 -3 nil)
272(define-opcode fcmpl 149 1 -1 nil)
273(define-opcode fcmpg 150 1 -1 nil)
274(define-opcode dcmpl 151 1 -3 nil)
275(define-opcode dcmpg 152 1 -3 nil)
276(define-opcode ifeq 153 3 -1 nil)
277(define-opcode ifne 154 3 -1 nil)
278(define-opcode iflt 155 3 -1 nil)
279(define-opcode ifge 156 3 -1 nil)
280(define-opcode ifgt 157 3 -1 nil)
281(define-opcode ifle 158 3 -1 nil)
282(define-opcode if_icmpeq 159 3 -2 nil)
283(define-opcode if_icmpne 160 3 -2 nil)
284(define-opcode if_icmplt 161 3 -2 nil)
285(define-opcode if_icmpge 162 3 -2 nil)
286(define-opcode if_icmpgt 163 3 -2 nil)
287(define-opcode if_icmple 164 3 -2 nil)
288(define-opcode if_acmpeq 165 3 -2 nil)
289(define-opcode if_acmpne 166 3 -2 nil)
290(define-opcode goto 167 3 0 nil)
291;;(define-opcode jsr 168 3 1) Don't use these 2 opcodes: deprecated
292;;(define-opcode ret 169 2 0) their use results in JVM verifier errors
293(define-opcode tableswitch 170 0 nil nil)
294(define-opcode lookupswitch 171 0 nil nil)
295(define-opcode ireturn 172 1 nil nil)
296(define-opcode lreturn 173 1 nil nil)
297(define-opcode freturn 174 1 nil nil)
298(define-opcode dreturn 175 1 nil nil)
299(define-opcode ireturn 172 1 -1 nil)
300(define-opcode areturn 176 1 -1 nil)
301(define-opcode return 177 1 0 nil)
302(define-opcode getstatic 178 3 1 nil "P")
303(define-opcode putstatic 179 3 -1 nil "P")
304(define-opcode getfield 180 3 0 nil "P")
305(define-opcode putfield 181 3 -2 nil "P")
306(define-opcode invokevirtual 182 3 nil nil "P")
307(define-opcode invokespecial 183 3 nil nil "P")
308(define-opcode invokestatic 184 3 nil nil "P")
309(define-opcode invokeinterface 185 5 nil nil "P")
310(define-opcode unused 186 0 nil nil)
311(define-opcode new 187 3 1 nil "P")
312(define-opcode newarray 188 2 nil nil)
313(define-opcode anewarray 189 3 0 nil)
314(define-opcode arraylength 190 1 0 nil)
315(define-opcode athrow 191 1 0 nil)
316(define-opcode checkcast 192 3 0 nil "P")
317(define-opcode instanceof 193 3 0 nil "P")
318(define-opcode monitorenter 194 1 -1 nil)
319(define-opcode monitorexit 195 1 -1 nil)
320(define-opcode wide 196 0 nil nil)
321(define-opcode multianewarray 197 4 nil nil)
322(define-opcode ifnull 198 3 -1 nil)
323(define-opcode ifnonnull 199 3 nil nil)
324(define-opcode goto_w 200 5 nil nil)
325;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
326(define-opcode label 202 0 0 nil)  ;; virtual: does not exist in the JVM
327;; (define-opcode push-value 203 nil 1)
328;; (define-opcode store-value 204 nil -1)
329(define-opcode clear-values 205 0 0 t)  ;; virtual: does not exist in the JVM
330;;(define-opcode var-ref 206 0 0)
331
332(defparameter *last-opcode* 206)
333
334(declaim (ftype (function (t) t) opcode-name))
335(defun opcode-name (opcode-number)
336  (let ((opcode (gethash opcode-number *opcodes*)))
337    (and opcode (jvm-opcode-name opcode))))
338
339(declaim (ftype (function (t) (integer 0 255)) opcode-number))
340(defun opcode-number (opcode-name)
341  (declare (optimize speed))
342  (let ((opcode (gethash (string opcode-name) *opcodes*)))
343    (if opcode
344        (jvm-opcode-number opcode)
345        (error "Unknown opcode ~S." opcode-name))))
346
347(declaim (ftype (function (t) fixnum) opcode-size))
348(defun opcode-size (opcode-number)
349  (declare (optimize speed (safety 0)))
350  (declare (type (integer 0 255) opcode-number))
351  (jvm-opcode-size (svref *opcode-table* opcode-number)))
352
353(declaim (ftype (function (t) t) opcode-stack-effect))
354(defun opcode-stack-effect (opcode-number)
355  (declare (optimize speed))
356  (jvm-opcode-stack-effect (svref *opcode-table* opcode-number)))
357
358(defun opcode-args-spec (opcode-number)
359  (let ((opcode (gethash opcode-number *opcodes*)))
360    (and opcode (jvm-opcode-args-spec))))
361
362
363
364;;   INSTRUCTION
365
366(defstruct (instruction (:constructor %make-instruction (opcode args)))
367  (opcode 0 :type (integer 0 255))
368  args
369  stack
370  depth
371  wide)
372
373(defun make-instruction (opcode args)
374  (let ((inst (apply #'%make-instruction
375                     (list opcode
376                           (remove :wide-prefix args)))))
377    (when (memq :wide-prefix args)
378      (setf (inst-wide inst) t))
379    inst))
380
381(defun print-instruction (instruction)
382  (sys::%format nil "~A ~A stack = ~S depth = ~S"
383          (opcode-name (instruction-opcode instruction))
384          (instruction-args instruction)
385          (instruction-stack instruction)
386          (instruction-depth instruction)))
387
388(declaim (ftype (function (t) t) instruction-label))
389(defun instruction-label (instruction)
390  (and instruction
391       (= (instruction-opcode (the instruction instruction)) 202)
392       (car (instruction-args instruction))))
393
394
395
396(defknown inst * t)
397(defun inst (instr &optional args)
398  (declare (optimize speed))
399  (let ((opcode (if (fixnump instr)
400                    instr
401                    (opcode-number instr))))
402    (unless (listp args)
403      (setf args (list args)))
404    (make-instruction opcode args)))
405
406
407;; Having %emit and %%emit output their code to *code*
408;; is currently an implementation detail exposed to all users.
409;; We need to have APIs to address this, but for now pass2 is
410;; our only user and we'll hard-code the use of *code*.
411(defvar *code* nil)
412
413(defknown %%emit * t)
414(defun %%emit (instr &rest args)
415  (declare (optimize speed))
416  (let ((instruction (make-instruction instr args)))
417    (push instruction *code*)
418    instruction))
419
420(defknown %emit * t)
421(defun %emit (instr &rest args)
422  (declare (optimize speed))
423  (let ((instruction (inst instr args)))
424    (push instruction *code*)
425    instruction))
426
427(defmacro emit (instr &rest args)
428  (when (and (consp instr)
429             (eq (car instr) 'QUOTE)
430             (symbolp (cadr instr)))
431    (setf instr (opcode-number (cadr instr))))
432  (if (fixnump instr)
433      `(%%emit ,instr ,@args)
434      `(%emit ,instr ,@args)))
435
436
437;;  Helper routines
438
439(defknown label (symbol) t)
440(defun label (symbol)
441  (declare (type symbol symbol))
442  (declare (optimize speed))
443  (emit 'label symbol)
444  (setf (symbol-value symbol) nil))
445
446(defknown aload (fixnum) t)
447(defun aload (index)
448  (case index
449    (0 (emit 'aload_0))
450    (1 (emit 'aload_1))
451    (2 (emit 'aload_2))
452    (3 (emit 'aload_3))
453    (t (emit 'aload index))))
454
455(defknown astore (fixnum) t)
456(defun astore (index)
457  (case index
458    (0 (emit 'astore_0))
459    (1 (emit 'astore_1))
460    (2 (emit 'astore_2))
461    (3 (emit 'astore_3))
462    (t (emit 'astore index))))
463
464(defknown iload (fixnum) t)
465(defun iload (index)
466  (case index
467    (0 (emit 'iload_0))
468    (1 (emit 'iload_1))
469    (2 (emit 'iload_2))
470    (3 (emit 'iload_3))
471    (t (emit 'iload index))))
472
473(defknown istore (fixnum) t)
474(defun istore (index)
475  (case index
476    (0 (emit 'istore_0))
477    (1 (emit 'istore_1))
478    (2 (emit 'istore_2))
479    (3 (emit 'istore_3))
480    (t (emit 'istore index))))
481
482(declaim (ftype (function (t) t) branch-p)
483         (inline branch-p))
484(defun branch-p (opcode)
485;;  (declare (optimize speed))
486;;  (declare (type '(integer 0 255) opcode))
487  (or (<= 153 opcode 167)
488      (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w
489
490(declaim (ftype (function (t) t) unconditional-control-transfer-p)
491         (inline unconditional-control-transfer-p))
492(defun unconditional-control-transfer-p (opcode)
493  (or (= 167 opcode) ;; goto
494      (= 200 opcode) ;; goto_w
495      (<= 172 opcode 177) ;; ?return
496      (= 191 opcode) ;; athrow
497      ))
498
499(declaim (ftype (function (t) boolean) label-p)
500         (inline label-p))
501(defun label-p (instruction)
502  (and instruction
503       (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
504
505(defun format-instruction-args (instruction pool)
506  (if (memql (instruction-opcode instruction) '(18 19 20
507                                                178 179 180 181 182 183 184 185
508                                                187
509                                                192 193))
510      (let ((*print-readably* nil)
511            (*print-escape* nil))
512        (with-output-to-string (s)
513          (print-pool-constant pool
514                               (find-pool-entry pool
515                                                (car (instruction-args instruction))) s
516                               :package "org/armedbear/lisp")))
517      (when (instruction-args instruction)
518        (format nil "~S" (instruction-args instruction)))))
519
520(defun print-code (code pool)
521  (declare (ignorable pool))
522  (dotimes (i (length code))
523    (let ((instruction (elt code i)))
524      (format t "~3D ~A ~19T~A ~A ~A~%"
525                    i
526                    (opcode-name (instruction-opcode instruction))
527                    (or (format-instruction-args instruction pool) "")
528                    (or (instruction-stack instruction) "")
529                    (or (instruction-depth instruction) "")))))
530
531(defun print-code2 (code pool)
532  (declare (ignorable pool))
533  (dotimes (i (length code))
534    (let ((instruction (elt code i)))
535      (case (instruction-opcode instruction)
536        (202 ; LABEL
537         (format t "~A:~%" (car (instruction-args instruction))))
538        (t
539         (format t "~8D:   ~A ~S~%"
540                 i
541                 (opcode-name (instruction-opcode instruction))
542                 (instruction-args instruction)))))))
543
544(defun expand-virtual-instructions (code)
545  (let* ((len (length code))
546         (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t)))
547    (dotimes (index len vector)
548      (declare (type (unsigned-byte 16) index))
549      (let ((instruction (svref code index)))
550        (case (instruction-opcode instruction)
551          (205 ; CLEAR-VALUES
552           (dolist (instruction
553                     (list
554                      (inst 'aload (car (instruction-args instruction)))
555                      (inst 'aconst_null)
556                      (inst 'putfield (list (pool-field +lisp-thread+ "_values"
557                                                        +lisp-object-array+)))))
558             (vector-push-extend instruction vector)))
559          (t
560           (vector-push-extend instruction vector)))))))
561
562
563;;   RESOLVERS
564
565(defun unsupported-opcode (instruction)
566  (error "Unsupported opcode ~D." (instruction-opcode instruction)))
567
568(declaim (type hash-table +resolvers+))
569(defconst +resolvers+ (make-hash-table))
570
571(defun initialize-resolvers ()
572  (let ((ht +resolvers+))
573    (dotimes (n (1+ *last-opcode*))
574      (setf (gethash n ht) #'unsupported-opcode))
575    ;; The following opcodes resolve to themselves.
576    (dolist (n '(0 ; nop
577                 1 ; aconst_null
578                 2 ; iconst_m1
579                 3 ; iconst_0
580                 4 ; iconst_1
581                 5 ; iconst_2
582                 6 ; iconst_3
583                 7 ; iconst_4
584                 8 ; iconst_5
585                 9 ; lconst_0
586                 10 ; lconst_1
587                 11 ; fconst_0
588                 12 ; fconst_1
589                 13 ; fconst_2
590                 14 ; dconst_0
591                 15 ; dconst_1
592                 26 ; iload_0
593                 27 ; iload_1
594                 28 ; iload_2
595                 29 ; iload_3
596                 42 ; aload_0
597                 43 ; aload_1
598                 44 ; aload_2
599                 45 ; aload_3
600                 46 ; iaload
601                 47 ; laload
602                 48 ; faload
603                 49 ; daload
604                 50 ; aaload
605                 54 ; istore
606                 59 ; istore_0
607                 60 ; istore_1
608                 61 ; istore_2
609                 62 ; istore_3
610                 75 ; astore_0
611                 76 ; astore_1
612                 77 ; astore_2
613                 78 ; astore_3
614                 79 ; iastore
615                 80 ; lastore
616                 81 ; fastore
617                 82 ; dastore
618                 83 ; aastore
619                 87 ; pop
620                 88 ; pop2
621                 89 ; dup
622                 90 ; dup_x1
623                 91 ; dup_x2
624                 92 ; dup2
625                 93 ; dup2_x1
626                 94 ; dup2_x2
627                 95 ; swap
628                 96 ; iadd
629                 97 ; ladd
630                 98 ; fadd
631                 99 ; dadd
632                 100 ; isub
633                 101 ; lsub
634                 102 ; fsub
635                 103 ; dsub
636                 104 ; imul
637                 105 ; lmul
638                 106 ; fmul
639                 107 ; dmul
640                 116 ; ineg
641                 117 ; lneg
642                 118 ; fneg
643                 119 ; dneg
644                 120 ; ishl
645                 121 ; lshl
646                 122 ; ishr
647                 123 ; lshr
648                 126 ; iand
649                 127 ; land
650                 128 ; ior
651                 129 ; lor
652                 130 ; ixor
653                 131 ; lxor
654                 133 ; i2l
655                 134 ; i2f
656                 135 ; i2d
657                 136 ; l2i
658                 137 ; l2f
659                 138 ; l2d
660                 141 ; f2d
661                 144 ; d2f
662                 148 ; lcmp
663                 149 ; fcmpd
664                 150 ; fcmpg
665                 151 ; dcmpd
666                 152 ; dcmpg
667                 153 ; ifeq
668                 154 ; ifne
669                 155 ; ifge
670                 156 ; ifgt
671                 157 ; ifgt
672                 158 ; ifle
673                 159 ; if_icmpeq
674                 160 ; if_icmpne
675                 161 ; if_icmplt
676                 162 ; if_icmpge
677                 163 ; if_icmpgt
678                 164 ; if_icmple
679                 165 ; if_acmpeq
680                 166 ; if_acmpne
681                 167 ; goto
682                 172 ; ireturn
683                 176 ; areturn
684                 177 ; return
685                 189 ; anewarray
686                 190 ; arraylength
687                 191 ; athrow
688                 194 ; monitorenter
689                 195 ; monitorexit
690                 198 ; ifnull
691                 202 ; label
692                 ))
693      (setf (gethash n ht) nil))))
694
695(initialize-resolvers)
696
697(defmacro define-resolver (opcodes args &body body)
698  (let ((name (gensym)))
699    `(progn
700       (defun ,name ,args ,@body)
701       (eval-when (:load-toplevel :execute)
702         ,(if (listp opcodes)
703              `(dolist (op ',opcodes)
704                 (setf (gethash op +resolvers+)
705                       (symbol-function ',name)))
706              `(setf (gethash ,opcodes +resolvers+)
707                     (symbol-function ',name)))))))
708
709(defun load/store-resolver (instruction inst-index inst-index2 error-text)
710 (let* ((args (instruction-args instruction))
711        (index (car args)))
712   (declare (type (unsigned-byte 16) index))
713   (cond ((<= 0 index 3)
714          (inst (+ index inst-index)))
715         ((<= 0 index 255)
716          (inst inst-index2 index))
717         (t
718          (error error-text)))))
719
720;; aload
721(define-resolver 25 (instruction)
722  (load/store-resolver instruction 42 25 "ALOAD unsupported case"))
723
724;; astore
725(define-resolver 58 (instruction)
726  (load/store-resolver instruction 75 58 "ASTORE unsupported case"))
727
728;; iload
729(define-resolver 21 (instruction)
730  (load/store-resolver instruction 26 21 "ILOAD unsupported case"))
731
732;; istore
733(define-resolver 54 (instruction)
734  (load/store-resolver instruction 59 54 "ISTORE unsupported case"))
735
736;; lload
737(define-resolver 22 (instruction)
738  (load/store-resolver instruction 30 22 "LLOAD unsupported case"))
739
740;; lstore
741(define-resolver 55 (instruction)
742  (load/store-resolver instruction 63 55 "LSTORE unsupported case"))
743
744;; bipush, sipush
745(define-resolver (16 17) (instruction)
746  (let* ((args (instruction-args instruction))
747         (n (first args)))
748    (declare (type fixnum n))
749    (cond ((<= 0 n 5)
750           (inst (+ n 3)))
751          ((<= -128 n 127)
752           (inst 16 (logand n #xff))) ; BIPUSH
753          (t ; SIPUSH
754           (inst 17 (s2 n))))))
755
756;; ldc
757(define-resolver 18 (instruction)
758  (let* ((args (instruction-args instruction)))
759    (unless (= (length args) 1)
760      (error "Wrong number of args for LDC."))
761    (if (> (car args) 255)
762        (inst 19 (u2 (car args))) ; LDC_W
763        (inst 18 args))))
764
765;; ldc_w
766(define-resolver 19 (instruction)
767  (let* ((args (instruction-args instruction)))
768    (unless (= (length args) 1)
769      (error "Wrong number of args for LDC_W."))
770    (inst 19 (u2 (car args)))))
771
772;; ldc2_w
773(define-resolver 20 (instruction)
774  (let* ((args (instruction-args instruction)))
775    (unless (= (length args) 1)
776      (error "Wrong number of args for LDC2_W."))
777    (inst 20 (u2 (car args)))))
778
779;; iinc
780(define-resolver 132 (instruction)
781  (let* ((args (instruction-args instruction))
782         (register (first args))
783         (n (second args)))
784    (when (not (<= -128 n 127))
785      (error "IINC argument ~A out of bounds." n))
786    (inst 132 (list register (s1 n)))))
787
788(define-resolver (178 179 180 181 182 183 184 185 192 193 187)
789    (instruction)
790  (let* ((arg (car (instruction-args instruction))))
791    (setf (instruction-args instruction)
792          (u2 arg))
793    instruction))
794
795(defknown resolve-instruction (t) t)
796(defun resolve-instruction (instruction)
797  (declare (optimize speed))
798  (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+)))
799    (if resolver
800        (funcall resolver instruction)
801        instruction)))
802
803(defun resolve-instructions (code)
804  (let* ((len (length code))
805         (vector (make-array len :fill-pointer 0 :adjustable t)))
806    (dotimes (index len vector)
807      (declare (type (unsigned-byte 16) index))
808      (let ((instruction (aref code index)))
809        (vector-push-extend (resolve-instruction instruction) vector)))))
810
811
812
813;; BYTE CODE ANALYSIS AND OPTIMIZATION
814
815(declaim (ftype (function (t t t) t) analyze-stack-path))
816(defun analyze-stack-path (code start-index depth)
817  (declare (optimize speed))
818  (declare (type fixnum start-index depth))
819  (do* ((i start-index (1+ i))
820        (limit (length code)))
821       ((>= i limit))
822    (declare (type fixnum i limit))
823    (let* ((instruction (aref code i))
824           (instruction-depth (instruction-depth instruction))
825           (instruction-stack (instruction-stack instruction)))
826      (declare (type fixnum instruction-stack))
827      (when instruction-depth
828        (unless (= (the fixnum instruction-depth)
829                   (the fixnum (+ depth instruction-stack)))
830          (internal-compiler-error "Stack inconsistency detected ~
831                                    in ~A at index ~D: ~
832                                    found ~S, expected ~S."
833                                   (if *current-compiland*
834                                       (compiland-name *current-compiland*)
835                                       "<unknown>")
836                                   i instruction-depth
837                                   (+ depth instruction-stack)))
838        (return-from analyze-stack-path))
839      (let ((opcode (instruction-opcode instruction)))
840        (setf depth (+ depth instruction-stack))
841        (setf (instruction-depth instruction) depth)
842        (unless (<= 0 depth)
843          (internal-compiler-error "Stack inconsistency detected ~
844                                    in ~A at index ~D: ~
845                                    negative depth ~S."
846                                   (if *current-compiland*
847                                       (compiland-name *current-compiland*)
848                                       "<unknown>")
849                                   i depth))
850        (when (branch-p opcode)
851          (let ((label (car (instruction-args instruction))))
852            (declare (type symbol label))
853            (analyze-stack-path code (symbol-value label) depth)))
854        (when (unconditional-control-transfer-p opcode)
855          ;; Current path ends.
856          (return-from analyze-stack-path))))))
857
858(declaim (ftype (function (t) t) analyze-stack))
859(defun analyze-stack (code exception-entry-points)
860  (declare (optimize speed))
861  (let* ((code-length (length code)))
862    (declare (type vector code))
863    (dotimes (i code-length)
864      (let* ((instruction (aref code i))
865             (opcode (instruction-opcode instruction)))
866        (when (eql opcode 202) ; LABEL
867          (let ((label (car (instruction-args instruction))))
868            (set label i)))
869        (unless (instruction-stack instruction)
870          (setf (instruction-stack instruction)
871                (opcode-stack-effect opcode))
872          (unless (instruction-stack instruction)
873            (sys::%format t "no stack information for instruction ~D~%"
874                          (instruction-opcode instruction))
875            (aver nil)))))
876    (analyze-stack-path code 0 0)
877    (dolist (entry-point exception-entry-points)
878      ;; Stack depth is always 1 when handler is called.
879      (analyze-stack-path code (symbol-value entry-point) 1))
880    (let ((max-stack 0))
881      (declare (type fixnum max-stack))
882      (dotimes (i code-length)
883        (let* ((instruction (aref code i))
884               (instruction-depth (instruction-depth instruction)))
885          (when instruction-depth
886            (setf max-stack (max max-stack (the fixnum instruction-depth))))))
887      max-stack)))
888
889(defun analyze-locals (code)
890  (let ((code-length (length code))
891        (max-local 0))
892    (dotimes (i code-length max-local)
893      (let* ((instruction (aref code i))
894             (opcode (instruction-opcode instruction)))
895        (setf max-local
896              (max max-local
897                   (or (let ((opcode-register
898                                (jvm-opcode-register-used opcode)))
899                         (if (eq t opcode-register)
900                             (car (instruction-args instruction))
901                             opcode-register))
902                       0)))))))
903
904(defun delete-unused-labels (code handler-labels)
905  (declare (optimize speed))
906  (let ((code (coerce code 'vector))
907        (changed nil)
908        (marker (gensym)))
909    ;; Mark the labels that are actually branched to.
910    (dotimes (i (length code))
911      (let ((instruction (aref code i)))
912        (when (branch-p (instruction-opcode instruction))
913          (let ((label (car (instruction-args instruction))))
914            (set label marker)))))
915    ;; Add labels used for exception handlers.
916    (dolist (label handler-labels)
917      (set label marker))
918    ;; Remove labels that are not used as branch targets.
919    (dotimes (i (length code))
920      (let ((instruction (aref code i)))
921        (when (= (instruction-opcode instruction) 202) ; LABEL
922          (let ((label (car (instruction-args instruction))))
923            (declare (type symbol label))
924            (unless (eq (symbol-value label) marker)
925              (setf (aref code i) nil)
926              (setf changed t))))))
927    (values (if changed (delete nil code) code)
928            changed)))
929
930(defun delete-unreachable-code (code)
931  ;; Look for unreachable code after GOTO.
932  (declare (optimize speed))
933  (let* ((code (coerce code 'vector))
934         (changed nil)
935         (after-goto/areturn nil))
936    (dotimes (i (length code))
937      (declare (type (unsigned-byte 16) i))
938      (let* ((instruction (aref code i))
939             (opcode (instruction-opcode instruction)))
940        (cond (after-goto/areturn
941               (if (= opcode 202) ; LABEL
942                   (setf after-goto/areturn nil)
943                   ;; Unreachable.
944                   (progn
945                     (setf (aref code i) nil)
946                     (setf changed t))))
947              ((unconditional-control-transfer-p opcode)
948               (setf after-goto/areturn t)))))
949    (values (if changed (delete nil code) code)
950            changed)))
951
952
953(declaim (ftype (function (t) label-target-instructions) hash-labels))
954(defun label-target-instructions (code)
955  (let ((ht (make-hash-table :test 'eq))
956        (code (coerce code 'vector))
957        (pending-labels '()))
958    (dotimes (i (length code))
959      (let ((instruction (aref code i)))
960        (cond ((label-p instruction)
961               (push (instruction-label instruction) pending-labels))
962              (t
963               ;; Not a label.
964               (when pending-labels
965                 (dolist (label pending-labels)
966                   (setf (gethash label ht) instruction))
967                 (setf pending-labels nil))))))
968    ht))
969
970(defun optimize-jumps (code)
971  (declare (optimize speed))
972  (let* ((code (coerce code 'vector))
973         (ht (label-target-instructions code))
974         (changed nil))
975    (dotimes (i (length code))
976      (let* ((instruction (aref code i))
977             (opcode (and instruction (instruction-opcode instruction))))
978        (when (and opcode (branch-p opcode))
979          (let* ((target-label (car (instruction-args instruction)))
980                 (next-instruction (gethash1 target-label ht)))
981            (when next-instruction
982              (case (instruction-opcode next-instruction)
983                ((167 200)                  ;; GOTO
984                 (setf (instruction-args instruction)
985                       (instruction-args next-instruction)
986                       changed t))
987                (176 ; ARETURN
988                 (when (unconditional-control-transfer-p opcode)
989                   (setf (instruction-opcode instruction) 176
990                         (instruction-args instruction) nil
991                         changed t)))))))))
992    (values code changed)))
993
994
995(defun optimize-instruction-sequences (code)
996  (let* ((code (coerce code 'vector))
997         (changed nil))
998    (dotimes (i (1- (length code)))
999      (let* ((this-instruction (aref code i))
1000             (this-opcode (and this-instruction
1001                               (instruction-opcode this-instruction)))
1002             (labels-skipped-p nil)
1003             (next-instruction (do ((j (1+ i) (1+ j)))
1004                                   ((or (>= j (length code))
1005                                        (/= 202 ; LABEL
1006                                            (instruction-opcode (aref code j))))
1007                                    (when (< j (length code))
1008                                      (aref code j)))
1009                                 (setf labels-skipped-p t)))
1010             (next-opcode (and next-instruction
1011                               (instruction-opcode next-instruction))))
1012        (case this-opcode
1013          (205 ; CLEAR-VALUES
1014           (when (eql next-opcode 205)       ; CLEAR-VALUES
1015             (setf (aref code i) nil)
1016             (setf changed t)))
1017          (178 ; GETSTATIC
1018           (when (and (eql next-opcode 87)   ; POP
1019                      (not labels-skipped-p))
1020             (setf (aref code i) nil)
1021             (setf (aref code (1+ i)) nil)
1022             (setf changed t)))
1023          (176 ; ARETURN
1024           (when (eql next-opcode 176)       ; ARETURN
1025             (setf (aref code i) nil)
1026             (setf changed t)))
1027          ((200 167)                         ; GOTO GOTO_W
1028           (when (and (or (eql next-opcode 202)  ; LABEL
1029                          (eql next-opcode 200)  ; GOTO_W
1030                          (eql next-opcode 167)) ; GOTO
1031                      (eq (car (instruction-args this-instruction))
1032                          (car (instruction-args next-instruction))))
1033             (setf (aref code i) nil)
1034             (setf changed t))))))
1035    (values (if changed (delete nil code) code)
1036            changed)))
1037
1038(defvar *enable-optimization* t)
1039
1040(defknown optimize-code (t t) t)
1041(defun optimize-code (code handler-labels pool)
1042  (unless *enable-optimization*
1043    (format t "optimizations are disabled~%"))
1044  (when *enable-optimization*
1045    (when *compiler-debug*
1046      (format t "----- before optimization -----~%")
1047      (print-code code pool))
1048    (loop
1049       (let ((changed-p nil))
1050         (multiple-value-setq
1051             (code changed-p)
1052           (delete-unused-labels code handler-labels))
1053         (if changed-p
1054             (setf code (optimize-instruction-sequences code))
1055             (multiple-value-setq
1056                 (code changed-p)
1057               (optimize-instruction-sequences code)))
1058         (if changed-p
1059             (setf code (optimize-jumps code))
1060             (multiple-value-setq
1061                 (code changed-p)
1062               (optimize-jumps code)))
1063         (if changed-p
1064             (setf code (delete-unreachable-code code))
1065             (multiple-value-setq
1066                 (code changed-p)
1067               (delete-unreachable-code code)))
1068         (unless changed-p
1069           (return))))
1070    (unless (vectorp code)
1071      (setf code (coerce code 'vector)))
1072    (when *compiler-debug*
1073      (sys::%format t "----- after optimization -----~%")
1074      (print-code code pool)))
1075  code)
1076
1077
1078
1079
1080(defun code-bytes (code)
1081  (let ((length 0)
1082        labels ;; alist
1083        )
1084    (declare (type (unsigned-byte 16) length))
1085    ;; Pass 1: calculate label offsets and overall length.
1086    (dotimes (i (length code))
1087      (declare (type (unsigned-byte 16) i))
1088      (let* ((instruction (aref code i))
1089             (opcode (instruction-opcode instruction)))
1090        (if (= opcode 202) ; LABEL
1091            (let ((label (car (instruction-args instruction))))
1092              (set label length)
1093              (setf labels
1094                    (acons label length labels)))
1095            (incf length (opcode-size opcode)))))
1096    ;; Pass 2: replace labels with calculated offsets.
1097    (let ((index 0))
1098      (declare (type (unsigned-byte 16) index))
1099      (dotimes (i (length code))
1100        (declare (type (unsigned-byte 16) i))
1101        (let ((instruction (aref code i)))
1102          (when (branch-p (instruction-opcode instruction))
1103            (let* ((label (car (instruction-args instruction)))
1104                   (offset (- (the (unsigned-byte 16)
1105                                (symbol-value (the symbol label)))
1106                              index)))
1107              (assert (<= -32768 offset 32767))
1108              (setf (instruction-args instruction) (s2 offset))))
1109          (unless (= (instruction-opcode instruction) 202) ; LABEL
1110            (incf index (opcode-size (instruction-opcode instruction)))))))
1111    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
1112    (let ((bytes (make-array length))
1113          (index 0))
1114      (declare (type (unsigned-byte 16) index))
1115      (dotimes (i (length code))
1116        (declare (type (unsigned-byte 16) i))
1117        (let ((instruction (aref code i)))
1118          (unless (= (instruction-opcode instruction) 202) ; LABEL
1119            (setf (svref bytes index) (instruction-opcode instruction))
1120            (incf index)
1121            (dolist (byte (instruction-args instruction))
1122              (setf (svref bytes index) byte)
1123              (incf index)))))
1124      (values bytes labels))))
1125
1126(defun finalize-code (code handler-labels optimize pool)
1127  (setf code (coerce (nreverse code) 'vector))
1128  (when optimize
1129    (setf code (optimize-code code handler-labels pool)))
1130  (resolve-instructions (expand-virtual-instructions code)))
1131
1132(provide '#:jvm-instructions)
Note: See TracBrowser for help on using the repository browser.