Changeset 12980


Ignore:
Timestamp:
10/18/10 18:03:40 (11 years ago)
Author:
astalla
Message:

[invokedynamic branch] Save current state of affairs before revolutionizing it.

Location:
branches/invokedynamic/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r12953 r12980  
    848848  name
    849849  descriptor
    850   attributes)
     850  attributes
     851  initial-locals)
    851852
    852853
     
    903904  "Prepares `method' for serialization."
    904905  (let ((pool (class-file-constants class)))
    905     (setf (method-access-flags method)
     906    (setf (method-initial-locals method)
     907    (compute-initial-method-locals class method)
     908    (method-access-flags method)
    906909          (map-flags (method-access-flags method))
    907910          (method-descriptor method)
     
    909912          (method-name method)
    910913          (constant-index (pool-add-utf8 pool (method-name method)))))
    911   (finalize-attributes (method-attributes method) nil class))
     914    (finalize-attributes (method-attributes method) method class))
    912915
    913916
     
    10021005                            (mapcar #'exception-end-pc handlers)
    10031006                            (mapcar #'exception-handler-pc handlers))
    1004                      t)))
     1007                     t))
     1008   (compute-stack-map-table-p (>= (class-file-major-version class) 50)))
    10051009    (unless (code-max-stack code)
    10061010      (setf (code-max-stack code)
     
    10091013      (setf (code-max-locals code)
    10101014            (analyze-locals code)))
    1011     (when (>= (class-file-major-version class) 50)
    1012       (code-add-attribute code (compute-stack-map-table class parent)))
    10131015    (multiple-value-bind
    1014           (c labels)
    1015         (code-bytes c)
     1016          (c labels stack-map-table)
     1017        (resolve-code c class parent compute-stack-map-table-p)
    10161018      (setf (code-code code) c
    1017             (code-labels code) labels)))
     1019            (code-labels code) labels)
     1020      (when compute-stack-map-table-p
     1021  #+todo (code-add-attribute code stack-map-table))))
    10181022
    10191023  (setf (code-exception-handlers code)
     
    10881092                        :catch-type type)
    10891093        (code-exception-handlers code)))
     1094
     1095(defun resolve-code (code class method compute-stack-map-table-p)
     1096  "Walks the code, replacing symbolic labels with numeric offsets, and optionally computing the stack map table."
     1097  (declare (ignore class))
     1098  (let* ((length 0)
     1099   labels ;; alist
     1100   stack-map-table
     1101   (*basic-block* (when compute-stack-map-table-p
     1102        (make-basic-block
     1103         :offset 0
     1104         :input-locals
     1105         (method-initial-locals method))))
     1106   (root-block *basic-block*)
     1107   *basic-blocks*)
     1108    (declare (type (unsigned-byte 16) length))
     1109    ;; Pass 1: calculate label offsets and overall length.
     1110    (dotimes (i (length code))
     1111      (declare (type (unsigned-byte 16) i))
     1112      (let* ((instruction (aref code i))
     1113             (opcode (instruction-opcode instruction)))
     1114        (if (= opcode 202) ; LABEL
     1115            (let ((label (car (instruction-args instruction))))
     1116              (set label length)
     1117              (setf labels
     1118                    (acons label length labels))
     1119        (incf length (opcode-size opcode))))))
     1120    ;; Pass 2: replace labels with calculated offsets.
     1121    (let ((index 0))
     1122      (declare (type (unsigned-byte 16) index))
     1123      (dotimes (i (length code))
     1124        (declare (type (unsigned-byte 16) i))
     1125        (let ((instruction (aref code i)))
     1126          (when (branch-p (instruction-opcode instruction))
     1127            (let* ((label (car (instruction-args instruction)))
     1128                   (offset (- (the (unsigned-byte 16)
     1129                                (symbol-value (the symbol label)))
     1130                              index)))
     1131              (setf (instruction-args instruction) (s2 offset))))
     1132    (when compute-stack-map-table-p
     1133      (funcall (opcode-effect-function opcode)
     1134         instruction index))
     1135          (unless (= (instruction-opcode instruction) 202) ; LABEL
     1136            (incf index (opcode-size (instruction-opcode instruction)))))))
     1137    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
     1138    (let ((bytes (make-array length))
     1139          (index 0))
     1140      (declare (type (unsigned-byte 16) index))
     1141      (dotimes (i (length code))
     1142        (declare (type (unsigned-byte 16) i))
     1143        (let ((instruction (aref code i)))
     1144          (unless (= (instruction-opcode instruction) 202) ; LABEL
     1145            (setf (svref bytes index) (instruction-opcode instruction))
     1146            (incf index)
     1147            (dolist (arg (instruction-args instruction))
     1148              (setf (svref bytes index)
     1149        (if (constant-p arg) (constant-index arg) arg))
     1150              (incf index)))))
     1151      (values bytes labels stack-map-table))))
     1152
     1153(defun ends-basic-block-p (opcode)
     1154  (or (branch-p opcode)
     1155      (>= 172 opcode 177))) ;;return variants
    10901156
    10911157(defstruct exception
     
    12981364  entries)
    12991365
     1366(defun add-stack-map-frame (stack-map-table instruction-offset locals
     1367          stack-items)
     1368  (error "TODO!"))
     1369
    13001370(defun finalize-stack-map-table-attribute (table parent class)
    1301   "Prepares the `stack-map-table' attribute for serialization, within method `parent'."
     1371  "Prepares the `stack-map-table' attribute for serialization, within method `parent': replaces all virtual types in the stack map frames with variable-info objects."
    13021372  (declare (ignore parent class)) ;;TODO
    13031373  table)
     
    13571427
    13581428(defconst *opcode-effect-table*
    1359   (make-array 256 :initial-element #'(lambda (a b) (declare (ignore b)) a)))
     1429  (make-array 256 :initial-element #'(lambda (&rest args) (car args))))
    13601430
    13611431(defun opcode-effect-function (opcode)
    13621432  (svref *opcode-effect-table* opcode))
    13631433
    1364 (defvar *computed-stack* nil "The list of types on the stack calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.")
    1365 
    1366 (defvar *computed-locals* nil "The list of types of local variables calculated from the last emitted instruction, or from the method signature if no instruction has been emitted yet for the current method.")
     1434(defstruct basic-block label offset input-locals input-stack output-locals output-stack successors)
     1435
     1436(defun basic-block-add-successor (basic-block successor)
     1437  (push successor (basic-block-successors basic-block)))
     1438
     1439(defvar *basic-block*)
     1440(defvar *basic-blocks* nil "An alist that associates labels with corresponding basic blocks")
     1441
     1442(defun label-basic-block (label)
     1443  (or (cdr (assoc label *basic-blocks*))
     1444      (setf (assoc label *basic-blocks*)
     1445      (make-basic-block :label label
     1446            :offset (symbol-value label)))))
    13671447
    13681448(defmacro define-opcode-effect (opcode &body body)
    13691449  `(setf (svref *opcode-effect-table*
    13701450    (opcode-number ',opcode))
    1371    #'(lambda (instruction)
    1372        (declare (ignorable instruction))
    1373        ,@body)))
    1374 
    1375 (defun update-stack-map-effect! (*computed-stack* *computed-locals* instruction)
    1376   (funcall (opcode-effect-function (instruction-opcode instruction))
    1377      instruction)
    1378   (setf (instruction-stack-map-locals instruction) *computed-locals*)
    1379   (setf (instruction-stack-map-stack instruction) *computed-stack*)
    1380   instruction)
    1381 
    1382 (defun compute-stack-map-table (class method)
    1383   (let ((table (make-stack-map-table-attribute))
    1384   (*computed-stack* (compute-initial-method-stack class method))
    1385   (*computed-locals*))
    1386     (finalize-stack-map-table table)))
    1387 
    1388 (defun finalize-stack-map-table (table)
    1389   "Replaces all virtual types in the stack map frames with variable-info objects."
    1390   ;;TODO
    1391   table)
    1392 
    1393 (defun compute-initial-method-stack (class method)
     1451   (if (and (symbolp (car body)) (null (cdr body)))
     1452       `(function ,(car body))
     1453       #'(lambda (instruction offset)
     1454     (declare (ignorable instruction offset))
     1455     ,@body))))
     1456
     1457(defun compute-initial-method-locals (class method)
    13941458  (let (locals)
    13951459    (unless (member :static (method-access-flags method))
     
    13981462    (push :uninitialized-this locals)
    13991463    ;;the method is an instance method.
    1400     (push (class-name class) locals)))
     1464    (push (class-file-class class) locals)))
    14011465    (dolist (x (cdr (method-descriptor method)))
    14021466      (push x locals))
    1403     locals))
     1467    (nreverse locals)))
    14041468
    14051469(defun smf-type->variable-info (type)
    14061470  (case type))
    14071471
     1472(defun smf-get (pos)
     1473  (or (nth pos (basic-block-output-locals *basic-block*))
     1474      (error "Locals inconsistency: get ~A but locals are ~A"
     1475       pos (length (basic-block-output-locals *basic-block*)))))
     1476
     1477(defun smf-set (pos type)
     1478  (if (< pos (length (basic-block-output-locals *basic-block*)))
     1479      (setf (nth pos (basic-block-output-locals *basic-block*)) type)
     1480      (progn
     1481  (setf (basic-block-output-locals *basic-block*)
     1482        (append (basic-block-output-locals *basic-block*) (list nil)))
     1483  (smf-set pos type))))
     1484
    14081485(defun smf-push (type)
    1409   (push type *computed-stack*))
    1410 
    1411 (defun smf-push2 (type)
    1412   (smf-push type)
    1413   (smf-push :top))
     1486  (push type (basic-block-output-stack *basic-block*))
     1487  (when (or (eq type :long) (eq type :double))
     1488    (push :top (basic-block-output-stack *basic-block*))))
    14141489
    14151490(defun smf-pop ()
    1416   (pop *computed-stack*))
     1491  (pop (basic-block-output-stack *basic-block*)))
    14171492
    14181493(defun smf-popn (n)
    14191494  (dotimes (i n)
    1420     (pop *computed-stack*)))
     1495    (pop (basic-block-output-stack *basic-block*))))
    14211496
    14221497(defun smf-element-of (type)
    1423   (if (consp type)
     1498  (if (and (consp type) (eq (car type) :array-of))
    14241499      (cdr type)
    1425       (error "Not an array stack map type: ~S" type)))
     1500      (cons :element-of type)))
    14261501
    14271502(defun smf-array-of (type)
    1428   (cons :array-of type))
     1503  (if (and (consp type) (eq (car type) :element-of))
     1504      (cdr type)
     1505      (cons :array-of type)))
    14291506
    14301507(define-opcode-effect aconst_null (smf-push :null))
     
    14361513(define-opcode-effect iconst_4 (smf-push :int))
    14371514(define-opcode-effect iconst_5 (smf-push :int))
    1438 (define-opcode-effect lconst_0 (smf-push2 :long))
    1439 (define-opcode-effect lconst_1 (smf-push2 :long))
     1515(define-opcode-effect lconst_0 (smf-push :long))
     1516(define-opcode-effect lconst_1 (smf-push :long))
    14401517(define-opcode-effect fconst_0 (smf-push :float))
    14411518(define-opcode-effect fconst_1 (smf-push :float))
    14421519(define-opcode-effect fconst_2 (smf-push :float))
    1443 (define-opcode-effect dconst_0 (smf-push2 :double))
    1444 (define-opcode-effect dconst_1 (smf-push2 :double))
     1520(define-opcode-effect dconst_0 (smf-push :double))
     1521(define-opcode-effect dconst_1 (smf-push :double))
    14451522(define-opcode-effect bipush (smf-push :int))
    14461523(define-opcode-effect sipush (smf-push :int))
    1447 (define-opcode-effect ldc
    1448     (case (constant-type (car (instruction-args instruction)))
    1449       (:int (smf-push :int))
    1450       (:long (smf-push2 :long))
    1451       (:float (smf-push :float))
    1452       (:double (smf-push2 :double))
    1453       (t (smf-push (car (instruction-args instruction))))))
     1524(define-opcode-effect ldc (smf-push (car (instruction-args instruction))))
    14541525(define-opcode-effect iload (smf-push :int))
    1455 (define-opcode-effect lload (smf-push2 :long))
     1526(define-opcode-effect lload (smf-push :long))
    14561527(define-opcode-effect fload (smf-push :float))
    1457 (define-opcode-effect dload (smf-push2 :double))
    1458 #|(define-opcode aload 25 2 1) ;;TODO
    1459 (define-opcode iload_0 26 1 1)
    1460 (define-opcode iload_1 27 1 1)
    1461 (define-opcode iload_2 28 1 1)
    1462 (define-opcode iload_3 29 1 1)
    1463 (define-opcode lload_0 30 1 2)
    1464 (define-opcode lload_1 31 1 2)
    1465 (define-opcode lload_2 32 1 2)
    1466 (define-opcode lload_3 33 1 2)
    1467 (define-opcode fload_0 34 1 nil)
    1468 (define-opcode fload_1 35 1 nil)
    1469 (define-opcode fload_2 36 1 nil)
    1470 (define-opcode fload_3 37 1 nil)
    1471 (define-opcode dload_0 38 1 nil)
    1472 (define-opcode dload_1 39 1 nil)
    1473 (define-opcode dload_2 40 1 nil)
    1474 (define-opcode dload_3 41 1 nil)
    1475 (define-opcode aload_0 42 1 1)
    1476 (define-opcode aload_1 43 1 1)
    1477 (define-opcode aload_2 44 1 1)
    1478 (define-opcode aload_3 45 1 1)|#
     1528(define-opcode-effect dload (smf-push :double))
     1529(define-opcode-effect aload
     1530    (smf-push (smf-get (car (instruction-args instruction)))))
     1531(define-opcode-effect iload_0 (smf-push :int))
     1532(define-opcode-effect iload_1 (smf-push :int))
     1533(define-opcode-effect iload_2 (smf-push :int))
     1534(define-opcode-effect iload_3 (smf-push :int))
     1535(define-opcode-effect lload_0 (smf-push :long))
     1536(define-opcode-effect lload_1 (smf-push :long))
     1537(define-opcode-effect lload_2 (smf-push :long))
     1538(define-opcode-effect lload_3 (smf-push :long))
     1539(define-opcode-effect fload_0 (smf-push :float))
     1540(define-opcode-effect fload_1 (smf-push :float))
     1541(define-opcode-effect fload_2 (smf-push :float))
     1542(define-opcode-effect fload_3 (smf-push :float))
     1543(define-opcode-effect dload_0 (smf-push :double))
     1544(define-opcode-effect dload_1 (smf-push :double))
     1545(define-opcode-effect dload_2 (smf-push :double))
     1546(define-opcode-effect dload_3 (smf-push :double))
     1547#|(define-opcode-effect aload_0 42 1 1)
     1548(define-opcode-effect aload_1 43 1 1)
     1549(define-opcode-effect aload_2 44 1 1)
     1550(define-opcode-effect aload_3 45 1 1)|#
    14791551(define-opcode-effect iaload (smf-popn 2) (smf-push :int))
    1480 (define-opcode-effect laload (smf-popn 2) (smf-push2 :long))
     1552(define-opcode-effect laload (smf-popn 2) (smf-push :long))
    14811553(define-opcode-effect faload (smf-popn 2) (smf-push :float))
    1482 (define-opcode-effect daload (smf-popn 2) (smf-push2 :double))
     1554(define-opcode-effect daload (smf-popn 2) (smf-push :double))
    14831555#+nil ;;until there's newarray
    14841556(define-opcode-effect aaload
     
    14891561(define-opcode-effect caload (smf-popn 2) (smf-push :int))
    14901562(define-opcode-effect saload (smf-popn 2) (smf-push :int))
    1491 #|(define-opcode istore 54 2 -1)
    1492 (define-opcode lstore 55 2 -2)
    1493 (define-opcode fstore 56 2 nil)
    1494 (define-opcode dstore 57 2 nil)
    1495 (define-opcode astore 58 2 -1)
    1496 (define-opcode istore_0 59 1 -1)
     1563
     1564(defun iaf-store-effect (instruction offset)
     1565  (declare (ignore offset))
     1566  (let ((t1 (smf-pop))
     1567    (arg (car (instruction-args instruction))))
     1568      (smf-set arg t1)
     1569      (when (> arg 0)
     1570  (let ((t2 (smf-get (1- arg))))
     1571    (when (or (eq t2 :long) (eq t2 :double))
     1572      (smf-set (1- arg) :top))))))
     1573
     1574(defun ld-store-effect (instruction offset)
     1575  (declare (ignore offset))
     1576  (smf-pop)
     1577  (let ((t1 (smf-pop))
     1578    (arg (car (instruction-args instruction))))
     1579      (smf-set arg t1)
     1580      (smf-set (1+ arg) :top)
     1581      (when (> arg 0)
     1582  (let ((t2 (smf-get (1- arg))))
     1583    (when (or (eq t2 :long) (eq t2 :double))
     1584      (smf-set (1- arg) :top))))))
     1585
     1586(define-opcode-effect istore iaf-store-effect)
     1587(define-opcode-effect lstore ld-store-effect)
     1588(define-opcode-effect fstore iaf-store-effect)
     1589(define-opcode-effect dstore ld-store-effect)
     1590(define-opcode-effect astore iaf-store-effect)
     1591#|(define-opcode istore_0 59 1 -1)
    14971592(define-opcode istore_1 60 1 -1)
    14981593(define-opcode istore_2 61 1 -1)
     
    15101605(define-opcode dstore_2 73 1 nil)
    15111606(define-opcode dstore_3 74 1 nil)
    1512 (define-opcode astore_0 75 1 -1)
    1513 (define-opcode astore_1 76 1 -1)
     1607(define-opcode astore_0 75 1 -1)|#
     1608;;TODO
     1609#|(define-opcode astore_1 76 1 -1)
    15141610(define-opcode astore_2 77 1 -1)
    15151611(define-opcode astore_3 78 1 -1)
  • branches/invokedynamic/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r12953 r12980  
    944944  code)
    945945
    946 
    947 
    948 
    949 (defun code-bytes (code)
    950   (let ((length 0)
    951         labels ;; alist
    952         )
    953     (declare (type (unsigned-byte 16) length))
    954     ;; Pass 1: calculate label offsets and overall length.
    955     (dotimes (i (length code))
    956       (declare (type (unsigned-byte 16) i))
    957       (let* ((instruction (aref code i))
    958              (opcode (instruction-opcode instruction)))
    959         (if (= opcode 202) ; LABEL
    960             (let ((label (car (instruction-args instruction))))
    961               (set label length)
    962               (setf labels
    963                     (acons label length labels)))
    964             (incf length (opcode-size opcode)))))
    965     ;; Pass 2: replace labels with calculated offsets.
    966     (let ((index 0))
    967       (declare (type (unsigned-byte 16) index))
    968       (dotimes (i (length code))
    969         (declare (type (unsigned-byte 16) i))
    970         (let ((instruction (aref code i)))
    971           (when (branch-p (instruction-opcode instruction))
    972             (let* ((label (car (instruction-args instruction)))
    973                    (offset (- (the (unsigned-byte 16)
    974                                 (symbol-value (the symbol label)))
    975                               index)))
    976               (setf (instruction-args instruction) (s2 offset))))
    977           (unless (= (instruction-opcode instruction) 202) ; LABEL
    978             (incf index (opcode-size (instruction-opcode instruction)))))))
    979     ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
    980     (let ((bytes (make-array length))
    981           (index 0))
    982       (declare (type (unsigned-byte 16) index))
    983       (dotimes (i (length code))
    984         (declare (type (unsigned-byte 16) i))
    985         (let ((instruction (aref code i)))
    986           (unless (= (instruction-opcode instruction) 202) ; LABEL
    987             (setf (svref bytes index) (instruction-opcode instruction))
    988             (incf index)
    989             (dolist (arg (instruction-args instruction))
    990               (setf (svref bytes index)
    991         (if (constant-p arg) (constant-index arg) arg))
    992               (incf index)))))
    993       (values bytes labels))))
    994 
    995946(defun finalize-code (code handler-labels optimize)
    996947  (setf code (coerce (nreverse code) 'vector))
     
    999950  (resolve-instructions (expand-virtual-instructions code)))
    1000951
     952;;Opcode effects on locals & stack - for computing the stack map table
     953
    1001954(provide '#:opcodes)
Note: See TracChangeset for help on using the changeset viewer.