Ignore:
Timestamp:
08/06/10 20:59:50 (13 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.

File:
1 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*))
Note: See TracChangeset for help on using the changeset viewer.