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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Jul 31 14:24:34 2010
New Revision: 12838

Log:
Backport r12834-12836, resolving merge conflicts along the way.

Modified:
   branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.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 Jul 31 14:24:34 2010
@@ -442,22 +442,6 @@
 
 (defparameter *descriptors* (make-hash-table :test #'equal))
 
-;; Just an experiment...
-(defmacro defsubst (name lambda-list &rest body)
-  (let* ((block-name (fdefinition-block-name name))
-         (expansion (generate-inline-expansion block-name lambda-list body)))
-    `(progn
-       (%defun ',name (lambda ,lambda-list (block ,block-name , at body)))
-       (precompile ',name)
-       (eval-when (:compile-toplevel :load-toplevel :execute)
-         (setf (inline-expansion ',name) ',expansion))
-       ',name)))
-
-#+nil
-(defmacro defsubst (&rest args)
-  `(defun , at args))
-
-
 (declaim (ftype (function (t t) cons) get-descriptor-info))
 (defun get-descriptor-info (arg-types return-type)
   (let* ((arg-types (mapcar #'!class-ref arg-types))
@@ -469,7 +453,8 @@
     (or descriptor-info
         (setf (gethash key ht) (make-descriptor-info arg-types return-type)))))
 
-(defsubst get-descriptor (arg-types return-type)
+(declaim (inline get-descriptor))
+(defun get-descriptor (arg-types return-type)
   (car (get-descriptor-info arg-types return-type)))
 
 (declaim (ftype (function * t) emit-invokestatic))
@@ -478,9 +463,54 @@
          (descriptor (car info))
          (stack-effect (cdr info))
          (class-name (!class-name class-name))
-         (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-name class) (!class-name +lisp-object+))
+         "LispObject")
+        ((equal class +lisp-symbol+)
+         "Symbol")
+        ((equal class  +lisp-thread+)
+         "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))
+         (class-name (!class-name class-name))
+         (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))
+         (class-name (!class-name class-name))
+         (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)
@@ -644,46 +674,6 @@
         (return-from common-representation result)))))
 
 
-
-(declaim (ftype (function t string) pretty-java-class))
-(defun pretty-java-class (class)
-  (cond ((equal (!class-name class) (!class-name +lisp-object+))
-         "LispObject")
-        ((equal class +lisp-symbol+)
-         "Symbol")
-        ((equal class +lisp-thread+)
-         "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))
-         (class-name (!class-name class-name))
-         (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))
-         (class-name (!class-name class-name))
-         (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)
 
@@ -1196,11 +1186,8 @@
 
 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
 (define-resolver (182 183 184) (instruction)
-  (let* ((args (instruction-args instruction))
-         (index (pool-method (!class-name (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)