Changeset 12865
- Timestamp:
- 08/06/10 20:59:50 (13 years ago)
- Location:
- branches/generic-class-file/abcl/src/org/armedbear/lisp
- Files:
-
- 3 edited
-
compiler-pass2.lisp (modified) (7 diffs)
-
jvm-instructions.lisp (modified) (3 diffs)
-
jvm.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12864 r12865 213 213 start end handler type))) 214 214 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 292 216 293 217 (defknown emit-push-nil () t) … … 990 914 (check-number-of-args form n t)) 991 915 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 ; nop1004 1 ; aconst_null1005 2 ; iconst_m11006 3 ; iconst_01007 4 ; iconst_11008 5 ; iconst_21009 6 ; iconst_31010 7 ; iconst_41011 8 ; iconst_51012 9 ; lconst_01013 10 ; lconst_11014 11 ; fconst_01015 12 ; fconst_11016 13 ; fconst_21017 14 ; dconst_01018 15 ; dconst_11019 42 ; aload_01020 43 ; aload_11021 44 ; aload_21022 45 ; aload_31023 46 ; iaload1024 47 ; laload1025 48 ; faload1026 49 ; daload1027 50 ; aaload1028 75 ; astore_01029 76 ; astore_11030 77 ; astore_21031 78 ; astore_31032 79 ; iastore1033 80 ; lastore1034 81 ; fastore1035 82 ; dastore1036 83 ; aastore1037 87 ; pop1038 88 ; pop21039 89 ; dup1040 90 ; dup_x11041 91 ; dup_x21042 92 ; dup21043 93 ; dup2_x11044 94 ; dup2_x21045 95 ; swap1046 96 ; iadd1047 97 ; ladd1048 98 ; fadd1049 99 ; dadd1050 100 ; isub1051 101 ; lsub1052 102 ; fsub1053 103 ; dsub1054 104 ; imul1055 105 ; lmul1056 106 ; fmul1057 107 ; dmul1058 116 ; ineg1059 117 ; lneg1060 118 ; fneg1061 119 ; dneg1062 120 ; ishl1063 121 ; lshl1064 122 ; ishr1065 123 ; lshr1066 126 ; iand1067 127 ; land1068 128 ; ior1069 129 ; lor1070 130 ; ixor1071 131 ; lxor1072 133 ; i2l1073 134 ; i2f1074 135 ; i2d1075 136 ; l2i1076 137 ; l2f1077 138 ; l2d1078 141 ; f2d1079 144 ; d2f1080 148 ; lcmp1081 149 ; fcmpd1082 150 ; fcmpg1083 151 ; dcmpd1084 152 ; dcmpg1085 153 ; ifeq1086 154 ; ifne1087 155 ; ifge1088 156 ; ifgt1089 157 ; ifgt1090 158 ; ifle1091 159 ; if_icmpeq1092 160 ; if_icmpne1093 161 ; if_icmplt1094 162 ; if_icmpge1095 163 ; if_icmpgt1096 164 ; if_icmple1097 165 ; if_acmpeq1098 166 ; if_acmpne1099 167 ; goto1100 176 ; areturn1101 177 ; return1102 190 ; arraylength1103 191 ; athrow1104 194 ; monitorenter1105 195 ; monitorexit1106 198 ; ifnull1107 202 ; label1108 ))1109 (setf (gethash n ht) nil))))1110 1111 (initialize-resolvers)1112 1113 (defmacro define-resolver (opcodes args &body body)1114 (let ((name (gensym)))1115 `(progn1116 (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 (t1132 (error error-text)))))1133 1134 ;; aload1135 (define-resolver 25 (instruction)1136 (load/store-resolver instruction 42 25 "ALOAD unsupported case"))1137 1138 ;; astore1139 (define-resolver 58 (instruction)1140 (load/store-resolver instruction 75 58 "ASTORE unsupported case"))1141 1142 ;; iload1143 (define-resolver 21 (instruction)1144 (load/store-resolver instruction 26 21 "ILOAD unsupported case"))1145 1146 ;; istore1147 (define-resolver 54 (instruction)1148 (load/store-resolver instruction 59 54 "ISTORE unsupported case"))1149 1150 ;; lload1151 (define-resolver 22 (instruction)1152 (load/store-resolver instruction 30 22 "LLOAD unsupported case"))1153 1154 ;; lstore1155 (define-resolver 55 (instruction)1156 (load/store-resolver instruction 63 55 "LSTORE unsupported case"))1157 1158 ;; getstatic, putstatic1159 (define-resolver (178 179) (instruction)1160 ;; we used to create the pool-field here; that moved to the emit-* layer1161 instruction)1162 1163 ;; bipush, sipush1164 (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))) ; BIPUSH1172 (t ; SIPUSH1173 (inst 17 (s2 n))))))1174 1175 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor1176 (define-resolver (182 183 184) (instruction)1177 ;; we used to create the pool-method here; that moved to the emit-* layer1178 instruction)1179 1180 ;; ldc1181 (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_W1187 (inst 18 args))))1188 1189 ;; ldc2_w1190 (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-name1197 (define-resolver (180 181) (instruction)1198 ;; we used to create the pool-field here; that moved to the emit-* layer1199 instruction)1200 1201 ;; new, anewarray, checkcast, instanceof class-name1202 (define-resolver (187 189 192 193) (instruction)1203 ;; we used to create the pool-class here; that moved to the emit-* layer1204 instruction)1205 1206 ;; iinc1207 (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 resolver1220 (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-VALUES1231 (let ((instructions1232 (list1233 (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 (t1240 (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)))1249 916 1250 917 (declaim (ftype (function (t t t) t) walk-code)) … … 1319 986 (setf *code* (nreverse (coerce *code* 'vector)))) 1320 987 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 i1326 (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 ; LABEL1336 (format t "~A:~%" (car (instruction-args instruction))))1337 (t1338 (format t "~8D: ~A ~S~%"1339 i1340 (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 instruction1346 (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))1347 1348 (declaim (ftype (function (t) t) instruction-label))1349 (defun instruction-label (instruction)1350 (and instruction1351 (= (instruction-opcode (the instruction instruction)) 202)1352 (car (instruction-args instruction))))1353 988 1354 989 ;; Remove unused labels. … … 1527 1162 (when *compiler-debug* 1528 1163 (format t "----- before optimization -----~%") 1529 (print-code ))1164 (print-code *code*)) 1530 1165 (loop 1531 1166 (let ((changed-p nil)) … … 1541 1176 (when *compiler-debug* 1542 1177 (sys::%format t "----- after optimization -----~%") 1543 (print-code )))1178 (print-code *code*))) 1544 1179 t) 1545 1180 … … 1854 1489 (emit 'return) 1855 1490 (finalize-code) 1856 (setf *code* (resolve-instructions *code*))1491 (setf *code* (resolve-instructions (expand-virtual-instructions *code*))) 1857 1492 (setf (method-max-stack constructor) (analyze-stack *code*)) 1858 1493 (setf (method-code constructor) (code-bytes *code*)) … … 8154 7789 (optimize-code) 8155 7790 8156 (setf *code* (resolve-instructions *code*))7791 (setf *code* (resolve-instructions (expand-virtual-instructions *code*))) 8157 7792 (setf (method-max-stack execute-method) (analyze-stack *code*)) 8158 7793 (setf (method-code execute-method) (code-bytes *code*)) -
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
r12864 r12865 31 31 32 32 (in-package #:jvm) 33 34 35 ;; OPCODES 33 36 34 37 (defconst *opcode-table* (make-array 256)) … … 255 258 (define-opcode goto_w 200 5 nil) 256 259 (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 258 261 ;; (define-opcode push-value 203 nil 1) 259 262 ;; (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 261 264 ;;(define-opcode var-ref 206 0 0) 262 265 … … 287 290 (jvm-opcode-stack-effect (svref *opcode-table* opcode-number))) 288 291 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 289 683 (provide '#:opcodes) -
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm.lisp
r12864 r12865 197 197 (defvar *this-class* nil) 198 198 199 (defvar *code* ())200 201 199 ;; All tags visible at the current point of compilation, some of which may not 202 200 ;; be in the current compiland.
Note: See TracChangeset
for help on using the changeset viewer.
