Changeset 12894

Timestamp:

08/13/10 20:25:20 (13 years ago)

Author:

ehuelsmann

Message:

Generate the execute() methods through the new generator.

Changed:

• CLEAR-VALUES instruction now takes the thread-register as its argument, to disconnect code-finalization from the scope of the *THREAD* binding.

Clean up:

• JAVA-METHOD (structure)
• HANDLER (structure)
• WRITE-METHOD (function)
• MAKE-METHOD (function)
• WRITE-CODE-ATTR (function)
• WRITE-EXCEPTION-TABLE (function)
• remove code-finalization from P2-COMPILAND

Location:

branches/generic-class-file/abcl/src/org/armedbear/lisp

Files:

• compiler-pass2.lisp (modified) (12 diffs)
• jvm-instructions.lisp (modified) (1 diff)
• jvm.lisp (modified) (1 diff)

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

@@ -81 +81 @@
 
 (defun add-exception-handler (start end handler type)
-  (if (null *current-code-attribute*)
-      (push (make-handler :from start
-                          :to end
-                          :code handler
-                          :catch-type (if (null type)
-                                          0
-                                          (pool-class type)))
-            *handlers*)
-      (code-add-exception-handler *current-code-attribute*
-                                  start end handler type)))
+  (code-add-exception-handler *current-code-attribute*
+                              start end handler type))
 
 
@@ -636 +628 @@
   (declare (optimize speed (safety 0)))
   (ensure-thread-var-initialized)
-  (emit 'clear-values))
+  (emit 'clear-values *thread*))
 
 (defknown maybe-emit-clear-values (&rest t) t)
@@ -644 +636 @@
     (unless (single-valued-p form)
       (ensure-thread-var-initialized)
-      (emit 'clear-values)
+      (emit 'clear-values *thread*)
       (return))))
 
@@ -777 +769 @@
 
 
-
-
-(defstruct (java-method (:include method)
-                        (:conc-name method-)
-                        (:constructor %make-method))
-  name-index
-  descriptor-index
-  max-stack
-  max-locals
-  code
-  handlers)
-
-(defun make-method (&rest args &key descriptor name
-                                    descriptor-index name-index
-                               &allow-other-keys)
-  (apply #'%make-method
-         (list* :descriptor-index (or descriptor-index (pool-name descriptor))
-                :name-index (or name-index (pool-name name))
-                args)))
 
 (defun emit-constructor-lambda-name (lambda-name)
@@ -934 +907 @@
     method))
 
-(defun write-exception-table (method stream)
-  (let ((handlers (method-handlers method)))
-    (write-u2 (length handlers) stream) ; number of entries
-    (dolist (handler handlers)
-      (write-u2 (symbol-value (handler-from handler)) stream)
-      (write-u2 (symbol-value (handler-to handler)) stream)
-      (write-u2 (symbol-value (handler-code handler)) stream)
-      (write-u2 (handler-catch-type handler) stream))))
 
 (defun write-source-file-attr (source-file stream)
@@ -962 +927 @@
     (write-u2 *source-line-number* stream)))
 
-(defun write-code-attr (method stream)
-  (declare (optimize speed))
-  (declare (type stream stream))
-  (let* ((name-index (pool-name "Code"))
-         (code (method-code method))
-         (code-length (length code))
-         (line-number-available-p (and (fixnump *source-line-number*)
-                                       (plusp *source-line-number*)))
-         (length (+ code-length 12
-                    (* (length (method-handlers method)) 8)
-                    (if line-number-available-p 12 0)))
-         (max-stack (or (method-max-stack method) 20))
-         (max-locals (or (method-max-locals method) 1)))
-    (write-u2 name-index stream)
-    (write-u4 length stream)
-    (write-u2 max-stack stream)
-    (write-u2 max-locals stream)
-    (write-u4 code-length stream)
-    (dotimes (i code-length)
-      (declare (type index i))
-      (write-u1 (the (unsigned-byte 8) (svref code i)) stream))
-    (write-exception-table method stream)
-    (cond (line-number-available-p
-           ; attributes count
-           (write-u2 1 stream)
-           (write-line-number-table stream))
-          (t
-           ; attributes count
-           (write-u2 0 stream)))))
-
-(defun write-method (method stream)
-  (declare (optimize speed))
-  (write-u2 (or (method-access-flags method) #x1) stream) ; access flags
-  (write-u2 (method-name-index method) stream)
-  (write-u2 (method-descriptor-index method) stream)
-  (write-u2 1 stream) ; attributes count
-  (write-code-attr method stream))
 
 
@@ -6891 +6819 @@
                                         (abcl-class-file-lambda-list class-file))))
     (pool-name "Code") ; Must be in pool!
