Context Navigation

source: branches/1.1.x/src/org/armedbear/lisp/jvm-instructions.lisp

Visit:

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: