Changeset 12871 for branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Timestamp:

08/07/10 11:53:23 (13 years ago)

Author:

ehuelsmann

Message:

Eliminate optimize-2: Partially, it duplicated DELETE-UNREACHABLE-CODE.
The other part moves to OPTIMIZE-3.

File:

• branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (4 diffs)

branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -919 +919 @@
 
 
-
-(defun optimize-2 ()
-  (let* ((code (coerce *code* 'vector))
-         (length (length code))
-         (changed nil))
-    (declare (type (unsigned-byte 16) length))
-    ;; Since we're looking at this instruction and the next one, we can stop
-    ;; one before the end.
-    (dotimes (i (1- length))
-      (declare (type (unsigned-byte 16) i))
-      (let ((instruction (aref code i)))
-        (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
-          (do* ((j (1+ i) (1+ j))
-                (next-instruction (aref code j) (aref code j)))
-               ((>= j length))
-            (declare (type (unsigned-byte 16) j))
-            (when next-instruction
-              (cond ((= (instruction-opcode next-instruction) 167) ; GOTO
-                     (cond ((= j (1+ i))
-                            ;; Two GOTOs in a row: the second instruction is
-                            ;; unreachable.
-                            (setf (aref code j) nil)
-                            (setf changed t))
-                           ((eq (car (instruction-args next-instruction))
-                                (car (instruction-args instruction)))
-                            ;; We've reached another GOTO to the same destination.
-                            ;; We don't need the first GOTO; we can just fall
-                            ;; through to the second one.
-                            (setf (aref code i) nil)
-                            (setf changed t)))
-                     (return))
-                    ((= (instruction-opcode next-instruction) 202) ; LABEL
-                     (when (eq (car (instruction-args instruction))
-                               (car (instruction-args next-instruction)))
-                       ;; GOTO next instruction; we don't need this one.
-                       (setf (aref code i) nil)
-                       (setf changed t)
-                       (return)))
-                    (t
-                     ;; Not a GOTO or a label.
-                     (return))))))))
-    (when changed
-      (setf *code* (delete nil code))
-      t)))
-
 ;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
 ;; GETSTATIC POP => nothing
@@ -972 +927 @@
       (declare (type (unsigned-byte 16) i))
       (let* ((this-instruction (aref code i))
-             (this-opcode (and this-instruction (instruction-opcode this-instruction)))
+             (this-opcode (and this-instruction
+                               (instruction-opcode this-instruction)))
              (next-instruction (aref code (1+ i)))
-             (next-opcode (and next-instruction (instruction-opcode next-instruction))))
+             (next-opcode (and next-instruction
+                               (instruction-opcode next-instruction))))
         (case this-opcode
           (205 ; CLEAR-VALUES
@@ -984 +941 @@
              (setf (aref code i) nil)
              (setf (aref code (1+ i)) nil)
+             (setf changed t)))
+          (167 ; GOTO
+           (when (and (eql next-opcode 202)  ; LABEL
+                      (eq (car (instruction-args this-instruction))
+                          (car (instruction-args next-instruction))))
+             (setf (aref code i) nil)
+             ;;(setf (aref code (1+ i)) nil)
              (setf changed t))))))
     (when changed
@@ -1008 +972 @@
                                  (mapcar #'handler-to *handlers*)
                                  (mapcar #'handler-code *handlers*))))
-        (setf changed-p (or (optimize-2) changed-p))
         (if changed-p
             (setf *code* (optimize-jumps *code*))