1 | ;;; jvm-instructions.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2006 Peter Graves |
---|
4 | ;;; Copyright (C) 2010 Erik Huelsmann |
---|
5 | ;;; $Id: jvm-instructions.lisp 14407 2013-03-01 20:47:38Z 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 | ;; 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 | (declaim (ftype (function (t) t) branch-p) |
---|
465 | (inline branch-p)) |
---|
466 | (defun branch-p (opcode) |
---|
467 | ;; (declare (optimize speed)) |
---|
468 | ;; (declare (type '(integer 0 255) opcode)) |
---|
469 | (or (<= 153 opcode 167) |
---|
470 | (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w |
---|
471 | |
---|
472 | (declaim (ftype (function (t) t) unconditional-control-transfer-p) |
---|
473 | (inline unconditional-control-transfer-p)) |
---|
474 | (defun unconditional-control-transfer-p (opcode) |
---|
475 | (or (= 167 opcode) ;; goto |
---|
476 | (= 200 opcode) ;; goto_w |
---|
477 | (<= 172 opcode 177) ;; ?return |
---|
478 | (= 191 opcode) ;; athrow |
---|
479 | )) |
---|
480 | |
---|
481 | (declaim (ftype (function (t) boolean) label-p) |
---|
482 | (inline label-p)) |
---|
483 | (defun label-p (instruction) |
---|
484 | (and instruction |
---|
485 | (= (the fixnum (instruction-opcode (the instruction instruction))) 202))) |
---|
486 | |
---|
487 | (defun format-instruction-args (instruction pool) |
---|
488 | (if (memql (instruction-opcode instruction) '(18 19 20 |
---|
489 | 178 179 180 181 182 183 184 185 |
---|
490 | 187 |
---|
491 | 192 193)) |
---|
492 | (let ((*print-readably* nil) |
---|
493 | (*print-escape* nil)) |
---|
494 | (with-output-to-string (s) |
---|
495 | (print-pool-constant pool |
---|
496 | (find-pool-entry pool |
---|
497 | (car (instruction-args instruction))) s |
---|
498 | :package "org/armedbear/lisp"))) |
---|
499 | (when (instruction-args instruction) |
---|
500 | (format nil "~S" (instruction-args instruction))))) |
---|
501 | |
---|
502 | (defun print-code (code pool) |
---|
503 | (declare (ignorable pool)) |
---|
504 | (dotimes (i (length code)) |
---|
505 | (let ((instruction (elt code i))) |
---|
506 | (format t "~3D ~A ~19T~A ~A ~A~%" |
---|
507 | i |
---|
508 | (opcode-name (instruction-opcode instruction)) |
---|
509 | (or (format-instruction-args instruction pool) "") |
---|
510 | (or (instruction-stack instruction) "") |
---|
511 | (or (instruction-depth instruction) ""))))) |
---|
512 | |
---|
513 | (defun print-code2 (code pool) |
---|
514 | (declare (ignorable pool)) |
---|
515 | (dotimes (i (length code)) |
---|
516 | (let ((instruction (elt code i))) |
---|
517 | (case (instruction-opcode instruction) |
---|
518 | (202 ; LABEL |
---|
519 | (format t "~A:~%" (car (instruction-args instruction)))) |
---|
520 | (t |
---|
521 | (format t "~8D: ~A ~S~%" |
---|
522 | i |
---|
523 | (opcode-name (instruction-opcode instruction)) |
---|
524 | (instruction-args instruction))))))) |
---|
525 | |
---|
526 | (defun expand-virtual-instructions (code) |
---|
527 | (let* ((len (length code)) |
---|
528 | (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t))) |
---|
529 | (dotimes (index len vector) |
---|
530 | (declare (type (unsigned-byte 16) index)) |
---|
531 | (let ((instruction (svref code index))) |
---|
532 | (case (instruction-opcode instruction) |
---|
533 | (205 ; CLEAR-VALUES |
---|
534 | (dolist (instruction |
---|
535 | (list |
---|
536 | (inst 'aload (car (instruction-args instruction))) |
---|
537 | (inst 'aconst_null) |
---|
538 | (inst 'putfield (list (pool-field +lisp-thread+ "_values" |
---|
539 | +lisp-object-array+))))) |
---|
540 | (vector-push-extend instruction vector))) |
---|
541 | (t |
---|
542 | (vector-push-extend instruction vector))))))) |
---|
543 | |
---|
544 | |
---|
545 | ;; RESOLVERS |
---|
546 | |
---|
547 | (defun unsupported-opcode (instruction) |
---|
548 | (error "Unsupported opcode ~D." (instruction-opcode instruction))) |
---|
549 | |
---|
550 | (declaim (type hash-table +resolvers+)) |
---|
551 | (defconst +resolvers+ (make-hash-table)) |
---|
552 | |
---|
553 | (defun initialize-resolvers () |
---|
554 | (let ((ht +resolvers+)) |
---|
555 | (dotimes (n (1+ *last-opcode*)) |
---|
556 | (setf (gethash n ht) #'unsupported-opcode)) |
---|
557 | ;; The following opcodes resolve to themselves. |
---|
558 | (dolist (n '(0 ; nop |
---|
559 | 1 ; aconst_null |
---|
560 | 2 ; iconst_m1 |
---|
561 | 3 ; iconst_0 |
---|
562 | 4 ; iconst_1 |
---|
563 | 5 ; iconst_2 |
---|
564 | 6 ; iconst_3 |
---|
565 | 7 ; iconst_4 |
---|
566 | 8 ; iconst_5 |
---|
567 | 9 ; lconst_0 |
---|
568 | 10 ; lconst_1 |
---|
569 | 11 ; fconst_0 |
---|
570 | 12 ; fconst_1 |
---|
571 | 13 ; fconst_2 |
---|
572 | 14 ; dconst_0 |
---|
573 | 15 ; dconst_1 |
---|
574 | 42 ; aload_0 |
---|
575 | 43 ; aload_1 |
---|
576 | 44 ; aload_2 |
---|
577 | 45 ; aload_3 |
---|
578 | 46 ; iaload |
---|
579 | 47 ; laload |
---|
580 | 48 ; faload |
---|
581 | 49 ; daload |
---|
582 | 50 ; aaload |
---|
583 | 75 ; astore_0 |
---|
584 | 76 ; astore_1 |
---|
585 | 77 ; astore_2 |
---|
586 | 78 ; astore_3 |
---|
587 | 79 ; iastore |
---|
588 | 80 ; lastore |
---|
589 | 81 ; fastore |
---|
590 | 82 ; dastore |
---|
591 | 83 ; aastore |
---|
592 | 87 ; pop |
---|
593 | 88 ; pop2 |
---|
594 | 89 ; dup |
---|
595 | 90 ; dup_x1 |
---|
596 | 91 ; dup_x2 |
---|
597 | 92 ; dup2 |
---|
598 | 93 ; dup2_x1 |
---|
599 | 94 ; dup2_x2 |
---|
600 | 95 ; swap |
---|
601 | 96 ; iadd |
---|
602 | 97 ; ladd |
---|
603 | 98 ; fadd |
---|
604 | 99 ; dadd |
---|
605 | 100 ; isub |
---|
606 | 101 ; lsub |
---|
607 | 102 ; fsub |
---|
608 | 103 ; dsub |
---|
609 | 104 ; imul |
---|
610 | 105 ; lmul |
---|
611 | 106 ; fmul |
---|
612 | 107 ; dmul |
---|
613 | 116 ; ineg |
---|
614 | 117 ; lneg |
---|
615 | 118 ; fneg |
---|
616 | 119 ; dneg |
---|
617 | 120 ; ishl |
---|
618 | 121 ; lshl |
---|
619 | 122 ; ishr |
---|
620 | 123 ; lshr |
---|
621 | 126 ; iand |
---|
622 | 127 ; land |
---|
623 | 128 ; ior |
---|
624 | 129 ; lor |
---|
625 | 130 ; ixor |
---|
626 | 131 ; lxor |
---|
627 | 133 ; i2l |
---|
628 | 134 ; i2f |
---|
629 | 135 ; i2d |
---|
630 | 136 ; l2i |
---|
631 | 137 ; l2f |
---|
632 | 138 ; l2d |
---|
633 | 141 ; f2d |
---|
634 | 144 ; d2f |
---|
635 | 148 ; lcmp |
---|
636 | 149 ; fcmpd |
---|
637 | 150 ; fcmpg |
---|
638 | 151 ; dcmpd |
---|
639 | 152 ; dcmpg |
---|
640 | 153 ; ifeq |
---|
641 | 154 ; ifne |
---|
642 | 155 ; ifge |
---|
643 | 156 ; ifgt |
---|
644 | 157 ; ifgt |
---|
645 | 158 ; ifle |
---|
646 | 159 ; if_icmpeq |
---|
647 | 160 ; if_icmpne |
---|
648 | 161 ; if_icmplt |
---|
649 | 162 ; if_icmpge |
---|
650 | 163 ; if_icmpgt |
---|
651 | 164 ; if_icmple |
---|
652 | 165 ; if_acmpeq |
---|
653 | 166 ; if_acmpne |
---|
654 | 167 ; goto |
---|
655 | 172 ; ireturn |
---|
656 | 176 ; areturn |
---|
657 | 177 ; return |
---|
658 | 189 ; anewarray |
---|
659 | 190 ; arraylength |
---|
660 | 191 ; athrow |
---|
661 | 194 ; monitorenter |
---|
662 | 195 ; monitorexit |
---|
663 | 198 ; ifnull |
---|
664 | 202 ; label |
---|
665 | )) |
---|
666 | (setf (gethash n ht) nil)))) |
---|
667 | |
---|
668 | (initialize-resolvers) |
---|
669 | |
---|
670 | (defmacro define-resolver (opcodes args &body body) |
---|
671 | (let ((name (gensym))) |
---|
672 | `(progn |
---|
673 | (defun ,name ,args ,@body) |
---|
674 | (eval-when (:load-toplevel :execute) |
---|
675 | ,(if (listp opcodes) |
---|
676 | `(dolist (op ',opcodes) |
---|
677 | (setf (gethash op +resolvers+) |
---|
678 | (symbol-function ',name))) |
---|
679 | `(setf (gethash ,opcodes +resolvers+) |
---|
680 | (symbol-function ',name))))))) |
---|
681 | |
---|
682 | (defun load/store-resolver (instruction inst-index inst-index2 error-text) |
---|
683 | (let* ((args (instruction-args instruction)) |
---|
684 | (index (car args))) |
---|
685 | (declare (type (unsigned-byte 16) index)) |
---|
686 | (cond ((<= 0 index 3) |
---|
687 | (inst (+ index inst-index))) |
---|
688 | ((<= 0 index 255) |
---|
689 | (inst inst-index2 index)) |
---|
690 | (t |
---|
691 | (error error-text))))) |
---|
692 | |
---|
693 | ;; aload |
---|
694 | (define-resolver 25 (instruction) |
---|
695 | (load/store-resolver instruction 42 25 "ALOAD unsupported case")) |
---|
696 | |
---|
697 | ;; astore |
---|
698 | (define-resolver 58 (instruction) |
---|
699 | (load/store-resolver instruction 75 58 "ASTORE unsupported case")) |
---|
700 | |
---|
701 | ;; iload |
---|
702 | (define-resolver 21 (instruction) |
---|
703 | (load/store-resolver instruction 26 21 "ILOAD unsupported case")) |
---|
704 | |
---|
705 | ;; istore |
---|
706 | (define-resolver 54 (instruction) |
---|
707 | (load/store-resolver instruction 59 54 "ISTORE unsupported case")) |
---|
708 | |
---|
709 | ;; lload |
---|
710 | (define-resolver 22 (instruction) |
---|
711 | (load/store-resolver instruction 30 22 "LLOAD unsupported case")) |
---|
712 | |
---|
713 | ;; lstore |
---|
714 | (define-resolver 55 (instruction) |
---|
715 | (load/store-resolver instruction 63 55 "LSTORE unsupported case")) |
---|
716 | |
---|
717 | ;; bipush, sipush |
---|
718 | (define-resolver (16 17) (instruction) |
---|
719 | (let* ((args (instruction-args instruction)) |
---|
720 | (n (first args))) |
---|
721 | (declare (type fixnum n)) |
---|
722 | (cond ((<= 0 n 5) |
---|
723 | (inst (+ n 3))) |
---|
724 | ((<= -128 n 127) |
---|
725 | (inst 16 (logand n #xff))) ; BIPUSH |
---|
726 | (t ; SIPUSH |
---|
727 | (inst 17 (s2 n)))))) |
---|
728 | |
---|
729 | ;; ldc |
---|
730 | (define-resolver 18 (instruction) |
---|
731 | (let* ((args (instruction-args instruction))) |
---|
732 | (unless (= (length args) 1) |
---|
733 | (error "Wrong number of args for LDC.")) |
---|
734 | (if (> (car args) 255) |
---|
735 | (inst 19 (u2 (car args))) ; LDC_W |
---|
736 | (inst 18 args)))) |
---|
737 | |
---|
738 | ;; ldc_w |
---|
739 | (define-resolver 19 (instruction) |
---|
740 | (let* ((args (instruction-args instruction))) |
---|
741 | (unless (= (length args) 1) |
---|
742 | (error "Wrong number of args for LDC_W.")) |
---|
743 | (inst 19 (u2 (car args))))) |
---|
744 | |
---|
745 | ;; ldc2_w |
---|
746 | (define-resolver 20 (instruction) |
---|
747 | (let* ((args (instruction-args instruction))) |
---|
748 | (unless (= (length args) 1) |
---|
749 | (error "Wrong number of args for LDC2_W.")) |
---|
750 | (inst 20 (u2 (car args))))) |
---|
751 | |
---|
752 | ;; iinc |
---|
753 | (define-resolver 132 (instruction) |
---|
754 | (let* ((args (instruction-args instruction)) |
---|
755 | (register (first args)) |
---|
756 | (n (second args))) |
---|
757 | (when (not (<= -128 n 127)) |
---|
758 | (error "IINC argument ~A out of bounds." n)) |
---|
759 | (inst 132 (list register (s1 n))))) |
---|
760 | |
---|
761 | (define-resolver (178 179 180 181 182 183 184 185 192 193 187) |
---|
762 | (instruction) |
---|
763 | (let* ((arg (car (instruction-args instruction)))) |
---|
764 | (setf (instruction-args instruction) |
---|
765 | (u2 arg)) |
---|
766 | instruction)) |
---|
767 | |
---|
768 | (defknown resolve-instruction (t) t) |
---|
769 | (defun resolve-instruction (instruction) |
---|
770 | (declare (optimize speed)) |
---|
771 | (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+))) |
---|
772 | (if resolver |
---|
773 | (funcall resolver instruction) |
---|
774 | instruction))) |
---|
775 | |
---|
776 | (defun resolve-instructions (code) |
---|
777 | (let* ((len (length code)) |
---|
778 | (vector (make-array len :fill-pointer 0 :adjustable t))) |
---|
779 | (dotimes (index len vector) |
---|
780 | (declare (type (unsigned-byte 16) index)) |
---|
781 | (let ((instruction (aref code index))) |
---|
782 | (vector-push-extend (resolve-instruction instruction) vector))))) |
---|
783 | |
---|
784 | |
---|
785 | |
---|
786 | ;; BYTE CODE ANALYSIS AND OPTIMIZATION |
---|
787 | |
---|
788 | (declaim (ftype (function (t t t) t) analyze-stack-path)) |
---|
789 | (defun analyze-stack-path (code start-index depth) |
---|
790 | (declare (optimize speed)) |
---|
791 | (declare (type fixnum start-index depth)) |
---|
792 | (do* ((i start-index (1+ i)) |
---|
793 | (limit (length code))) |
---|
794 | ((>= i limit)) |
---|
795 | (declare (type fixnum i limit)) |
---|
796 | (let* ((instruction (aref code i)) |
---|
797 | (instruction-depth (instruction-depth instruction)) |
---|
798 | (instruction-stack (instruction-stack instruction))) |
---|
799 | (declare (type fixnum instruction-stack)) |
---|
800 | (when instruction-depth |
---|
801 | (unless (= (the fixnum instruction-depth) |
---|
802 | (the fixnum (+ depth instruction-stack))) |
---|
803 | (internal-compiler-error "Stack inconsistency detected ~ |
---|
804 | in ~A at index ~D: ~ |
---|
805 | found ~S, expected ~S." |
---|
806 | (if *current-compiland* |
---|
807 | (compiland-name *current-compiland*) |
---|
808 | "<unknown>") |
---|
809 | i instruction-depth |
---|
810 | (+ depth instruction-stack))) |
---|
811 | (return-from analyze-stack-path)) |
---|
812 | (let ((opcode (instruction-opcode instruction))) |
---|
813 | (setf depth (+ depth instruction-stack)) |
---|
814 | (setf (instruction-depth instruction) depth) |
---|
815 | (unless (<= 0 depth) |
---|
816 | (internal-compiler-error "Stack inconsistency detected ~ |
---|
817 | in ~A at index ~D: ~ |
---|
818 | negative depth ~S." |
---|
819 | (if *current-compiland* |
---|
820 | (compiland-name *current-compiland*) |
---|
821 | "<unknown>") |
---|
822 | i depth)) |
---|
823 | (when (branch-p opcode) |
---|
824 | (let ((label (car (instruction-args instruction)))) |
---|
825 | (declare (type symbol label)) |
---|
826 | (analyze-stack-path code (symbol-value label) depth))) |
---|
827 | (when (unconditional-control-transfer-p opcode) |
---|
828 | ;; Current path ends. |
---|
829 | (return-from analyze-stack-path)))))) |
---|
830 | |
---|
831 | (declaim (ftype (function (t) t) analyze-stack)) |
---|
832 | (defun analyze-stack (code exception-entry-points) |
---|
833 | (declare (optimize speed)) |
---|
834 | (let* ((code-length (length code))) |
---|
835 | (declare (type vector code)) |
---|
836 | (dotimes (i code-length) |
---|
837 | (let* ((instruction (aref code i)) |
---|
838 | (opcode (instruction-opcode instruction))) |
---|
839 | (when (eql opcode 202) ; LABEL |
---|
840 | (let ((label (car (instruction-args instruction)))) |
---|
841 | (set label i))) |
---|
842 | (unless (instruction-stack instruction) |
---|
843 | (setf (instruction-stack instruction) |
---|
844 | (opcode-stack-effect opcode)) |
---|
845 | (unless (instruction-stack instruction) |
---|
846 | (sys::%format t "no stack information for instruction ~D~%" |
---|
847 | (instruction-opcode instruction)) |
---|
848 | (aver nil))))) |
---|
849 | (analyze-stack-path code 0 0) |
---|
850 | (dolist (entry-point exception-entry-points) |
---|
851 | ;; Stack depth is always 1 when handler is called. |
---|
852 | (analyze-stack-path code (symbol-value entry-point) 1)) |
---|
853 | (let ((max-stack 0)) |
---|
854 | (declare (type fixnum max-stack)) |
---|
855 | (dotimes (i code-length) |
---|
856 | (let* ((instruction (aref code i)) |
---|
857 | (instruction-depth (instruction-depth instruction))) |
---|
858 | (when instruction-depth |
---|
859 | (setf max-stack (max max-stack (the fixnum instruction-depth)))))) |
---|
860 | max-stack))) |
---|
861 | |
---|
862 | (defun analyze-locals (code) |
---|
863 | (let ((code-length (length code)) |
---|
864 | (max-local 0)) |
---|
865 | (dotimes (i code-length max-local) |
---|
866 | (let* ((instruction (aref code i)) |
---|
867 | (opcode (instruction-opcode instruction))) |
---|
868 | (setf max-local |
---|
869 | (max max-local |
---|
870 | (or (let ((opcode-register |
---|
871 | (jvm-opcode-register-used opcode))) |
---|
872 | (if (eq t opcode-register) |
---|
873 | (car (instruction-args instruction)) |
---|
874 | opcode-register)) |
---|
875 | 0))))))) |
---|
876 | |
---|
877 | (defun delete-unused-labels (code handler-labels) |
---|
878 | (declare (optimize speed)) |
---|
879 | (let ((code (coerce code 'vector)) |
---|
880 | (changed nil) |
---|
881 | (marker (gensym))) |
---|
882 | ;; Mark the labels that are actually branched to. |
---|
883 | (dotimes (i (length code)) |
---|
884 | (let ((instruction (aref code i))) |
---|
885 | (when (branch-p (instruction-opcode instruction)) |
---|
886 | (let ((label (car (instruction-args instruction)))) |
---|
887 | (set label marker))))) |
---|
888 | ;; Add labels used for exception handlers. |
---|
889 | (dolist (label handler-labels) |
---|
890 | (set label marker)) |
---|
891 | ;; Remove labels that are not used as branch targets. |
---|
892 | (dotimes (i (length code)) |
---|
893 | (let ((instruction (aref code i))) |
---|
894 | (when (= (instruction-opcode instruction) 202) ; LABEL |
---|
895 | (let ((label (car (instruction-args instruction)))) |
---|
896 | (declare (type symbol label)) |
---|
897 | (unless (eq (symbol-value label) marker) |
---|
898 | (setf (aref code i) nil) |
---|
899 | (setf changed t)))))) |
---|
900 | (values (if changed (delete nil code) code) |
---|
901 | changed))) |
---|
902 | |
---|
903 | (defun delete-unreachable-code (code) |
---|
904 | ;; Look for unreachable code after GOTO. |
---|
905 | (declare (optimize speed)) |
---|
906 | (let* ((code (coerce code 'vector)) |
---|
907 | (changed nil) |
---|
908 | (after-goto/areturn nil)) |
---|
909 | (dotimes (i (length code)) |
---|
910 | (declare (type (unsigned-byte 16) i)) |
---|
911 | (let* ((instruction (aref code i)) |
---|
912 | (opcode (instruction-opcode instruction))) |
---|
913 | (cond (after-goto/areturn |
---|
914 | (if (= opcode 202) ; LABEL |
---|
915 | (setf after-goto/areturn nil) |
---|
916 | ;; Unreachable. |
---|
917 | (progn |
---|
918 | (setf (aref code i) nil) |
---|
919 | (setf changed t)))) |
---|
920 | ((unconditional-control-transfer-p opcode) |
---|
921 | (setf after-goto/areturn t))))) |
---|
922 | (values (if changed (delete nil code) code) |
---|
923 | changed))) |
---|
924 | |
---|
925 | |
---|
926 | (declaim (ftype (function (t) label-target-instructions) hash-labels)) |
---|
927 | (defun label-target-instructions (code) |
---|
928 | (let ((ht (make-hash-table :test 'eq)) |
---|
929 | (code (coerce code 'vector)) |
---|
930 | (pending-labels '())) |
---|
931 | (dotimes (i (length code)) |
---|
932 | (let ((instruction (aref code i))) |
---|
933 | (cond ((label-p instruction) |
---|
934 | (push (instruction-label instruction) pending-labels)) |
---|
935 | (t |
---|
936 | ;; Not a label. |
---|
937 | (when pending-labels |
---|
938 | (dolist (label pending-labels) |
---|
939 | (setf (gethash label ht) instruction)) |
---|
940 | (setf pending-labels nil)))))) |
---|
941 | ht)) |
---|
942 | |
---|
943 | (defun optimize-jumps (code) |
---|
944 | (declare (optimize speed)) |
---|
945 | (let* ((code (coerce code 'vector)) |
---|
946 | (ht (label-target-instructions code)) |
---|
947 | (changed nil)) |
---|
948 | (dotimes (i (length code)) |
---|
949 | (let* ((instruction (aref code i)) |
---|
950 | (opcode (and instruction (instruction-opcode instruction)))) |
---|
951 | (when (and opcode (branch-p opcode)) |
---|
952 | (let* ((target-label (car (instruction-args instruction))) |
---|
953 | (next-instruction (gethash1 target-label ht))) |
---|
954 | (when next-instruction |
---|
955 | (case (instruction-opcode next-instruction) |
---|
956 | ((167 200) ;; GOTO |
---|
957 | (setf (instruction-args instruction) |
---|
958 | (instruction-args next-instruction) |
---|
959 | changed t)) |
---|
960 | (176 ; ARETURN |
---|
961 | (when (unconditional-control-transfer-p opcode) |
---|
962 | (setf (instruction-opcode instruction) 176 |
---|
963 | (instruction-args instruction) nil |
---|
964 | changed t))))))))) |
---|
965 | (values code changed))) |
---|
966 | |
---|
967 | |
---|
968 | (defun optimize-instruction-sequences (code) |
---|
969 | (let* ((code (coerce code 'vector)) |
---|
970 | (changed nil)) |
---|
971 | (dotimes (i (1- (length code))) |
---|
972 | (let* ((this-instruction (aref code i)) |
---|
973 | (this-opcode (and this-instruction |
---|
974 | (instruction-opcode this-instruction))) |
---|
975 | (labels-skipped-p nil) |
---|
976 | (next-instruction (do ((j (1+ i) (1+ j))) |
---|
977 | ((or (>= j (length code)) |
---|
978 | (/= 202 ; LABEL |
---|
979 | (instruction-opcode (aref code j)))) |
---|
980 | (when (< j (length code)) |
---|
981 | (aref code j))) |
---|
982 | (setf labels-skipped-p t))) |
---|
983 | (next-opcode (and next-instruction |
---|
984 | (instruction-opcode next-instruction)))) |
---|
985 | (case this-opcode |
---|
986 | (205 ; CLEAR-VALUES |
---|
987 | (when (eql next-opcode 205) ; CLEAR-VALUES |
---|
988 | (setf (aref code i) nil) |
---|
989 | (setf changed t))) |
---|
990 | (178 ; GETSTATIC |
---|
991 | (when (and (eql next-opcode 87) ; POP |
---|
992 | (not labels-skipped-p)) |
---|
993 | (setf (aref code i) nil) |
---|
994 | (setf (aref code (1+ i)) nil) |
---|
995 | (setf changed t))) |
---|
996 | (176 ; ARETURN |
---|
997 | (when (eql next-opcode 176) ; ARETURN |
---|
998 | (setf (aref code i) nil) |
---|
999 | (setf changed t))) |
---|
1000 | ((200 167) ; GOTO GOTO_W |
---|
1001 | (when (and (or (eql next-opcode 202) ; LABEL |
---|
1002 | (eql next-opcode 200) ; GOTO_W |
---|
1003 | (eql next-opcode 167)) ; GOTO |
---|
1004 | (eq (car (instruction-args this-instruction)) |
---|
1005 | (car (instruction-args next-instruction)))) |
---|
1006 | (setf (aref code i) nil) |
---|
1007 | (setf changed t)))))) |
---|
1008 | (values (if changed (delete nil code) code) |
---|
1009 | changed))) |
---|
1010 | |
---|
1011 | (defvar *enable-optimization* t) |
---|
1012 | |
---|
1013 | (defknown optimize-code (t t) t) |
---|
1014 | (defun optimize-code (code handler-labels pool) |
---|
1015 | (unless *enable-optimization* |
---|
1016 | (format t "optimizations are disabled~%")) |
---|
1017 | (when *enable-optimization* |
---|
1018 | (when *compiler-debug* |
---|
1019 | (format t "----- before optimization -----~%") |
---|
1020 | (print-code code pool)) |
---|
1021 | (loop |
---|
1022 | (let ((changed-p nil)) |
---|
1023 | (multiple-value-setq |
---|
1024 | (code changed-p) |
---|
1025 | (delete-unused-labels code handler-labels)) |
---|
1026 | (if changed-p |
---|
1027 | (setf code (optimize-instruction-sequences code)) |
---|
1028 | (multiple-value-setq |
---|
1029 | (code changed-p) |
---|
1030 | (optimize-instruction-sequences code))) |
---|
1031 | (if changed-p |
---|
1032 | (setf code (optimize-jumps code)) |
---|
1033 | (multiple-value-setq |
---|
1034 | (code changed-p) |
---|
1035 | (optimize-jumps code))) |
---|
1036 | (if changed-p |
---|
1037 | (setf code (delete-unreachable-code code)) |
---|
1038 | (multiple-value-setq |
---|
1039 | (code changed-p) |
---|
1040 | (delete-unreachable-code code))) |
---|
1041 | (unless changed-p |
---|
1042 | (return)))) |
---|
1043 | (unless (vectorp code) |
---|
1044 | (setf code (coerce code 'vector))) |
---|
1045 | (when *compiler-debug* |
---|
1046 | (sys::%format t "----- after optimization -----~%") |
---|
1047 | (print-code code pool))) |
---|
1048 | code) |
---|
1049 | |
---|
1050 | |
---|
1051 | |
---|
1052 | |
---|
1053 | (defun code-bytes (code) |
---|
1054 | (let ((length 0) |
---|
1055 | labels ;; alist |
---|
1056 | ) |
---|
1057 | (declare (type (unsigned-byte 16) length)) |
---|
1058 | ;; Pass 1: calculate label offsets and overall length. |
---|
1059 | (dotimes (i (length code)) |
---|
1060 | (declare (type (unsigned-byte 16) i)) |
---|
1061 | (let* ((instruction (aref code i)) |
---|
1062 | (opcode (instruction-opcode instruction))) |
---|
1063 | (if (= opcode 202) ; LABEL |
---|
1064 | (let ((label (car (instruction-args instruction)))) |
---|
1065 | (set label length) |
---|
1066 | (setf labels |
---|
1067 | (acons label length labels))) |
---|
1068 | (incf length (opcode-size opcode))))) |
---|
1069 | ;; Pass 2: replace labels with calculated offsets. |
---|
1070 | (let ((index 0)) |
---|
1071 | (declare (type (unsigned-byte 16) index)) |
---|
1072 | (dotimes (i (length code)) |
---|
1073 | (declare (type (unsigned-byte 16) i)) |
---|
1074 | (let ((instruction (aref code i))) |
---|
1075 | (when (branch-p (instruction-opcode instruction)) |
---|
1076 | (let* ((label (car (instruction-args instruction))) |
---|
1077 | (offset (- (the (unsigned-byte 16) |
---|
1078 | (symbol-value (the symbol label))) |
---|
1079 | index))) |
---|
1080 | (assert (<= -32768 offset 32767)) |
---|
1081 | (setf (instruction-args instruction) (s2 offset)))) |
---|
1082 | (unless (= (instruction-opcode instruction) 202) ; LABEL |
---|
1083 | (incf index (opcode-size (instruction-opcode instruction))))))) |
---|
1084 | ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. |
---|
1085 | (let ((bytes (make-array length)) |
---|
1086 | (index 0)) |
---|
1087 | (declare (type (unsigned-byte 16) index)) |
---|
1088 | (dotimes (i (length code)) |
---|
1089 | (declare (type (unsigned-byte 16) i)) |
---|
1090 | (let ((instruction (aref code i))) |
---|
1091 | (unless (= (instruction-opcode instruction) 202) ; LABEL |
---|
1092 | (setf (svref bytes index) (instruction-opcode instruction)) |
---|
1093 | (incf index) |
---|
1094 | (dolist (byte (instruction-args instruction)) |
---|
1095 | (setf (svref bytes index) byte) |
---|
1096 | (incf index))))) |
---|
1097 | (values bytes labels)))) |
---|
1098 | |
---|
1099 | (defun finalize-code (code handler-labels optimize pool) |
---|
1100 | (setf code (coerce (nreverse code) 'vector)) |
---|
1101 | (when optimize |
---|
1102 | (setf code (optimize-code code handler-labels pool))) |
---|
1103 | (resolve-instructions (expand-virtual-instructions code))) |
---|
1104 | |
---|
1105 | (provide '#:jvm-instructions) |
---|