[armedbear-cvs] r14073 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sun Aug 12 13:40:24 UTC 2012
Author: ehuelsmann
Date: Sun Aug 12 06:40:11 2012
New Revision: 14073
Log:
Much nicer code printing with (setq jvm::*compiler-debug* t).
Modified:
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 12 06:25:58 2012 (r14072)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 12 06:40:11 2012 (r14073)
@@ -213,7 +213,7 @@
(let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
(index (pool-add-method-ref *pool* class-name
method-name (cons return-type arg-types)))
- (instruction (apply #'%emit 'invokestatic (u2 index))))
+ (instruction (%emit 'invokestatic index)))
(setf (instruction-stack instruction) stack-effect)))
@@ -234,7 +234,7 @@
(let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
(index (pool-add-method-ref *pool* class-name
method-name (cons return-type arg-types)))
- (instruction (apply #'%emit 'invokevirtual (u2 index))))
+ (instruction (%emit 'invokevirtual index)))
(declare (type (signed-byte 8) stack-effect))
(let ((explain *explain*))
(when (and explain (memq :java-calls explain))
@@ -251,7 +251,7 @@
(let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
(index (pool-add-method-ref *pool* class-name
"<init>" (cons nil arg-types)))
- (instruction (apply #'%emit 'invokespecial (u2 index))))
+ (instruction (%emit 'invokespecial index)))
(declare (type (signed-byte 8) stack-effect))
(setf (instruction-stack instruction) (1- stack-effect))))
@@ -291,29 +291,29 @@
(defknown emit-getstatic (t t t) t)
(defun emit-getstatic (class-name field-name type)
(let ((index (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'getstatic (u2 index))))
+ (%emit 'getstatic index)))
(defknown emit-putstatic (t t t) t)
(defun emit-putstatic (class-name field-name type)
(let ((index (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'putstatic (u2 index))))
+ (%emit 'putstatic index)))
(declaim (inline emit-getfield emit-putfield))
(defknown emit-getfield (t t t) t)
(defun emit-getfield (class-name field-name type)
(let* ((index (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'getfield (u2 index))))
+ (%emit 'getfield index)))
(defknown emit-putfield (t t t) t)
(defun emit-putfield (class-name field-name type)
(let* ((index (pool-add-field-ref *pool* class-name field-name type)))
- (apply #'%emit 'putfield (u2 index))))
+ (%emit 'putfield index)))
(defknown emit-new (t) t)
(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
(defun emit-new (class-name)
- (apply #'%emit 'new (u2 (pool-class class-name))))
+ (%emit 'new (pool-class class-name)))
(defknown emit-anewarray (t) t)
(defun emit-anewarray (class-name)
@@ -321,11 +321,11 @@
(defknown emit-checkcast (t) t)
(defun emit-checkcast (class-name)
- (apply #'%emit 'checkcast (u2 (pool-class class-name))))
+ (apply #'%emit 'checkcast (list (pool-class class-name))))
(defknown emit-instanceof (t) t)
(defun emit-instanceof (class-name)
- (apply #'%emit 'instanceof (u2 (pool-class class-name))))
+ (apply #'%emit 'instanceof (list (pool-class class-name))))
(defvar type-representations '((:int fixnum)
@@ -1085,6 +1085,10 @@
(emit 'return))
(with-code-to-method (class (abcl-class-file-static-initializer class))
(emit 'return))
+ (when *compiler-debug*
+ (print "; Writing class file ")
+ (print (abcl-class-file-class-name class))
+ (terpri))
(finalize-class-file class)
(write-class-file class stream))
Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Aug 12 06:25:58 2012 (r14072)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sun Aug 12 06:40:11 2012 (r14073)
@@ -71,6 +71,29 @@
(:short "S")
((nil :void) "V")))
+(defun pretty-class (type &optional (default-package ""))
+ (let* ((p-len (1+ (length default-package)))
+ (len (length type))
+ (cnt (when (< p-len len)
+ (count #\/ type :start p-len)))
+ (type (if (and cnt (= 0 cnt))
+ (subseq type p-len len)
+ (substitute #\. #\/ type))))
+ type))
+
+(defun pretty-type (type &optional (default-package ""))
+ (cond
+ ((eql #\I type) "int")
+ ((eql #\J type) "long")
+ ((eql #\F type) "float")
+ ((eql #\D type) "double")
+ ((eql #\Z type) "boolean")
+ ((eql #\C type) "char")
+ ((eql #\B type) "byte")
+ ((eql #\S type) "short")
+ ((eql #\V type) "void")
+ ((stringp type)
+ (pretty-class (subseq type 1 (1- (length type))) default-package))))
#|
@@ -265,15 +288,42 @@
(index 0)
entries-list
;; the entries hash stores raw values, except in case of string and
- ;; utf8, because both are string values
+ ;; utf8, because both are string values in which case a two-element
+ ;; list - containing the tag and the value - is used
(entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
+(defun matching-index-p (entry index)
+ (eql (constant-index entry) index))
+
+(defun find-pool-entry (pool item &key (test #'matching-index-p))
+ (find-if (lambda (x)
+ (funcall test x item))
+ (pool-entries-list pool)))
+
(defstruct constant
"Structure to be included in all constant sub-types."
tag
index)
+(defgeneric print-pool-constant (pool entry stream &key &allow-other-keys)
+ (:method (pool (entry t) stream &key)
+ (print-object entry stream)))
+
+(defmethod print-pool-constant :around (pool entry stream &key recursive)
+ (cond
+ ((and (null *print-readably*)
+ (null *print-escape*)
+ (null recursive))
+ (princ #\# stream)
+ (princ (constant-index entry) stream)
+ (princ #\Space stream)
+ (princ #\< stream)
+ (call-next-method)
+ (princ #\> stream))
+ (t
+ (call-next-method))))
+
(defparameter +constant-type-map+
'((:class 7 1)
(:field-ref 9 1)
@@ -293,6 +343,24 @@
"Structure holding information on a 'class' type item in the constant pool."
name-index)
+(defmethod print-pool-constant (pool (entry constant-class) stream
+ &key recursive package)
+ (cond
+ ((and (null *print-escape*)
+ (null *print-readably*))
+ ;; human readable
+ (unless recursive
+ (princ "Class " stream))
+ (princ
+ (pretty-class (constant-utf8-value
+ (find-pool-entry pool
+ (constant-class-name-index entry)))
+ package)
+ stream))
+ (t
+ ;; READable
+ (call-next-method))))
+
(defstruct (constant-member-ref (:constructor
%make-constant-member-ref
(tag index class-index name/type-index))
@@ -302,6 +370,39 @@
class-index
name/type-index)
+(defmethod print-pool-constant (pool (entry constant-member-ref) stream
+ &key recursive package)
+ (cond
+ ((and (null *print-escape*)
+ (null *print-readably*))
+ ;; human readable
+ (unless recursive
+ (princ (case (constant-member-ref-tag entry)
+ (9 "Field ")
+ (10 "Method ")
+ (11 "Interface method "))
+ stream))
+ (let ((name-prefix
+ (with-output-to-string (s)
+ (print-pool-constant pool
+ (find-pool-entry pool
+ (constant-member-ref-class-index entry))
+ s
+ :recursive t
+ :package package)
+ (princ #\. s))))
+ (print-pool-constant pool
+ (find-pool-entry pool
+ (constant-member-ref-name/type-index entry))
+ stream
+ :name-prefix name-prefix
+ :recursive t
+ :package package)))
+ (t
+ ;; READable
+ (call-next-method))))
+
+
(declaim (inline make-constant-field-ref make-constant-method-ref
make-constant-interface-method-ref))
(defun make-constant-field-ref (index class-index name/type-index)
@@ -324,6 +425,24 @@
"Structure holding information on a 'string' type item in the constant pool."
value-index)
+
+(defmethod print-pool-constant (pool (entry constant-string) stream
+ &key recursive)
+ (cond
+ ((and (null *print-readably*)
+ (null *print-escape*))
+ (unless recursive
+ (princ "String " stream))
+ (princ #\" stream)
+ (print-pool-constant pool
+ (find-pool-entry pool
+ (constant-string-value-index entry))
+ stream
+ :recursive t)
+ (princ #\" stream))
+ (t
+ (call-next-method))))
+
(defstruct (constant-float/int (:constructor
%make-constant-float/int (tag index value))
(:include constant))
@@ -331,6 +450,20 @@
in the constant pool."
value)
+(defmethod print-pool-constant (pool (entry constant-float/int) stream
+ &key recursive)
+ (cond
+ ((and (null *print-escape*)
+ (null *print-readably*))
+ (unless recursive
+ (princ (case (constant-tag entry)
+ (3 "int ")
+ (4 "float "))
+ stream))
+ (princ (constant-float/int-value entry) stream))
+ (t
+ (call-next-method))))
+
(declaim (inline make-constant-float make-constant-int))
(defun make-constant-float (index value)
"Creates a `constant-float/int' structure instance containing a float."
@@ -347,6 +480,20 @@
in the constant pool."
value)
+(defmethod print-pool-constant (pool (entry constant-double/long) stream
+ &key recursive)
+ (cond
+ ((and (null *print-escape*)
+ (null *print-readably*))
+ (unless recursive
+ (princ (case (constant-tag entry)
+ (5 "long ")
+ (6 "double "))
+ stream))
+ (princ (constant-double/long-value entry) stream))
+ (t
+ (call-next-method))))
+
(declaim (inline make-constant-double make-constant-float))
(defun make-constant-double (index value)
"Creates a `constant-double/long' structure instance containing a double."
@@ -367,6 +514,59 @@
name-index
descriptor-index)
+(defun parse-descriptor (descriptor)
+ (let (arguments
+ method-descriptor-p
+ (index 0))
+ (when (eql (aref descriptor 0) #\()
+ ;; parse the arguments here...
+ (assert (find #\) descriptor))
+ (setf method-descriptor-p t)
+ (loop until (eql (aref descriptor index) #\))
+ do (incf index)
+ if (find (aref descriptor index) "IJFDZCBSV")
+ do (push (aref descriptor index) arguments)
+ if (eql (aref descriptor index) #\L)
+ do (loop for i upfrom index
+ until (eql (aref descriptor i) #\;)
+ finally (push (subseq descriptor index (1+ i))
+ arguments)
+ finally (setf index i))
+ finally (incf index)))
+ (values (let ((return-value (subseq descriptor index)))
+ (if (= (length return-value) 1)
+ (aref return-value 0)
+ return-value))
+ (nreverse arguments)
+ method-descriptor-p)))
+
+(defmethod print-pool-constant (pool (entry constant-name/type) stream
+ &key name-prefix package)
+ (cond
+ ((and (null *print-readably*)
+ (null *print-escape*))
+ (multiple-value-bind
+ (type arguments method-descriptor-p)
+ (let ((entry (find-pool-entry pool
+ (constant-name/type-descriptor-index entry))))
+ (if (constant-utf8-p entry)
+ (parse-descriptor (constant-utf8-value entry))
+ (class-ref entry)))
+ (princ (pretty-type type package) stream)
+ (princ #\Space stream)
+ (when name-prefix
+ (princ name-prefix stream))
+ (print-pool-constant pool
+ (find-pool-entry pool (constant-name/type-name-index entry))
+ stream
+ :recursive t)
+ (when method-descriptor-p
+ (format stream "(~{~A~^,~})" (mapcar (lambda (x)
+ (pretty-type x package))
+ arguments)))))
+ (t
+ (call-next-method))))
+
(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
(:include constant
(tag 1)))
@@ -762,7 +962,7 @@
(incf pool-index)
(let ((tag (constant-tag entry)))
(when *jvm-class-debug-pool*
- (print-constant entry t))
+ (print-entry entry t))
(write-u1 tag stream)
(case tag
(1 ; UTF8
@@ -788,7 +988,7 @@
(error "write-constant-pool-entry unhandled tag ~D~%" tag)))))))
-(defun print-constant (entry stream)
+(defun print-entry (entry stream)
"Debugging helper to print the content of a constant-pool entry."
(let ((tag (constant-tag entry))
(index (constant-index entry)))
@@ -807,6 +1007,13 @@
(8 (sys::%format t "str: ~a~%" (constant-string-value-index entry))))))
+(defmethod print-pool-constant (pool (entry constant-utf8) stream &key)
+ (if (and (null *print-escape*)
+ (null *print-readably*))
+ (princ (constant-utf8-value entry) stream)
+ (call-next-method)))
+
+
#|
ABCL doesn't use interfaces, so don't implement it here at this time
@@ -1043,7 +1250,8 @@
(nconc (mapcar #'exception-start-pc handlers)
(mapcar #'exception-end-pc handlers)
(mapcar #'exception-handler-pc handlers))
- (code-optimize code))))
+ (code-optimize code)
+ (class-file-constants class))))
(invoke-callbacks :code-finalized class parent
(coerce c 'list) handlers)
(unless (code-max-stack code)
@@ -1055,6 +1263,7 @@
(multiple-value-bind
(c labels)
(code-bytes c)
+ (assert (< 0 (length c) 65536))
(setf (code-code code) c
(code-labels code) labels)))
Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Aug 12 06:25:58 2012 (r14072)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Sun Aug 12 06:40:11 2012 (r14073)
@@ -448,17 +448,34 @@
(and instruction
(= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
-(defun print-code (code)
+(defun format-instruction-args (instruction pool)
+ (if (memql (instruction-opcode instruction) '(18 19 20
+ 178 179 180 181 182 183 184 185
+ 187
+ 192 193))
+ (let ((*print-readably* nil)
+ (*print-escape* nil))
+ (with-output-to-string (s)
+ (print-pool-constant pool
+ (find-pool-entry pool
+ (car (instruction-args instruction))) s
+ :package "org/armedbear/lisp")))
+ (when (instruction-args instruction)
+ (format nil "~S" (instruction-args instruction)))))
+
+(defun print-code (code pool)
+ (declare (ignorable pool))
(dotimes (i (length code))
(let ((instruction (elt code i)))
- (sys::%format t "~D ~A ~S ~S ~S~%"
+ (format t "~3D ~A ~19T~A ~A ~A~%"
i
(opcode-name (instruction-opcode instruction))
- (instruction-args instruction)
- (instruction-stack instruction)
- (instruction-depth instruction)))))
+ (or (format-instruction-args instruction pool) "")
+ (or (instruction-stack instruction) "")
+ (or (instruction-depth instruction) "")))))
-(defun print-code2 (code)
+(defun print-code2 (code pool)
+ (declare (ignorable pool))
(dotimes (i (length code))
(let ((instruction (elt code i)))
(case (instruction-opcode instruction)
@@ -482,8 +499,8 @@
(list
(inst 'aload (car (instruction-args instruction)))
(inst 'aconst_null)
- (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
- +lisp-object-array+)))))
+ (inst 'putfield (list (pool-field +lisp-thread+ "_values"
+ +lisp-object-array+)))))
(vector-push-extend instruction vector)))
(t
(vector-push-extend instruction vector)))))))
@@ -602,19 +619,9 @@
172 ; ireturn
176 ; areturn
177 ; return
- 178 ; getstatic
- 179 ; putstatic
- 180 ; getfield
- 181 ; putfield
- 182 ; invokevirtual
- 183 ; invockespecial
- 184 ; invokestatic
- 187 ; new
189 ; anewarray
190 ; arraylength
191 ; athrow
- 192 ; checkcast
- 193 ; instanceof
194 ; monitorenter
195 ; monitorexit
198 ; ifnull
@@ -715,6 +722,13 @@
(error "IINC argument ~A out of bounds." n))
(inst 132 (list register (s1 n)))))
+(define-resolver (178 179 180 181 182 183 184 185 192 193 187)
+ (instruction)
+ (let* ((arg (car (instruction-args instruction))))
+ (setf (instruction-args instruction)
+ (u2 arg))
+ instruction))
+
(defknown resolve-instruction (t) t)
(defun resolve-instruction (instruction)
(declare (optimize speed))
@@ -970,13 +984,13 @@
(defvar *enable-optimization* t)
(defknown optimize-code (t t) t)
-(defun optimize-code (code handler-labels)
+(defun optimize-code (code handler-labels pool)
(unless *enable-optimization*
(format t "optimizations are disabled~%"))
(when *enable-optimization*
(when *compiler-debug*
(format t "----- before optimization -----~%")
- (print-code code))
+ (print-code code pool))
(loop
(let ((changed-p nil))
(multiple-value-setq
@@ -1003,7 +1017,7 @@
(setf code (coerce code 'vector)))
(when *compiler-debug*
(sys::%format t "----- after optimization -----~%")
- (print-code code)))
+ (print-code code pool)))
code)
@@ -1036,6 +1050,7 @@
(offset (- (the (unsigned-byte 16)
(symbol-value (the symbol label)))
index)))
+ (assert (<= -32768 offset 32767))
(setf (instruction-args instruction) (s2 offset))))
(unless (= (instruction-opcode instruction) 202) ; LABEL
(incf index (opcode-size (instruction-opcode instruction)))))))
@@ -1054,10 +1069,10 @@
(incf index)))))
(values bytes labels))))
-(defun finalize-code (code handler-labels optimize)
+(defun finalize-code (code handler-labels optimize pool)
(setf code (coerce (nreverse code) 'vector))
(when optimize
- (setf code (optimize-code code handler-labels)))
+ (setf code (optimize-code code handler-labels pool)))
(resolve-instructions (expand-virtual-instructions code)))
(provide '#:opcodes)
More information about the armedbear-cvs
mailing list