[armedbear-cvs] r12869 - branches/generic-class-file/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Aug  7 04:39:49 2010
New Revision: 12869

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

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Aug  7 04:39:49 2010
@@ -918,36 +918,6 @@
   (setf *code* (nreverse (coerce *code* 'vector))))
 
 
-;; Remove unused labels.
-(defun optimize-1 ()
-  (let ((code (coerce *code* 'vector))
-        (changed nil)
-        (marker (gensym)))
-    ;; Mark the labels that are actually branched to.
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (branch-p (instruction-opcode instruction))
-          (let ((label (car (instruction-args instruction))))
-            (set label marker)))))
-    ;; Add labels used for exception handlers.
-    (dolist (handler *handlers*)
-      (set (handler-from handler) marker)
-      (set (handler-to handler) marker)
-      (set (handler-code handler) marker))
-    ;; Remove labels that are not used as branch targets.
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (= (instruction-opcode instruction) 202) ; LABEL
-          (let ((label (car (instruction-args instruction))))
-            (declare (type symbol label))
-            (unless (eq (symbol-value label) marker)
-              (setf (aref code i) nil)
-              (setf changed t))))))
-    (when changed
-      (setf *code* (delete nil code))
-      t)))
 
 (defun optimize-2 ()
   (let* ((code (coerce *code* 'vector))
@@ -1072,7 +1042,13 @@
       (print-code *code*))
     (loop
       (let ((changed-p nil))
-        (setf changed-p (or (optimize-1) changed-p))
+        (multiple-value-setq
+            (*code* changed-p)
+          (delete-unused-labels *code*
+                                (append
+                                 (mapcar #'handler-from *handlers*)
+                                 (mapcar #'handler-to *handlers*)
+                                 (mapcar #'handler-code *handlers*))))
         (setf changed-p (or (optimize-2) changed-p))
         (setf changed-p (or (optimize-2b) changed-p))
         (setf changed-p (or (optimize-3) changed-p))
@@ -1090,48 +1066,6 @@
       (print-code *code*)))
   t)
 
-(defun code-bytes (code)
-  (let ((length 0)
-        labels ;; alist
-        )
-    (declare (type (unsigned-byte 16) length))
-    ;; Pass 1: calculate label offsets and overall length.
-    (dotimes (i (length code))
-      (declare (type (unsigned-byte 16) i))
-      (let* ((instruction (aref code i))
-             (opcode (instruction-opcode instruction)))
-        (if (= opcode 202) ; LABEL
-            (let ((label (car (instruction-args instruction))))
-              (set label length)
-              (setf labels
-                    (acons label length labels)))
-            (incf length (opcode-size opcode)))))
-    ;; Pass 2: replace labels with calculated offsets.
-    (let ((index 0))
-      (declare (type (unsigned-byte 16) index))
-      (dotimes (i (length code))
-        (declare (type (unsigned-byte 16) i))
-        (let ((instruction (aref code i)))
-          (when (branch-p (instruction-opcode instruction))
-            (let* ((label (car (instruction-args instruction)))
-                   (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
-              (setf (instruction-args instruction) (s2 offset))))
-          (unless (= (instruction-opcode instruction) 202) ; LABEL
-            (incf index (opcode-size (instruction-opcode instruction)))))))
-    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
-    (let ((bytes (make-array length))
-          (index 0))
-      (declare (type (unsigned-byte 16) index))
-      (dotimes (i (length code))
-        (declare (type (unsigned-byte 16) i))
-        (let ((instruction (aref code i)))
-          (unless (= (instruction-opcode instruction) 202) ; LABEL
-            (setf (svref bytes index) (instruction-opcode instruction))
-            (incf index)
-            (dolist (byte (instruction-args instruction))
-              (setf (svref bytes index) byte)
-              (incf index)))))
-      (values bytes labels))))
 
 (declaim (inline write-u1))
 (defun write-u1 (n stream)

Modified: branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	(original)
+++ branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp	Sat Aug  7 04:39:49 2010
@@ -769,6 +769,34 @@
             (setf max-stack (max max-stack (the fixnum instruction-depth))))))
       max-stack)))
 
+
+(defun delete-unused-labels (code handler-labels)
+  (let ((code (coerce code 'vector))
+        (changed nil)
+        (marker (gensym)))
+    ;; Mark the labels that are actually branched to.
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let ((instruction (aref code i)))
+        (when (branch-p (instruction-opcode instruction))
+          (let ((label (car (instruction-args instruction))))
+            (set label marker)))))
+    ;; Add labels used for exception handlers.
+    (dolist (label handler-labels)
+      (set label marker))
+    ;; Remove labels that are not used as branch targets.
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let ((instruction (aref code i)))
+        (when (= (instruction-opcode instruction) 202) ; LABEL
+          (let ((label (car (instruction-args instruction))))
+            (declare (type symbol label))
+            (unless (eq (symbol-value label) marker)
+              (setf (aref code i) nil)
+              (setf changed t))))))
+    (values (if changed (delete nil code) code)
+            changed)))
+
 (defun delete-unreachable-code (code)
   ;; Look for unreachable code after GOTO.
   (let* ((code (coerce code 'vector))
@@ -790,6 +818,50 @@
     (values (if changed (delete nil code) code)
             changed)))
 
+(defun code-bytes (code)
+  (let ((length 0)
+        labels ;; alist
+        )
+    (declare (type (unsigned-byte 16) length))
+    ;; Pass 1: calculate label offsets and overall length.
+    (dotimes (i (length code))
+      (declare (type (unsigned-byte 16) i))
+      (let* ((instruction (aref code i))
+             (opcode (instruction-opcode instruction)))
+        (if (= opcode 202) ; LABEL
+            (let ((label (car (instruction-args instruction))))
+              (set label length)
+              (setf labels
+                    (acons label length labels)))
+            (incf length (opcode-size opcode)))))
+    ;; Pass 2: replace labels with calculated offsets.
+    (let ((index 0))
+      (declare (type (unsigned-byte 16) index))
+      (dotimes (i (length code))
+        (declare (type (unsigned-byte 16) i))
+        (let ((instruction (aref code i)))
+          (when (branch-p (instruction-opcode instruction))
+            (let* ((label (car (instruction-args instruction)))
+                   (offset (- (the (unsigned-byte 16)
+                                (symbol-value (the symbol label)))
+                              index)))
+              (setf (instruction-args instruction) (s2 offset))))
+          (unless (= (instruction-opcode instruction) 202) ; LABEL
+            (incf index (opcode-size (instruction-opcode instruction)))))))
+    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
+    (let ((bytes (make-array length))
+          (index 0))
+      (declare (type (unsigned-byte 16) index))
+      (dotimes (i (length code))
+        (declare (type (unsigned-byte 16) i))
+        (let ((instruction (aref code i)))
+          (unless (= (instruction-opcode instruction) 202) ; LABEL
+            (setf (svref bytes index) (instruction-opcode instruction))
+            (incf index)
+            (dolist (byte (instruction-args instruction))
+              (setf (svref bytes index) byte)
+              (incf index)))))
+      (values bytes labels))))