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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun Aug  8 06:06:35 2010
New Revision: 12876

Log:
Move FINALIZE-CODE to jvm-instructions.lisp and make it
really finalize all code.

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	Sun Aug  8 06:06:35 2010
@@ -914,9 +914,6 @@
   (check-number-of-args form n t))
 
 
-(defun finalize-code ()
-  (setf *code* (nreverse (coerce *code* 'vector))))
-
 
 
 
@@ -1186,8 +1183,11 @@
            (aver nil)))
     (setf *code* (append *static-code* *code*))
     (emit 'return)
-    (finalize-code)
-    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
+    (setf *code*
+          (finalize-code *code* (nconc (mapcar #'handler-from *handlers*)
+                                       (mapcar #'handler-to *handlers*)
+                                       (mapcar #'handler-code *handlers*)) nil))
+
     (setf (method-max-stack constructor)
           (analyze-stack *code* (mapcar #'handler-code *handlers*)))
     (setf (method-code constructor) (code-bytes *code*))
@@ -7485,10 +7485,11 @@
 
 
     ;;;  Move here
-    (finalize-code)
-    (optimize-code)
+    (setf *code* (finalize-code *code*
+                                (nconc (mapcar #'handler-from *handlers*)
+                                       (mapcar #'handler-to *handlers*)
+                                       (mapcar #'handler-code *handlers*)) t))
 
-    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
     (setf (method-max-stack execute-method)
           (analyze-stack *code* (mapcar #'handler-code *handlers*)))
     (setf (method-code execute-method) (code-bytes *code*))

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	Sun Aug  8 06:06:35 2010
@@ -819,7 +819,7 @@
             changed)))
 
 
-(declaim (ftype (function (t) hash-table) hash-labels))
+(declaim (ftype (function (t) label-target-instructions) hash-labels))
 (defun label-target-instructions (code)
   (let ((ht (make-hash-table :test 'eq))
         (code (coerce code 'vector))
@@ -908,46 +908,42 @@
 
 (defvar *enable-optimization* t)
 
-(defknown optimize-code () t)
-(defun optimize-code ()
+(defknown optimize-code (t t) t)
+(defun optimize-code (code handler-labels)
   (unless *enable-optimization*
     (format t "optimizations are disabled~%"))
   (when *enable-optimization*
     (when *compiler-debug*
       (format t "----- before optimization -----~%")
-      (print-code *code*))
+      (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)))
+       (let ((changed-p nil))
+         (multiple-value-setq
+             (code changed-p)
+           (delete-unused-labels code handler-labels))
+         (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)
+      (print-code code)))
+  code)
 
 
 
@@ -997,6 +993,10 @@
               (incf index)))))
       (values bytes labels))))
 
-
+(defun finalize-code (code handler-labels optimize)
+  (setf code (coerce (nreverse code) 'vector))
+  (when optimize
+    (setf code (optimize-code code handler-labels)))
+  (resolve-instructions (expand-virtual-instructions code)))
 
 (provide '#:opcodes)