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

Last change on this file since 14215 was 14111, checked in by ehuelsmann, 8 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.