Changeset 12869


Ignore:
Timestamp:
08/07/10 08:39:49 (11 years ago)
Author:
ehuelsmann
Message:

Move CODE-BYTES and OPTIMIZE-1 (renamed to DELETE-UNUSED-LABELS)
to jvm-instructions.lisp.

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

Legend:

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

    r12868 r12869  
    919919
    920920
    921 ;; Remove unused labels.
    922 (defun optimize-1 ()
    923   (let ((code (coerce *code* 'vector))
    924         (changed nil)
    925         (marker (gensym)))
    926     ;; Mark the labels that are actually branched to.
    927     (dotimes (i (length code))
    928       (declare (type (unsigned-byte 16) i))
    929       (let ((instruction (aref code i)))
    930         (when (branch-p (instruction-opcode instruction))
    931           (let ((label (car (instruction-args instruction))))
    932             (set label marker)))))
    933     ;; Add labels used for exception handlers.
    934     (dolist (handler *handlers*)
    935       (set (handler-from handler) marker)
    936       (set (handler-to handler) marker)
    937       (set (handler-code handler) marker))
    938     ;; Remove labels that are not used as branch targets.
    939     (dotimes (i (length code))
    940       (declare (type (unsigned-byte 16) i))
    941       (let ((instruction (aref code i)))
    942         (when (= (instruction-opcode instruction) 202) ; LABEL
    943           (let ((label (car (instruction-args instruction))))
    944             (declare (type symbol label))
    945             (unless (eq (symbol-value label) marker)
    946               (setf (aref code i) nil)
    947               (setf changed t))))))
    948     (when changed
    949       (setf *code* (delete nil code))
    950       t)))
    951921
    952922(defun optimize-2 ()
     
    10731043    (loop
    10741044      (let ((changed-p nil))
    1075         (setf changed-p (or (optimize-1) changed-p))
     1045        (multiple-value-setq
     1046            (*code* changed-p)
     1047          (delete-unused-labels *code*
     1048                                (append
     1049                                 (mapcar #'handler-from *handlers*)
     1050                                 (mapcar #'handler-to *handlers*)
     1051                                 (mapcar #'handler-code *handlers*))))
    10761052        (setf changed-p (or (optimize-2) changed-p))
    10771053        (setf changed-p (or (optimize-2b) changed-p))
     
    10911067  t)
    10921068
    1093 (defun code-bytes (code)
    1094   (let ((length 0)
    1095         labels ;; alist
    1096         )
    1097     (declare (type (unsigned-byte 16) length))
    1098     ;; Pass 1: calculate label offsets and overall length.
    1099     (dotimes (i (length code))
    1100       (declare (type (unsigned-byte 16) i))
    1101       (let* ((instruction (aref code i))
    1102              (opcode (instruction-opcode instruction)))
    1103         (if (= opcode 202) ; LABEL
    1104             (let ((label (car (instruction-args instruction))))
    1105               (set label length)
    1106               (setf labels
    1107                     (acons label length labels)))
    1108             (incf length (opcode-size opcode)))))
    1109     ;; Pass 2: replace labels with calculated offsets.
    1110     (let ((index 0))
    1111       (declare (type (unsigned-byte 16) index))
    1112       (dotimes (i (length code))
    1113         (declare (type (unsigned-byte 16) i))
    1114         (let ((instruction (aref code i)))
    1115           (when (branch-p (instruction-opcode instruction))
    1116             (let* ((label (car (instruction-args instruction)))
    1117                    (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
    1118               (setf (instruction-args instruction) (s2 offset))))
    1119           (unless (= (instruction-opcode instruction) 202) ; LABEL
    1120             (incf index (opcode-size (instruction-opcode instruction)))))))
    1121     ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
    1122     (let ((bytes (make-array length))
    1123           (index 0))
    1124       (declare (type (unsigned-byte 16) index))
    1125       (dotimes (i (length code))
    1126         (declare (type (unsigned-byte 16) i))
    1127         (let ((instruction (aref code i)))
    1128           (unless (= (instruction-opcode instruction) 202) ; LABEL
    1129             (setf (svref bytes index) (instruction-opcode instruction))
    1130             (incf index)
    1131             (dolist (byte (instruction-args instruction))
    1132               (setf (svref bytes index) byte)
    1133               (incf index)))))
    1134       (values bytes labels))))
    11351069
    11361070(declaim (inline write-u1))
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r12868 r12869  
    770770      max-stack)))
    771771
     772
     773(defun delete-unused-labels (code handler-labels)
     774  (let ((code (coerce code 'vector))
     775        (changed nil)
     776        (marker (gensym)))
     777    ;; Mark the labels that are actually branched to.
     778    (dotimes (i (length code))
     779      (declare (type (unsigned-byte 16) i))
     780      (let ((instruction (aref code i)))
     781        (when (branch-p (instruction-opcode instruction))
     782          (let ((label (car (instruction-args instruction))))
     783            (set label marker)))))
     784    ;; Add labels used for exception handlers.
     785    (dolist (label handler-labels)
     786      (set label marker))
     787    ;; Remove labels that are not used as branch targets.
     788    (dotimes (i (length code))
     789      (declare (type (unsigned-byte 16) i))
     790      (let ((instruction (aref code i)))
     791        (when (= (instruction-opcode instruction) 202) ; LABEL
     792          (let ((label (car (instruction-args instruction))))
     793            (declare (type symbol label))
     794            (unless (eq (symbol-value label) marker)
     795              (setf (aref code i) nil)
     796              (setf changed t))))))
     797    (values (if changed (delete nil code) code)
     798            changed)))
     799
    772800(defun delete-unreachable-code (code)
    773801  ;; Look for unreachable code after GOTO.
     
    791819            changed)))
    792820
     821(defun code-bytes (code)
     822  (let ((length 0)
     823        labels ;; alist
     824        )
     825    (declare (type (unsigned-byte 16) length))
     826    ;; Pass 1: calculate label offsets and overall length.
     827    (dotimes (i (length code))
     828      (declare (type (unsigned-byte 16) i))
     829      (let* ((instruction (aref code i))
     830             (opcode (instruction-opcode instruction)))
     831        (if (= opcode 202) ; LABEL
     832            (let ((label (car (instruction-args instruction))))
     833              (set label length)
     834              (setf labels
     835                    (acons label length labels)))
     836            (incf length (opcode-size opcode)))))
     837    ;; Pass 2: replace labels with calculated offsets.
     838    (let ((index 0))
     839      (declare (type (unsigned-byte 16) index))
     840      (dotimes (i (length code))
     841        (declare (type (unsigned-byte 16) i))
     842        (let ((instruction (aref code i)))
     843          (when (branch-p (instruction-opcode instruction))
     844            (let* ((label (car (instruction-args instruction)))
     845                   (offset (- (the (unsigned-byte 16)
     846                                (symbol-value (the symbol label)))
     847                              index)))
     848              (setf (instruction-args instruction) (s2 offset))))
     849          (unless (= (instruction-opcode instruction) 202) ; LABEL
     850            (incf index (opcode-size (instruction-opcode instruction)))))))
     851    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
     852    (let ((bytes (make-array length))
     853          (index 0))
     854      (declare (type (unsigned-byte 16) index))
     855      (dotimes (i (length code))
     856        (declare (type (unsigned-byte 16) i))
     857        (let ((instruction (aref code i)))
     858          (unless (= (instruction-opcode instruction) 202) ; LABEL
     859            (setf (svref bytes index) (instruction-opcode instruction))
     860            (incf index)
     861            (dolist (byte (instruction-args instruction))
     862              (setf (svref bytes index) byte)
     863              (incf index)))))
     864      (values bytes labels))))
    793865
    794866
Note: See TracChangeset for help on using the changeset viewer.