[armedbear-cvs] r12836 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Jul 31 08:24:51 2010
New Revision: 12836

Log:
Move emit-invoke* functions closer together, making them a section.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jul 31 08:24:51 2010
@@ -494,9 +494,52 @@
   (let* ((info (get-descriptor-info arg-types return-type))
          (descriptor (car info))
          (stack-effect (cdr info))
-         (instruction (emit 'invokestatic class-name method-name descriptor)))
+         (index (pool-method class-name method-name descriptor))
+         (instruction (apply #'%emit 'invokestatic (u2 index))))
     (setf (instruction-stack instruction) stack-effect)))
 
+
+
+(declaim (ftype (function t string) pretty-java-class))
+(defun pretty-java-class (class)
+  (cond ((equal class +lisp-object-class+)
+         "LispObject")
+        ((equal class +lisp-symbol+)
+         "Symbol")
+        ((equal class +lisp-thread-class+)
+         "LispThread")
+        (t
+         class)))
+
+(defknown emit-invokevirtual (t t t t) t)
+(defun emit-invokevirtual (class-name method-name arg-types return-type)
+  (let* ((info (get-descriptor-info arg-types return-type))
+         (descriptor (car info))
+         (stack-effect (cdr info))
+         (index (pool-method class-name method-name descriptor))
+         (instruction (apply #'%emit 'invokevirtual (u2 index))))
+    (declare (type (signed-byte 8) stack-effect))
+    (let ((explain *explain*))
+      (when (and explain (memq :java-calls explain))
+        (unless (string= method-name "execute")
+          (format t ";   call to ~A ~A.~A(~{~A~^,~})~%"
+                  (pretty-java-type return-type)
+                  (pretty-java-class class-name)
+                  method-name
+                  (mapcar 'pretty-java-type arg-types)))))
+    (setf (instruction-stack instruction) (1- stack-effect))))
+
+(defknown emit-invokespecial-init (string list) t)
+(defun emit-invokespecial-init (class-name arg-types)
+  (let* ((info (get-descriptor-info arg-types nil))
+         (descriptor (car info))
+         (stack-effect (cdr info))
+         (index (pool-method class-name "<init>" descriptor))
+         (instruction (apply #'%emit 'invokespecial (u2 index))))
+    (declare (type (signed-byte 8) stack-effect))
+    (setf (instruction-stack instruction) (1- stack-effect))))
+
+
 (defknown pretty-java-type (t) string)
 (defun pretty-java-type (type)
   (let ((arrayp nil)
@@ -660,44 +703,6 @@
         (return-from common-representation result)))))
 
 
-
-(declaim (ftype (function t string) pretty-java-class))
-(defun pretty-java-class (class)
-  (cond ((equal class +lisp-object-class+)
-         "LispObject")
-        ((equal class +lisp-symbol+)
-         "Symbol")
-        ((equal class +lisp-thread-class+)
-         "LispThread")
-        (t
-         class)))
-
-(defknown emit-invokevirtual (t t t t) t)
-(defun emit-invokevirtual (class-name method-name arg-types return-type)
-  (let* ((info (get-descriptor-info arg-types return-type))
-         (descriptor (car info))
-         (stack-effect (cdr info))
-         (instruction (emit 'invokevirtual class-name method-name descriptor)))
-    (declare (type (signed-byte 8) stack-effect))
-    (let ((explain *explain*))
-      (when (and explain (memq :java-calls explain))
-        (unless (string= method-name "execute")
-          (format t ";   call to ~A ~A.~A(~{~A~^,~})~%"
-                  (pretty-java-type return-type)
-                  (pretty-java-class class-name)
-                  method-name
-                  (mapcar 'pretty-java-type arg-types)))))
-    (setf (instruction-stack instruction) (1- stack-effect))))
-
-(defknown emit-invokespecial-init (string list) t)
-(defun emit-invokespecial-init (class-name arg-types)
-  (let* ((info (get-descriptor-info arg-types nil))
-         (descriptor (car info))
-         (stack-effect (cdr info))
-         (instruction (emit 'invokespecial class-name "<init>" descriptor)))
-    (declare (type (signed-byte 8) stack-effect))
-    (setf (instruction-stack instruction) (1- stack-effect))))
-
 ;; Index of local variable used to hold the current thread.
 (defvar *thread* nil)
 
@@ -1209,10 +1214,8 @@
 
 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
 (define-resolver (182 183 184) (instruction)
-  (let* ((args (instruction-args instruction))
-         (index (pool-method (first args) (second args) (third args))))
-    (setf (instruction-args instruction) (u2 index))
-    instruction))
+  ;; we used to create the pool-method here; that moved to the emit-* layer
+  instruction)
 
 ;; ldc
 (define-resolver 18 (instruction)