[armedbear-cvs] r12875 - branches/generic-class-file/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Aug 7 21:14:08 UTC 2010
Author: ehuelsmann
Date: Sat Aug 7 17:14:06 2010
New Revision: 12875
Log:
Move OPTIMIZE-INSTRUCTION-SEQUENCES and OPTIMIZE-CODE
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 17:14:06 2010
@@ -918,92 +918,6 @@
(setf *code* (nreverse (coerce *code* 'vector))))
-(defun optimize-instruction-sequences (code)
- (let* ((code (coerce code 'vector))
- (changed nil))
- (dotimes (i (1- (length code)))
- (declare (type (unsigned-byte 16) i))
- (let* ((this-instruction (aref code i))
- (this-opcode (and this-instruction
- (instruction-opcode this-instruction)))
- (labels-skipped-p nil)
- (next-instruction (do ((j (1+ i) (1+ j)))
- ((or (>= j (length code))
- (/= 202 ; LABEL
- (instruction-opcode (aref code j))))
- (when (< j (length code))
- (aref code j)))
- (setf labels-skipped-p t)))
- (next-opcode (and next-instruction
- (instruction-opcode next-instruction))))
- (case this-opcode
- (205 ; CLEAR-VALUES
- (when (eql next-opcode 205) ; CLEAR-VALUES
- (setf (aref code i) nil)
- (setf changed t)))
- (178 ; GETSTATIC
- (when (and (eql next-opcode 87) ; POP
- (not labels-skipped-p))
- (setf (aref code i) nil)
- (setf (aref code (1+ i)) nil)
- (setf changed t)))
- (176 ; ARETURN
- (when (eql next-opcode 176) ; ARETURN
- (setf (aref code i) nil)
- (setf changed t)))
- ((200 167) ; GOTO GOTO_W
- (when (and (or (eql next-opcode 202) ; LABEL
- (eql next-opcode 200) ; GOTO_W
- (eql next-opcode 167)) ; GOTO
- (eq (car (instruction-args this-instruction))
- (car (instruction-args next-instruction))))
- (setf (aref code i) nil)
- (setf changed t))))))
- (values (if changed (delete nil code) code)
- changed)))
-
-(defvar *enable-optimization* t)
-
-(defknown optimize-code () t)
-(defun optimize-code ()
- (unless *enable-optimization*
- (format t "optimizations are disabled~%"))
- (when *enable-optimization*
- (when *compiler-debug*
- (format t "----- before optimization -----~%")
- (print-code *code*))
- (loop
- (let ((changed-p nil))
- (multiple-value-setq
- (*code* changed-p)
- (delete-unused-labels *code*
- (nconc
- (mapcar #'handler-from *handlers*)
- (mapcar #'handler-to *handlers*)
- (mapcar #'handler-code *handlers*))))
- (if changed-p
- (setf *code* (optimize-instruction-sequences *code*))
- (multiple-value-setq
- (*code* changed-p)
- (optimize-instruction-sequences *code*)))
- (if changed-p
- (setf *code* (optimize-jumps *code*))
- (multiple-value-setq
- (*code* changed-p)
- (optimize-jumps *code*)))
- (if changed-p
- (setf *code* (delete-unreachable-code *code*))
- (multiple-value-setq
- (*code* changed-p)
- (delete-unreachable-code *code*)))
- (unless changed-p
- (return))))
- (unless (vectorp *code*)
- (setf *code* (coerce *code* 'vector)))
- (when *compiler-debug*
- (sys::%format t "----- after optimization -----~%")
- (print-code *code*)))
- t)
(declaim (inline write-u1))
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 17:14:06 2010
@@ -861,6 +861,97 @@
changed t)))))))))
(values code changed)))
+
+(defun optimize-instruction-sequences (code)
+ (let* ((code (coerce code 'vector))
+ (changed nil))
+ (dotimes (i (1- (length code)))
+ (declare (type (unsigned-byte 16) i))
+ (let* ((this-instruction (aref code i))
+ (this-opcode (and this-instruction
+ (instruction-opcode this-instruction)))
+ (labels-skipped-p nil)
+ (next-instruction (do ((j (1+ i) (1+ j)))
+ ((or (>= j (length code))
+ (/= 202 ; LABEL
+ (instruction-opcode (aref code j))))
+ (when (< j (length code))
+ (aref code j)))
+ (setf labels-skipped-p t)))
+ (next-opcode (and next-instruction
+ (instruction-opcode next-instruction))))
+ (case this-opcode
+ (205 ; CLEAR-VALUES
+ (when (eql next-opcode 205) ; CLEAR-VALUES
+ (setf (aref code i) nil)
+ (setf changed t)))
+ (178 ; GETSTATIC
+ (when (and (eql next-opcode 87) ; POP
+ (not labels-skipped-p))
+ (setf (aref code i) nil)
+ (setf (aref code (1+ i)) nil)
+ (setf changed t)))
+ (176 ; ARETURN
+ (when (eql next-opcode 176) ; ARETURN
+ (setf (aref code i) nil)
+ (setf changed t)))
+ ((200 167) ; GOTO GOTO_W
+ (when (and (or (eql next-opcode 202) ; LABEL
+ (eql next-opcode 200) ; GOTO_W
+ (eql next-opcode 167)) ; GOTO
+ (eq (car (instruction-args this-instruction))
+ (car (instruction-args next-instruction))))
+ (setf (aref code i) nil)
+ (setf changed t))))))
+ (values (if changed (delete nil code) code)
+ changed)))
+
+(defvar *enable-optimization* t)
+
+(defknown optimize-code () t)
+(defun optimize-code ()
+ (unless *enable-optimization*
+ (format t "optimizations are disabled~%"))
+ (when *enable-optimization*
+ (when *compiler-debug*
+ (format t "----- before optimization -----~%")
+ (print-code *code*))
+ (loop
+ (let ((changed-p nil))
+ (multiple-value-setq
+ (*code* changed-p)
+ (delete-unused-labels *code*
+ (nconc
+ (mapcar #'handler-from *handlers*)
+ (mapcar #'handler-to *handlers*)
+ (mapcar #'handler-code *handlers*))))
+ (if changed-p
+ (setf *code* (optimize-instruction-sequences *code*))
+ (multiple-value-setq
+ (*code* changed-p)
+ (optimize-instruction-sequences *code*)))
+ (if changed-p
+ (setf *code* (optimize-jumps *code*))
+ (multiple-value-setq
+ (*code* changed-p)
+ (optimize-jumps *code*)))
+ (if changed-p
+ (setf *code* (delete-unreachable-code *code*))
+ (multiple-value-setq
+ (*code* changed-p)
+ (delete-unreachable-code *code*)))
+ (unless changed-p
+ (return))))
+ (unless (vectorp *code*)
+ (setf *code* (coerce *code* 'vector)))
+ (when *compiler-debug*
+ (sys::%format t "----- after optimization -----~%")
+ (print-code *code*)))
+ t)
+
+
+
+
(defun code-bytes (code)
(let ((length 0)
labels ;; alist
More information about the armedbear-cvs
mailing list