Changeset 12865


Ignore:
Timestamp:
08/06/10 20:59:50 (12 years ago)
Author:
ehuelsmann
Message:

Move emit, %emit, %%emit, INSTRUCTION, resolvers and some helper
functions from compiler-pass2.lisp to jvm-instructions.lisp: this
is a step to separate pass2 into several modules.

Location:
branches/generic-class-file/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12864 r12865  
    213213                                  start end handler type)))
    214214
    215 (defstruct (instruction (:constructor %make-instruction (opcode args)))
    216   (opcode 0 :type (integer 0 255))
    217   args
    218   stack
    219   depth
    220   wide)
    221 
    222 (defun make-instruction (opcode args)
    223   (let ((inst (apply #'%make-instruction
    224                      (list opcode
    225                            (remove :wide-prefix args)))))
    226     (when (memq :wide-prefix args)
    227       (setf (inst-wide inst) t))
    228     inst))
    229 
    230 (defun print-instruction (instruction)
    231   (sys::%format nil "~A ~A stack = ~S depth = ~S"
    232           (opcode-name (instruction-opcode instruction))
    233           (instruction-args instruction)
    234           (instruction-stack instruction)
    235           (instruction-depth instruction)))
    236 
    237 (defknown inst * t)
    238 (defun inst (instr &optional args)
    239   (declare (optimize speed))
    240   (let ((opcode (if (fixnump instr)
    241                     instr
    242                     (opcode-number instr))))
    243     (unless (listp args)
    244       (setf args (list args)))
    245     (make-instruction opcode args)))
    246 
    247 (defknown %%emit * t)
    248 (defun %%emit (instr &rest args)
    249   (declare (optimize speed))
    250   (let ((instruction (make-instruction instr args)))
    251     (push instruction *code*)
    252     instruction))
    253 
    254 (defknown %emit * t)
    255 (defun %emit (instr &rest args)
    256   (declare (optimize speed))
    257   (let ((instruction (inst instr args)))
    258     (push instruction *code*)
    259     instruction))
    260 
    261 (defmacro emit (instr &rest args)
    262   (when (and (consp instr) (eq (car instr) 'QUOTE) (symbolp (cadr instr)))
    263     (setf instr (opcode-number (cadr instr))))
    264   (if (fixnump instr)
    265       `(%%emit ,instr ,@args)
    266       `(%emit ,instr ,@args)))
    267 
    268 (defknown label (symbol) t)
    269 (defun label (symbol)
    270   (declare (type symbol symbol))
    271   (declare (optimize speed))
    272   (emit 'label symbol)
    273   (setf (symbol-value symbol) nil))
    274 
    275 (defknown aload (fixnum) t)
    276 (defun aload (index)
    277   (case index
    278     (0 (emit 'aload_0))
    279     (1 (emit 'aload_1))
    280     (2 (emit 'aload_2))
    281     (3 (emit 'aload_3))
    282     (t (emit 'aload index))))
    283 
    284 (defknown astore (fixnum) t)
    285 (defun astore (index)
    286   (case index
    287     (0 (emit 'astore_0))
    288     (1 (emit 'astore_1))
    289     (2 (emit 'astore_2))
    290     (3 (emit 'astore_3))
    291     (t (emit 'astore index))))
     215
    292216
    293217(defknown emit-push-nil () t)
     
    990914  (check-number-of-args form n t))
    991915
    992 (defun unsupported-opcode (instruction)
    993   (error "Unsupported opcode ~D." (instruction-opcode instruction)))
    994 
    995 (declaim (type hash-table +resolvers+))
    996 (defconst +resolvers+ (make-hash-table))
    997 
    998 (defun initialize-resolvers ()
    999   (let ((ht +resolvers+))
    1000     (dotimes (n (1+ *last-opcode*))
    1001       (setf (gethash n ht) #'unsupported-opcode))
    1002     ;; The following opcodes resolve to themselves.
    1003     (dolist (n '(0 ; nop
    1004                  1 ; aconst_null
    1005                  2 ; iconst_m1
    1006                  3 ; iconst_0
    1007                  4 ; iconst_1
    1008                  5 ; iconst_2
    1009                  6 ; iconst_3
    1010                  7 ; iconst_4
    1011                  8 ; iconst_5
    1012                  9 ; lconst_0
    1013                  10 ; lconst_1
    1014                  11 ; fconst_0
    1015                  12 ; fconst_1
    1016                  13 ; fconst_2
    1017                  14 ; dconst_0
    1018                  15 ; dconst_1
    1019                  42 ; aload_0
    1020                  43 ; aload_1
    1021                  44 ; aload_2
    1022                  45 ; aload_3
    1023                  46 ; iaload
    1024                  47 ; laload
    1025                  48 ; faload
    1026                  49 ; daload
    1027                  50 ; aaload
    1028                  75 ; astore_0
    1029                  76 ; astore_1
    1030                  77 ; astore_2
    1031                  78 ; astore_3
    1032                  79 ; iastore
    1033                  80 ; lastore
    1034                  81 ; fastore
    1035                  82 ; dastore
    1036                  83 ; aastore
    1037                  87 ; pop
    1038                  88 ; pop2
    1039                  89 ; dup
    1040                  90 ; dup_x1
    1041                  91 ; dup_x2
    1042                  92 ; dup2
    1043                  93 ; dup2_x1
    1044                  94 ; dup2_x2
    1045                  95 ; swap
    1046                  96 ; iadd
    1047                  97 ; ladd
    1048                  98 ; fadd
    1049                  99 ; dadd
    1050                  100 ; isub
    1051                  101 ; lsub
    1052                  102 ; fsub
    1053                  103 ; dsub
    1054                  104 ; imul
    1055                  105 ; lmul
    1056                  106 ; fmul
    1057                  107 ; dmul
    1058                  116 ; ineg
    1059                  117 ; lneg
    1060                  118 ; fneg
    1061                  119 ; dneg
    1062                  120 ; ishl
    1063                  121 ; lshl
    1064                  122 ; ishr
    1065                  123 ; lshr
    1066                  126 ; iand
    1067                  127 ; land
    1068                  128 ; ior
    1069                  129 ; lor
    1070                  130 ; ixor
    1071                  131 ; lxor
    1072                  133 ; i2l
    1073                  134 ; i2f
    1074                  135 ; i2d
    1075                  136 ; l2i
    1076                  137 ; l2f
    1077                  138 ; l2d
    1078                  141 ; f2d
    1079                  144 ; d2f
    1080                  148 ; lcmp
    1081                  149 ; fcmpd
    1082                  150 ; fcmpg
    1083                  151 ; dcmpd
    1084                  152 ; dcmpg
    1085                  153 ; ifeq
    1086                  154 ; ifne
    1087                  155 ; ifge
    1088                  156 ; ifgt
    1089                  157 ; ifgt
    1090                  158 ; ifle
    1091                  159 ; if_icmpeq
    1092                  160 ; if_icmpne
    1093                  161 ; if_icmplt
    1094                  162 ; if_icmpge
    1095                  163 ; if_icmpgt
    1096                  164 ; if_icmple
    1097                  165 ; if_acmpeq
    1098                  166 ; if_acmpne
    1099                  167 ; goto
    1100                  176 ; areturn
    1101                  177 ; return
    1102                  190 ; arraylength
    1103                  191 ; athrow
    1104                  194 ; monitorenter
    1105                  195 ; monitorexit
    1106                  198 ; ifnull
    1107                  202 ; label
    1108                  ))
    1109       (setf (gethash n ht) nil))))
    1110 
    1111 (initialize-resolvers)
    1112 
    1113 (defmacro define-resolver (opcodes args &body body)
    1114   (let ((name (gensym)))
    1115     `(progn
    1116        (defun ,name ,args ,@body)
    1117        (eval-when (:load-toplevel :execute)
    1118    ,(if (listp opcodes)
    1119         `(dolist (op ',opcodes)
    1120      (setf (gethash op +resolvers+) (symbol-function ',name)))
    1121         `(setf (gethash ,opcodes +resolvers+) (symbol-function ',name)))))))
    1122 
    1123 (defun load/store-resolver (instruction inst-index inst-index2 error-text)
    1124  (let* ((args (instruction-args instruction))
    1125         (index (car args)))
    1126    (declare (type (unsigned-byte 16) index))
    1127    (cond ((<= 0 index 3)
    1128           (inst (+ index inst-index)))
    1129          ((<= 0 index 255)
    1130           (inst inst-index2 index))
    1131          (t
    1132           (error error-text)))))
    1133 
    1134 ;; aload
    1135 (define-resolver 25 (instruction)
    1136   (load/store-resolver instruction 42 25 "ALOAD unsupported case"))
    1137 
    1138 ;; astore
    1139 (define-resolver 58 (instruction)
    1140   (load/store-resolver instruction 75 58 "ASTORE unsupported case"))
    1141 
    1142 ;; iload
    1143 (define-resolver 21 (instruction)
    1144   (load/store-resolver instruction 26 21 "ILOAD unsupported case"))
    1145 
    1146 ;; istore
    1147 (define-resolver 54 (instruction)
    1148   (load/store-resolver instruction 59 54 "ISTORE unsupported case"))
    1149 
    1150 ;; lload
    1151 (define-resolver 22 (instruction)
    1152   (load/store-resolver instruction 30 22 "LLOAD unsupported case"))
    1153 
    1154 ;; lstore
    1155 (define-resolver 55 (instruction)
    1156   (load/store-resolver instruction 63 55 "LSTORE unsupported case"))
    1157 
    1158 ;; getstatic, putstatic
    1159 (define-resolver (178 179) (instruction)
    1160   ;; we used to create the pool-field here; that moved to the emit-* layer
    1161   instruction)
    1162 
    1163 ;; bipush, sipush
    1164 (define-resolver (16 17) (instruction)
    1165   (let* ((args (instruction-args instruction))
    1166          (n (first args)))
    1167     (declare (type fixnum n))
    1168     (cond ((<= 0 n 5)
    1169            (inst (+ n 3)))
    1170           ((<= -128 n 127)
    1171            (inst 16 (logand n #xff))) ; BIPUSH
    1172           (t ; SIPUSH
    1173            (inst 17 (s2 n))))))
    1174 
    1175 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
    1176 (define-resolver (182 183 184) (instruction)
    1177   ;; we used to create the pool-method here; that moved to the emit-* layer
    1178   instruction)
    1179 
    1180 ;; ldc
    1181 (define-resolver 18 (instruction)
    1182   (let* ((args (instruction-args instruction)))
    1183     (unless (= (length args) 1)
    1184       (error "Wrong number of args for LDC."))
    1185     (if (> (car args) 255)
    1186         (inst 19 (u2 (car args))) ; LDC_W
    1187         (inst 18 args))))
    1188 
    1189 ;; ldc2_w
    1190 (define-resolver 20 (instruction)
    1191   (let* ((args (instruction-args instruction)))
    1192     (unless (= (length args) 1)
    1193       (error "Wrong number of args for LDC2_W."))
    1194     (inst 20 (u2 (car args)))))
    1195 
    1196 ;; getfield, putfield class-name field-name type-name
    1197 (define-resolver (180 181) (instruction)
    1198   ;; we used to create the pool-field here; that moved to the emit-* layer
    1199   instruction)
    1200 
    1201 ;; new, anewarray, checkcast, instanceof class-name
    1202 (define-resolver (187 189 192 193) (instruction)
    1203   ;; we used to create the pool-class here; that moved to the emit-* layer
    1204   instruction)
    1205 
    1206 ;; iinc
    1207 (define-resolver 132 (instruction)
    1208   (let* ((args (instruction-args instruction))
    1209          (register (first args))
    1210          (n (second args)))
    1211     (when (not (<= -128 n 127))
    1212       (error "IINC argument ~A out of bounds." n))
    1213     (inst 132 (list register (s1 n)))))
    1214 
    1215 (defknown resolve-instruction (t) t)
    1216 (defun resolve-instruction (instruction)
    1217   (declare (optimize speed))
    1218   (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+)))
    1219     (if resolver
    1220         (funcall resolver instruction)
    1221         instruction)))
    1222 
    1223 (defun resolve-instructions (code)
    1224   (let* ((len (length code))
    1225          (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t)))
    1226     (dotimes (index len vector)
    1227       (declare (type (unsigned-byte 16) index))
    1228       (let ((instruction (svref code index)))
    1229         (case (instruction-opcode instruction)
    1230           (205 ; CLEAR-VALUES
    1231            (let ((instructions
    1232                   (list
    1233                    (inst 'aload *thread*)
    1234                    (inst 'aconst_null)
    1235                    (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
    1236                                                    +lisp-object-array+))))))
    1237              (dolist (instruction instructions)
    1238                (vector-push-extend (resolve-instruction instruction) vector))))
    1239           (t
    1240            (vector-push-extend (resolve-instruction instruction) vector)))))))
    1241 
    1242 (declaim (ftype (function (t) t) branch-opcode-p))
    1243 (declaim (inline branch-opcode-p))
    1244 (defun branch-opcode-p (opcode)
    1245   (declare (optimize speed))
    1246   (declare (type '(integer 0 255) opcode))
    1247   (or (<= 153 opcode 168)
    1248       (= opcode 198)))
    1249916
    1250917(declaim (ftype (function (t t t) t) walk-code))
     
    1319986  (setf *code* (nreverse (coerce *code* 'vector))))
    1320987
    1321 (defun print-code ()
    1322   (dotimes (i (length *code*))
    1323     (let ((instruction (elt *code* i)))
    1324       (sys::%format t "~D ~A ~S ~S ~S~%"
    1325                     i
    1326                     (opcode-name (instruction-opcode instruction))
    1327                     (instruction-args instruction)
    1328                     (instruction-stack instruction)
    1329                     (instruction-depth instruction)))))
    1330 
    1331 (defun print-code2 (code)
    1332   (dotimes (i (length code))
    1333     (let ((instruction (elt code i)))
    1334       (case (instruction-opcode instruction)
    1335         (202 ; LABEL
    1336          (format t "~A:~%" (car (instruction-args instruction))))
    1337         (t
    1338          (format t "~8D:   ~A ~S~%"
    1339                  i
    1340                  (opcode-name (instruction-opcode instruction))
    1341                  (instruction-args instruction)))))))
    1342 
    1343 (declaim (ftype (function (t) boolean) label-p))
    1344 (defun label-p (instruction)
    1345   (and instruction
    1346        (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
    1347 
    1348 (declaim (ftype (function (t) t) instruction-label))
    1349 (defun instruction-label (instruction)
    1350   (and instruction
    1351        (= (instruction-opcode (the instruction instruction)) 202)
    1352        (car (instruction-args instruction))))
    1353988
    1354989;; Remove unused labels.
     
    15271162    (when *compiler-debug*
    15281163      (format t "----- before optimization -----~%")
    1529       (print-code))
     1164      (print-code *code*))
    15301165    (loop
    15311166      (let ((changed-p nil))
     
    15411176    (when *compiler-debug*
    15421177      (sys::%format t "----- after optimization -----~%")
    1543       (print-code)))
     1178      (print-code *code*)))
    15441179  t)
    15451180
     
    18541489    (emit 'return)
    18551490    (finalize-code)
    1856     (setf *code* (resolve-instructions *code*))
     1491    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
    18571492    (setf (method-max-stack constructor) (analyze-stack *code*))
    18581493    (setf (method-code constructor) (code-bytes *code*))
     
    81547789    (optimize-code)
    81557790
    8156     (setf *code* (resolve-instructions *code*))
     7791    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
    81577792    (setf (method-max-stack execute-method) (analyze-stack *code*))
    81587793    (setf (method-code execute-method) (code-bytes *code*))
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r12864 r12865  
    3131
    3232(in-package #:jvm)
     33
     34
     35;;    OPCODES
    3336
    3437(defconst *opcode-table* (make-array 256))
     
    255258(define-opcode goto_w 200 5 nil)
    256259(define-opcode jsr_w 201 5 nil)
    257 (define-opcode label 202 0 0)
     260(define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
    258261;; (define-opcode push-value 203 nil 1)
    259262;; (define-opcode store-value 204 nil -1)
    260 (define-opcode clear-values 205 0 0)
     263(define-opcode clear-values 205 0 0)  ;; virtual: does not exist in the JVM
    261264;;(define-opcode var-ref 206 0 0)
    262265
     
    287290  (jvm-opcode-stack-effect (svref *opcode-table* opcode-number)))
    288291
     292
     293
     294
     295;;   INSTRUCTION
     296
     297(defstruct (instruction (:constructor %make-instruction (opcode args)))
     298  (opcode 0 :type (integer 0 255))
     299  args
     300  stack
     301  depth
     302  wide)
     303
     304(defun make-instruction (opcode args)
     305  (let ((inst (apply #'%make-instruction
     306                     (list opcode
     307                           (remove :wide-prefix args)))))
     308    (when (memq :wide-prefix args)
     309      (setf (inst-wide inst) t))
     310    inst))
     311
     312(defun print-instruction (instruction)
     313  (sys::%format nil "~A ~A stack = ~S depth = ~S"
     314          (opcode-name (instruction-opcode instruction))
     315          (instruction-args instruction)
     316          (instruction-stack instruction)
     317          (instruction-depth instruction)))
     318
     319(declaim (ftype (function (t) t) instruction-label))
     320(defun instruction-label (instruction)
     321  (and instruction
     322       (= (instruction-opcode (the instruction instruction)) 202)
     323       (car (instruction-args instruction))))
     324
     325
     326
     327(defknown inst * t)
     328(defun inst (instr &optional args)
     329  (declare (optimize speed))
     330  (let ((opcode (if (fixnump instr)
     331                    instr
     332                    (opcode-number instr))))
     333    (unless (listp args)
     334      (setf args (list args)))
     335    (make-instruction opcode args)))
     336
     337
     338;; Having %emit and %%emit output their code to *code*
     339;; is currently an implementation detail exposed to all users.
     340;; We need to have APIs to address this, but for now pass2 is
     341;; our only user and we'll hard-code the use of *code*.
     342(defvar *code* nil)
     343
     344(defknown %%emit * t)
     345(defun %%emit (instr &rest args)
     346  (declare (optimize speed))
     347  (let ((instruction (make-instruction instr args)))
     348    (push instruction *code*)
     349    instruction))
     350
     351(defknown %emit * t)
     352(defun %emit (instr &rest args)
     353  (declare (optimize speed))
     354  (let ((instruction (inst instr args)))
     355    (push instruction *code*)
     356    instruction))
     357
     358(defmacro emit (instr &rest args)
     359  (when (and (consp instr)
     360             (eq (car instr) 'QUOTE)
     361             (symbolp (cadr instr)))
     362    (setf instr (opcode-number (cadr instr))))
     363  (if (fixnump instr)
     364      `(%%emit ,instr ,@args)
     365      `(%emit ,instr ,@args)))
     366
     367
     368;;  Helper routines
     369
     370(defknown label (symbol) t)
     371(defun label (symbol)
     372  (declare (type symbol symbol))
     373  (declare (optimize speed))
     374  (emit 'label symbol)
     375  (setf (symbol-value symbol) nil))
     376
     377(defknown aload (fixnum) t)
     378(defun aload (index)
     379  (case index
     380    (0 (emit 'aload_0))
     381    (1 (emit 'aload_1))
     382    (2 (emit 'aload_2))
     383    (3 (emit 'aload_3))
     384    (t (emit 'aload index))))
     385
     386(defknown astore (fixnum) t)
     387(defun astore (index)
     388  (case index
     389    (0 (emit 'astore_0))
     390    (1 (emit 'astore_1))
     391    (2 (emit 'astore_2))
     392    (3 (emit 'astore_3))
     393    (t (emit 'astore index))))
     394
     395(declaim (ftype (function (t) t) branch-opcode-p))
     396(declaim (inline branch-opcode-p))
     397(defun branch-opcode-p (opcode)
     398  (declare (optimize speed))
     399  (declare (type '(integer 0 255) opcode))
     400  (or (<= 153 opcode 168)
     401      (= opcode 198)))
     402
     403(declaim (ftype (function (t) boolean) label-p))
     404(defun label-p (instruction)
     405  (and instruction
     406       (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
     407
     408(defun print-code (code)
     409  (dotimes (i (length code))
     410    (let ((instruction (elt code i)))
     411      (sys::%format t "~D ~A ~S ~S ~S~%"
     412                    i
     413                    (opcode-name (instruction-opcode instruction))
     414                    (instruction-args instruction)
     415                    (instruction-stack instruction)
     416                    (instruction-depth instruction)))))
     417
     418(defun print-code2 (code)
     419  (dotimes (i (length code))
     420    (let ((instruction (elt code i)))
     421      (case (instruction-opcode instruction)
     422        (202 ; LABEL
     423         (format t "~A:~%" (car (instruction-args instruction))))
     424        (t
     425         (format t "~8D:   ~A ~S~%"
     426                 i
     427                 (opcode-name (instruction-opcode instruction))
     428                 (instruction-args instruction)))))))
     429
     430(defun expand-virtual-instructions (code)
     431  (let* ((len (length code))
     432         (vector (make-array (ash len 1) :fill-pointer 0 :adjustable t)))
     433    (dotimes (index len vector)
     434      (declare (type (unsigned-byte 16) index))
     435      (let ((instruction (svref code index)))
     436        (case (instruction-opcode instruction)
     437          (205 ; CLEAR-VALUES
     438           (dolist (instruction
     439                     (list
     440                      (inst 'aload *thread*)
     441                      (inst 'aconst_null)
     442                      (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
     443                                                      +lisp-object-array+)))))
     444             (vector-push-extend instruction vector)))
     445          (t
     446           (vector-push-extend instruction vector)))))))
     447
     448
     449;;   RESOLVERS
     450
     451(defun unsupported-opcode (instruction)
     452  (error "Unsupported opcode ~D." (instruction-opcode instruction)))
     453
     454(declaim (type hash-table +resolvers+))
     455(defconst +resolvers+ (make-hash-table))
     456
     457(defun initialize-resolvers ()
     458  (let ((ht +resolvers+))
     459    (dotimes (n (1+ *last-opcode*))
     460      (setf (gethash n ht) #'unsupported-opcode))
     461    ;; The following opcodes resolve to themselves.
     462    (dolist (n '(0 ; nop
     463                 1 ; aconst_null
     464                 2 ; iconst_m1
     465                 3 ; iconst_0
     466                 4 ; iconst_1
     467                 5 ; iconst_2
     468                 6 ; iconst_3
     469                 7 ; iconst_4
     470                 8 ; iconst_5
     471                 9 ; lconst_0
     472                 10 ; lconst_1
     473                 11 ; fconst_0
     474                 12 ; fconst_1
     475                 13 ; fconst_2
     476                 14 ; dconst_0
     477                 15 ; dconst_1
     478                 42 ; aload_0
     479                 43 ; aload_1
     480                 44 ; aload_2
     481                 45 ; aload_3
     482                 46 ; iaload
     483                 47 ; laload
     484                 48 ; faload
     485                 49 ; daload
     486                 50 ; aaload
     487                 75 ; astore_0
     488                 76 ; astore_1
     489                 77 ; astore_2
     490                 78 ; astore_3
     491                 79 ; iastore
     492                 80 ; lastore
     493                 81 ; fastore
     494                 82 ; dastore
     495                 83 ; aastore
     496                 87 ; pop
     497                 88 ; pop2
     498                 89 ; dup
     499                 90 ; dup_x1
     500                 91 ; dup_x2
     501                 92 ; dup2
     502                 93 ; dup2_x1
     503                 94 ; dup2_x2
     504                 95 ; swap
     505                 96 ; iadd
     506                 97 ; ladd
     507                 98 ; fadd
     508                 99 ; dadd
     509                 100 ; isub
     510                 101 ; lsub
     511                 102 ; fsub
     512                 103 ; dsub
     513                 104 ; imul
     514                 105 ; lmul
     515                 106 ; fmul
     516                 107 ; dmul
     517                 116 ; ineg
     518                 117 ; lneg
     519                 118 ; fneg
     520                 119 ; dneg
     521                 120 ; ishl
     522                 121 ; lshl
     523                 122 ; ishr
     524                 123 ; lshr
     525                 126 ; iand
     526                 127 ; land
     527                 128 ; ior
     528                 129 ; lor
     529                 130 ; ixor
     530                 131 ; lxor
     531                 133 ; i2l
     532                 134 ; i2f
     533                 135 ; i2d
     534                 136 ; l2i
     535                 137 ; l2f
     536                 138 ; l2d
     537                 141 ; f2d
     538                 144 ; d2f
     539                 148 ; lcmp
     540                 149 ; fcmpd
     541                 150 ; fcmpg
     542                 151 ; dcmpd
     543                 152 ; dcmpg
     544                 153 ; ifeq
     545                 154 ; ifne
     546                 155 ; ifge
     547                 156 ; ifgt
     548                 157 ; ifgt
     549                 158 ; ifle
     550                 159 ; if_icmpeq
     551                 160 ; if_icmpne
     552                 161 ; if_icmplt
     553                 162 ; if_icmpge
     554                 163 ; if_icmpgt
     555                 164 ; if_icmple
     556                 165 ; if_acmpeq
     557                 166 ; if_acmpne
     558                 167 ; goto
     559                 176 ; areturn
     560                 177 ; return
     561                 178 ; getstatic
     562                 179 ; putstatic
     563                 180 ; getfield
     564                 181 ; putfield
     565                 182 ; invokevirtual
     566                 183 ; invockespecial
     567                 184 ; invokestatic
     568                 187 ; new
     569                 189 ; anewarray
     570                 190 ; arraylength
     571                 191 ; athrow
     572                 192 ; checkcast
     573                 193 ; instanceof
     574                 194 ; monitorenter
     575                 195 ; monitorexit
     576                 198 ; ifnull
     577                 202 ; label
     578                 ))
     579      (setf (gethash n ht) nil))))
     580
     581(initialize-resolvers)
     582
     583(defmacro define-resolver (opcodes args &body body)
     584  (let ((name (gensym)))
     585    `(progn
     586       (defun ,name ,args ,@body)
     587       (eval-when (:load-toplevel :execute)
     588         ,(if (listp opcodes)
     589              `(dolist (op ',opcodes)
     590                 (setf (gethash op +resolvers+)
     591                       (symbol-function ',name)))
     592              `(setf (gethash ,opcodes +resolvers+)
     593                     (symbol-function ',name)))))))
     594
     595(defun load/store-resolver (instruction inst-index inst-index2 error-text)
     596 (let* ((args (instruction-args instruction))
     597        (index (car args)))
     598   (declare (type (unsigned-byte 16) index))
     599   (cond ((<= 0 index 3)
     600          (inst (+ index inst-index)))
     601         ((<= 0 index 255)
     602          (inst inst-index2 index))
     603         (t
     604          (error error-text)))))
     605
     606;; aload
     607(define-resolver 25 (instruction)
     608  (load/store-resolver instruction 42 25 "ALOAD unsupported case"))
     609
     610;; astore
     611(define-resolver 58 (instruction)
     612  (load/store-resolver instruction 75 58 "ASTORE unsupported case"))
     613
     614;; iload
     615(define-resolver 21 (instruction)
     616  (load/store-resolver instruction 26 21 "ILOAD unsupported case"))
     617
     618;; istore
     619(define-resolver 54 (instruction)
     620  (load/store-resolver instruction 59 54 "ISTORE unsupported case"))
     621
     622;; lload
     623(define-resolver 22 (instruction)
     624  (load/store-resolver instruction 30 22 "LLOAD unsupported case"))
     625
     626;; lstore
     627(define-resolver 55 (instruction)
     628  (load/store-resolver instruction 63 55 "LSTORE unsupported case"))
     629
     630;; bipush, sipush
     631(define-resolver (16 17) (instruction)
     632  (let* ((args (instruction-args instruction))
     633         (n (first args)))
     634    (declare (type fixnum n))
     635    (cond ((<= 0 n 5)
     636           (inst (+ n 3)))
     637          ((<= -128 n 127)
     638           (inst 16 (logand n #xff))) ; BIPUSH
     639          (t ; SIPUSH
     640           (inst 17 (s2 n))))))
     641
     642;; ldc
     643(define-resolver 18 (instruction)
     644  (let* ((args (instruction-args instruction)))
     645    (unless (= (length args) 1)
     646      (error "Wrong number of args for LDC."))
     647    (if (> (car args) 255)
     648        (inst 19 (u2 (car args))) ; LDC_W
     649        (inst 18 args))))
     650
     651;; ldc2_w
     652(define-resolver 20 (instruction)
     653  (let* ((args (instruction-args instruction)))
     654    (unless (= (length args) 1)
     655      (error "Wrong number of args for LDC2_W."))
     656    (inst 20 (u2 (car args)))))
     657
     658;; iinc
     659(define-resolver 132 (instruction)
     660  (let* ((args (instruction-args instruction))
     661         (register (first args))
     662         (n (second args)))
     663    (when (not (<= -128 n 127))
     664      (error "IINC argument ~A out of bounds." n))
     665    (inst 132 (list register (s1 n)))))
     666
     667(defknown resolve-instruction (t) t)
     668(defun resolve-instruction (instruction)
     669  (declare (optimize speed))
     670  (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+)))
     671    (if resolver
     672        (funcall resolver instruction)
     673        instruction)))
     674
     675(defun resolve-instructions (code)
     676  (let* ((len (length code))
     677         (vector (make-array len :fill-pointer 0 :adjustable t)))
     678    (dotimes (index len vector)
     679      (declare (type (unsigned-byte 16) index))
     680      (let ((instruction (aref code index)))
     681        (vector-push-extend (resolve-instruction instruction) vector)))))
     682
    289683(provide '#:opcodes)
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp

    r12864 r12865  
    197197(defvar *this-class* nil)
    198198
    199 (defvar *code* ())
    200 
    201199;; All tags visible at the current point of compilation, some of which may not
    202200;; be in the current compiland.
Note: See TracChangeset for help on using the changeset viewer.