+    (class-add-method class-file constructor)
 
     (when *file-compilation*
@@ -6900 +6829 @@
     (dolist (field (class-file-fields class-file))
       (finalize-field field class-file))
-    (finalize-method constructor class-file)
+    (dolist (method (class-file-methods class-file))
+      (finalize-method method class-file))
 
     (write-u4 #xCAFEBABE stream)
@@ -6918 +6848 @@
       (write-field field stream))
     ;; methods count
-    (write-u2 (1+ (length (abcl-class-file-methods class-file))) stream)
+    (write-u2 (length (abcl-class-file-methods class-file)) stream)
     ;; methods
     (dolist (method (abcl-class-file-methods class-file))
-      (write-method method stream))
-    (!write-method constructor stream)
+      (!write-method method stream))
     ;; attributes count
     (cond (*file-compilation*
@@ -6997 +6926 @@
 
          (arg-types (analyze-args compiland))
-         (execute-method (make-method :name "execute"
-                                      :descriptor (apply #'descriptor
-                                                         +lisp-object+
-                                                         arg-types)))
+         (method (!make-method "execute" +lisp-object+ arg-types
+                               :flags '(:final :public)))
+         (code (method-add-code method))
+         (*current-code-attribute* code)
          (*code* ())
          (*register* 1) ;; register 0: "this" pointer
          (*registers-allocated* 1)
-         (*handlers* ())
          (*visible-variables* *visible-variables*)
 
@@ -7010 +6938 @@
          (*initialize-thread-var* nil)
          (label-START (gensym)))
+
+    (class-add-method class-file method)
 
     (dolist (var (compiland-arg-vars compiland))
@@ -7192 +7122 @@
 
     (setf (abcl-class-file-lambda-list class-file) args)
-    (setf (method-max-locals execute-method) *registers-allocated*)
-    (push execute-method (abcl-class-file-methods class-file))
-
-
-    ;;;  Move here
-    (setf *code* (finalize-code *code*
-                                (nconc (mapcar #'handler-from *handlers*)
-                                       (mapcar #'handler-to *handlers*)
-                                       (mapcar #'handler-code *handlers*)) t))
-
-    (setf (method-max-stack execute-method)
-          (analyze-stack *code* (mapcar #'handler-code *handlers*)))
-    (setf (method-code execute-method) (code-bytes *code*))
-
-    ;; Remove handler if its protected range is empty.
-    (setf *handlers*
-          (delete-if (lambda (handler)
-                       (eql (symbol-value (handler-from handler))
-                            (symbol-value (handler-to handler))))
-                     *handlers*))
-    ;;; to here
-    ;;; To a separate function which is part of class file finalization
-    ;;;  when we have a section of class-file-generation centered code
-
-
-    (setf (method-handlers execute-method) (nreverse *handlers*)))
+    (setf (code-max-locals code) *registers-allocated*)
+    (setf (code-code code) *code*))
+
   t)
 

branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

@@ -448 +448 @@
            (dolist (instruction
                      (list
-                      (inst 'aload *thread*)
+                      (inst 'aload (car (instruction-args instruction)))
                       (inst 'aconst_null)
                       (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"

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

@@ -230 +230 @@
 (defvar *registers-allocated* 0)
 
-(defvar *handlers* ())
-
-(defstruct handler
-  from       ;; label indicating the start of the protected block
-  to         ;; label indicating the end of the protected block
-  code       ;; label to jump to if the specified exception occurs
-  catch-type ;; pool index of the class name of the exception, or 0 (zero)
-             ;; for 'all'
-  )
-
 ;; Variables visible at the current point of compilation.
 (defvar *visible-variables* nil