[armedbear-cvs] r12839 - branches/generic-class-file/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Jul 31 19:21:21 UTC 2010
Author: ehuelsmann
Date: Sat Jul 31 15:21:20 2010
New Revision: 12839
Log:
Backport r12837, 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 15:21:20 2010
@@ -308,17 +308,17 @@
(defknown emit-push-nil () t)
(declaim (inline emit-push-nil))
(defun emit-push-nil ()
- (emit 'getstatic +lisp+ "NIL" +lisp-object+))
+ (emit-getstatic +lisp+ "NIL" +lisp-object+))
(defknown emit-push-nil-symbol () t)
(declaim (inline emit-push-nil-symbol))
(defun emit-push-nil-symbol ()
- (emit 'getstatic +lisp-nil+ "NIL" +lisp-symbol+))
+ (emit-getstatic +lisp-nil+ "NIL" +lisp-symbol+))
(defknown emit-push-t () t)
(declaim (inline emit-push-t))
(defun emit-push-t ()
- (emit 'getstatic +lisp+ "T" +lisp-symbol+))
+ (emit-getstatic +lisp+ "T" +lisp-symbol+))
(defknown emit-push-false (t) t)
(defun emit-push-false (representation)
@@ -541,6 +541,19 @@
(setf pretty-string (concatenate 'string pretty-string "[]")))
pretty-string))
+(declaim (inline emit-getstatic emit-putstatic))
+(defknown emit-getstatic (t t t) t)
+(defun emit-getstatic (class-name field-name type)
+ (let ((index (pool-field (!class-name class-name)
+ field-name (!class-ref type))))
+ (apply #'%emit 'getstatic (u2 index))))
+
+(defknown emit-putstatic (t t t) t)
+(defun emit-putstatic (class-name field-name type)
+ (let ((index (pool-field (!class-name class-name)
+ field-name (!class-ref type))))
+ (apply #'%emit 'putstatic (u2 index))))
+
(defvar type-representations '((:int fixnum)
(:long (integer #.most-negative-java-long
#.most-positive-java-long))
@@ -743,7 +756,7 @@
(emit 'instanceof instanceof-class)
(emit 'ifne LABEL1)
(emit-load-local-variable variable)
- (emit 'getstatic +lisp-symbol+ expected-type-java-symbol-name
+ (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name
+lisp-symbol+)
(emit-invokestatic +lisp+ "type_error"
(lisp-object-arg-types 2) +lisp-object+)
@@ -803,7 +816,7 @@
(defun maybe-generate-interrupt-check ()
(unless (> *speed* *safety*)
(let ((label1 (gensym)))
- (emit 'getstatic +lisp+ "interrupted" "Z")
+ (emit-getstatic +lisp+ "interrupted" "Z")
(emit 'ifeq label1)
(emit-invokestatic +lisp+ "handleInterrupt" nil nil)
(label label1))))
@@ -1167,10 +1180,8 @@
;; getstatic, putstatic
(define-resolver (178 179) (instruction)
- (let* ((args (instruction-args instruction))
- (index (pool-field (!class-name (first args))
- (second args) (!class-ref (third args)))))
- (inst (instruction-opcode instruction) (u2 index))))
+ ;; we used to create the pool-field here; that moved to the emit-* layer
+ instruction)
;; bipush, sipush
(define-resolver (16 17) (instruction)
@@ -1810,7 +1821,7 @@
(if (null (third param)) ;; supplied-p
(emit-push-nil)
(emit-push-t)) ;; we don't need the actual supplied-p symbol
- (emit 'getstatic +lisp-closure+ "OPTIONAL" "I")
+ (emit-getstatic +lisp-closure+ "OPTIONAL" "I")
(emit-invokespecial-init +lisp-closure-parameter+
(list +lisp-symbol+ +lisp-object+
+lisp-object+ "I")))
@@ -2008,7 +2019,7 @@
(defun serialize-integer (n)
"Generates code to restore a serialized integer."
(cond((<= 0 n 255)
- (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
+ (emit-getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
(emit-push-constant-int n)
(emit 'aaload))
((<= most-negative-fixnum n most-positive-fixnum)
@@ -2077,7 +2088,7 @@
(lookup-known-symbol symbol)
(cond
(name
- (emit 'getstatic class name +lisp-symbol+))
+ (emit-getstatic class name +lisp-symbol+))
((null (symbol-package symbol))
(emit-push-constant-int (dump-uninterned-symbol-index symbol))
(emit-invokestatic +lisp-load+ "getUninternedSymbol" '("I")
@@ -2139,7 +2150,7 @@
(setf similarity-fn #'eq))
(let ((existing (assoc object *externalized-objects* :test similarity-fn)))
(when existing
- (emit 'getstatic *this-class* (cdr existing) field-type)
+ (emit-getstatic *this-class* (cdr existing) field-type)
(when cast
(emit 'checkcast cast))
(return-from emit-load-externalized-object field-type)))
@@ -2158,18 +2169,18 @@
(list +java-string+) +lisp-object+)
(when (not (eq field-type +lisp-object+))
(emit 'checkcast field-type))
- (emit 'putstatic *this-class* field-name field-type)
+ (emit-putstatic *this-class* field-name field-type)
(setf *static-code* *code*)))
(*declare-inline*
(funcall dispatch-fn object)
- (emit 'putstatic *this-class* field-name field-type))
+ (emit-putstatic *this-class* field-name field-type))
(t
(let ((*code* *static-code*))
(funcall dispatch-fn object)
- (emit 'putstatic *this-class* field-name field-type)
+ (emit-putstatic *this-class* field-name field-type)
(setf *static-code* *code*))))
- (emit 'getstatic *this-class* field-name field-type)
+ (emit-getstatic *this-class* field-name field-type)
(when cast
(emit 'checkcast cast))
field-type)))
@@ -2201,9 +2212,9 @@
(let ((*code* (if *declare-inline* *code* *static-code*)))
(if (eq class *this-class*)
(progn ;; generated by the DECLARE-OBJECT*'s above
- (emit 'getstatic class name +lisp-object+)
+ (emit-getstatic class name +lisp-object+)
(emit 'checkcast +lisp-symbol+))
- (emit 'getstatic class name +lisp-symbol+))
+ (emit-getstatic class name +lisp-symbol+))
(emit-invokevirtual +lisp-symbol+
(if setf
"getSymbolSetfFunctionOrDie"
@@ -2213,7 +2224,7 @@
;; (AutoloadedFunctionProxy) by allowing it to resolve itself
(emit-invokevirtual +lisp-object+
"resolve" nil +lisp-object+)
- (emit 'putstatic *this-class* f +lisp-object+)
+ (emit-putstatic *this-class* f +lisp-object+)
(if *declare-inline*
(setf saved-code *code*)
(setf *static-code* *code*))
@@ -2240,7 +2251,7 @@
(emit 'new class-name)
(emit 'dup)
(emit-invokespecial-init class-name '())
- (emit 'putstatic *this-class* g +lisp-object+)
+ (emit-putstatic *this-class* g +lisp-object+)
(setf *static-code* *code*)
(setf (gethash local-function ht) g))))
@@ -2265,7 +2276,7 @@
(emit 'ldc (pool-string s))
(emit-invokestatic +lisp+ "readObjectFromString"
(list +java-string+) +lisp-object+)
- (emit 'putstatic *this-class* g +lisp-object+)
+ (emit-putstatic *this-class* g +lisp-object+)
(if *declare-inline*
(setf saved-code *code*)
(setf *static-code* *code*)))
@@ -2287,7 +2298,7 @@
(list +java-string+) +lisp-object+)
(emit-invokestatic +lisp+ "loadTimeValue"
(lisp-object-arg-types 1) +lisp-object+)
- (emit 'putstatic *this-class* g +lisp-object+)
+ (emit-putstatic *this-class* g +lisp-object+)
(if *declare-inline*
(setf saved-code *code*)
(setf *static-code* *code*)))
@@ -2309,7 +2320,7 @@
(emit 'ldc (pool-string g))
(emit-invokestatic +lisp+ "recall"
(list +java-string+) +lisp-object+)
- (emit 'putstatic *this-class* g +lisp-object+)
+ (emit-putstatic *this-class* g +lisp-object+)
(setf *static-code* *code*)
g)))
@@ -3032,7 +3043,7 @@
(declare-local-function local-function)
(declare-object
(local-function-function local-function)))))
- (emit 'getstatic *this-class* g +lisp-object+)
+ (emit-getstatic *this-class* g +lisp-object+)
; Stack: template-function
(when *closure-variables*
(emit 'checkcast +lisp-compiled-closure+)
@@ -4753,7 +4764,7 @@
(defun p2-load-time-value (form target representation)
(cond (*file-compilation*
- (emit 'getstatic *this-class*
+ (emit-getstatic *this-class*
(declare-load-time-value (second form)) +lisp-object+)
(fix-boxing representation nil)
(emit-move-from-stack target representation))
@@ -4884,7 +4895,7 @@
(defun emit-make-compiled-closure-for-labels
(local-function compiland declaration)
- (emit 'getstatic *this-class* declaration +lisp-object+)
+ (emit-getstatic *this-class* declaration +lisp-object+)
(let ((parent (compiland-parent compiland)))
(when (compiland-closure-register parent)
(dformat t "(compiland-closure-register parent) = ~S~%"
@@ -4969,7 +4980,7 @@
(let ((class-file (compiland-class-file compiland)))
(with-open-class-file (f class-file)
(compile-and-write-to-stream class-file compiland f))
- (emit 'getstatic *this-class*
+ (emit-getstatic *this-class*
(declare-local-function (make-local-function :class-file
class-file))
+lisp-object+)))
@@ -5015,7 +5026,7 @@
(declare-local-function local-function)
(declare-object
(local-function-function local-function)))))
- (emit 'getstatic *this-class* g +lisp-object+)
+ (emit-getstatic *this-class* g +lisp-object+)
; Stack: template-function
(when (compiland-closure-register *current-compiland*)
@@ -5026,7 +5037,7 @@
+lisp-object+)))))
(emit-move-from-stack target))
((inline-ok name)
- (emit 'getstatic *this-class*
+ (emit-getstatic *this-class*
(declare-function name) +lisp-object+)
(emit-move-from-stack target))
(t
@@ -5056,11 +5067,11 @@
(declare-local-function local-function)
(declare-object
(local-function-function local-function)))))
- (emit 'getstatic *this-class*
+ (emit-getstatic *this-class*
g +lisp-object+))))) ; Stack: template-function
((and (member name *functions-defined-in-current-file* :test #'equal)
(not (notinline-p name)))
- (emit 'getstatic *this-class*
+ (emit-getstatic *this-class*
(declare-setf-function name) +lisp-object+)
(emit-move-from-stack target))
((and (null *file-compilation*)
@@ -7432,7 +7443,7 @@
(emit 'dup)
(emit 'instanceof instanceof-class)
(emit 'ifne LABEL1)
- (emit 'getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+)
+ (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+)
(emit-invokestatic +lisp+ "type_error"
(lisp-object-arg-types 2) +lisp-object+)
(label LABEL1))
More information about the armedbear-cvs
mailing list