Changeset 12869
- Timestamp:
- 08/07/10 08:39:49 (13 years ago)
- 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 919 919 920 920 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) ; LABEL943 (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 changed949 (setf *code* (delete nil code))950 t)))951 921 952 922 (defun optimize-2 () … … 1073 1043 (loop 1074 1044 (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*)))) 1076 1052 (setf changed-p (or (optimize-2) changed-p)) 1077 1053 (setf changed-p (or (optimize-2b) changed-p)) … … 1091 1067 t) 1092 1068 1093 (defun code-bytes (code)1094 (let ((length 0)1095 labels ;; alist1096 )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) ; LABEL1104 (let ((label (car (instruction-args instruction))))1105 (set label length)1106 (setf labels1107 (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) ; LABEL1120 (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) ; LABEL1129 (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))))1135 1069 1136 1070 (declaim (inline write-u1)) -
branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
r12868 r12869 770 770 max-stack))) 771 771 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 772 800 (defun delete-unreachable-code (code) 773 801 ;; Look for unreachable code after GOTO. … … 791 819 changed))) 792 820 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)))) 793 865 794 866
Note: See TracChangeset
for help on using the changeset viewer.