Changeset 14073


Ignore:
Timestamp:
08/12/12 13:40:11 (8 years ago)
Author:
ehuelsmann
Message:

Much nicer code printing with (setq jvm::*compiler-debug* t).

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r14061 r14073  
    214214         (index (pool-add-method-ref *pool* class-name
    215215                                     method-name (cons return-type arg-types)))
    216          (instruction (apply #'%emit 'invokestatic (u2 index))))
     216         (instruction (%emit 'invokestatic index)))
    217217    (setf (instruction-stack instruction) stack-effect)))
    218218
     
    235235         (index (pool-add-method-ref *pool* class-name
    236236                                     method-name (cons return-type arg-types)))
    237          (instruction (apply #'%emit 'invokevirtual (u2 index))))
     237         (instruction (%emit 'invokevirtual index)))
    238238    (declare (type (signed-byte 8) stack-effect))
    239239    (let ((explain *explain*))
     
    252252         (index (pool-add-method-ref *pool* class-name
    253253                                     "<init>" (cons nil arg-types)))
    254          (instruction (apply #'%emit 'invokespecial (u2 index))))
     254         (instruction (%emit 'invokespecial index)))
    255255    (declare (type (signed-byte 8) stack-effect))
    256256    (setf (instruction-stack instruction) (1- stack-effect))))
     
    292292(defun emit-getstatic (class-name field-name type)
    293293  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
    294     (apply #'%emit 'getstatic (u2 index))))
     294    (%emit 'getstatic index)))
    295295
    296296(defknown emit-putstatic (t t t) t)
    297297(defun emit-putstatic (class-name field-name type)
    298298  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
    299     (apply #'%emit 'putstatic (u2 index))))
     299    (%emit 'putstatic index)))
    300300
    301301(declaim (inline emit-getfield emit-putfield))
     
    303303(defun emit-getfield (class-name field-name type)
    304304  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
    305     (apply #'%emit 'getfield (u2 index))))
     305    (%emit 'getfield index)))
    306306
    307307(defknown emit-putfield (t t t) t)
    308308(defun emit-putfield (class-name field-name type)
    309309  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
    310     (apply #'%emit 'putfield (u2 index))))
     310    (%emit 'putfield index)))
    311311
    312312
     
    314314(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
    315315(defun emit-new (class-name)
    316   (apply #'%emit 'new (u2 (pool-class class-name))))
     316  (%emit 'new (pool-class class-name)))
    317317
    318318(defknown emit-anewarray (t) t)
     
    322322(defknown emit-checkcast (t) t)
    323323(defun emit-checkcast (class-name)
    324   (apply #'%emit 'checkcast (u2 (pool-class class-name))))
     324  (apply #'%emit 'checkcast (list (pool-class class-name))))
    325325
    326326(defknown emit-instanceof (t) t)
    327327(defun emit-instanceof (class-name)
    328   (apply #'%emit 'instanceof (u2 (pool-class class-name))))
     328  (apply #'%emit 'instanceof (list (pool-class class-name))))
    329329
    330330
     
    10861086  (with-code-to-method (class (abcl-class-file-static-initializer class))
    10871087    (emit 'return))
     1088  (when *compiler-debug*
     1089    (print "; Writing class file ")
     1090    (print (abcl-class-file-class-name class))
     1091    (terpri))
    10881092  (finalize-class-file class)
    10891093  (write-class-file class stream))
  • trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r13850 r14073  
    7272    ((nil :void) "V")))
    7373
     74(defun pretty-class (type &optional (default-package ""))
     75  (let* ((p-len (1+ (length default-package)))
     76         (len (length type))
     77         (cnt (when (< p-len len)
     78                (count #\/ type :start p-len)))
     79         (type (if (and cnt (= 0 cnt))
     80                   (subseq type p-len len)
     81                   (substitute #\. #\/ type))))
     82    type))
     83
     84(defun pretty-type (type &optional (default-package ""))
     85  (cond
     86    ((eql #\I type) "int")
     87    ((eql #\J type) "long")
     88    ((eql #\F type) "float")
     89    ((eql #\D type) "double")
     90    ((eql #\Z type) "boolean")
     91    ((eql #\C type) "char")
     92    ((eql #\B type) "byte")
     93    ((eql #\S type) "short")
     94    ((eql #\V type) "void")
     95    ((stringp type)
     96     (pretty-class (subseq type 1 (1- (length type))) default-package))))
    7497
    7598#|
     
    266289  entries-list
    267290  ;; the entries hash stores raw values, except in case of string and
    268   ;; utf8, because both are string values
     291  ;; utf8, because both are string values in which case a two-element
     292  ;; list - containing the tag and the value - is used
    269293  (entries (make-hash-table :test #'equal :size 2048 :rehash-size 2.0)))
     294
     295(defun matching-index-p (entry index)
     296  (eql (constant-index entry) index))
     297
     298(defun find-pool-entry (pool item &key (test #'matching-index-p))
     299  (find-if (lambda (x)
     300             (funcall test x item))
     301           (pool-entries-list pool)))
    270302
    271303
     
    274306  tag
    275307  index)
     308
     309(defgeneric print-pool-constant (pool entry stream &key &allow-other-keys)
     310  (:method (pool (entry t) stream &key)
     311    (print-object entry stream)))
     312
     313(defmethod print-pool-constant :around (pool entry stream &key recursive)
     314  (cond
     315    ((and (null *print-readably*)
     316          (null *print-escape*)
     317          (null recursive))
     318     (princ #\# stream)
     319     (princ (constant-index entry) stream)
     320     (princ #\Space stream)
     321     (princ #\< stream)
     322     (call-next-method)
     323     (princ #\> stream))
     324    (t
     325     (call-next-method))))
    276326
    277327(defparameter +constant-type-map+
     
    294344  name-index)
    295345
     346(defmethod print-pool-constant (pool (entry constant-class) stream
     347                                &key recursive package)
     348  (cond
     349    ((and (null *print-escape*)
     350          (null *print-readably*))
     351     ;; human readable
     352     (unless recursive
     353       (princ "Class " stream))
     354     (princ
     355      (pretty-class (constant-utf8-value
     356                     (find-pool-entry pool
     357                                      (constant-class-name-index entry)))
     358                    package)
     359      stream))
     360    (t
     361     ;; READable
     362     (call-next-method))))
     363
    296364(defstruct (constant-member-ref (:constructor
    297365                                 %make-constant-member-ref
     
    303371  name/type-index)
    304372
     373(defmethod print-pool-constant (pool (entry constant-member-ref) stream
     374                                &key recursive package)
     375  (cond
     376    ((and (null *print-escape*)
     377          (null *print-readably*))
     378     ;; human readable
     379     (unless recursive
     380       (princ (case (constant-member-ref-tag entry)
     381                (9 "Field ")
     382                (10 "Method ")
     383                (11 "Interface method "))
     384              stream))
     385     (let ((name-prefix
     386            (with-output-to-string (s)
     387              (print-pool-constant pool
     388                          (find-pool-entry pool
     389                                           (constant-member-ref-class-index entry))
     390                          s
     391                          :recursive t
     392                          :package package)
     393              (princ #\. s))))
     394       (print-pool-constant pool
     395                            (find-pool-entry pool
     396                                             (constant-member-ref-name/type-index entry))
     397                            stream
     398                            :name-prefix name-prefix
     399                            :recursive t
     400                            :package package)))
     401    (t
     402     ;; READable
     403     (call-next-method))))
     404
     405
    305406(declaim (inline make-constant-field-ref make-constant-method-ref
    306407                 make-constant-interface-method-ref))
     
    325426  value-index)
    326427
     428
     429(defmethod print-pool-constant (pool (entry constant-string) stream
     430                                &key recursive)
     431  (cond
     432    ((and (null *print-readably*)
     433          (null *print-escape*))
     434     (unless recursive
     435       (princ "String " stream))
     436     (princ #\" stream)
     437     (print-pool-constant pool
     438                          (find-pool-entry pool
     439                                           (constant-string-value-index entry))
     440                          stream
     441                          :recursive t)
     442     (princ #\" stream))
     443    (t
     444     (call-next-method))))
     445
    327446(defstruct (constant-float/int (:constructor
    328447                                %make-constant-float/int (tag index value))
     
    332451  value)
    333452
     453(defmethod print-pool-constant (pool (entry constant-float/int) stream
     454                                &key recursive)
     455  (cond
     456    ((and (null *print-escape*)
     457          (null *print-readably*))
     458     (unless recursive
     459       (princ (case (constant-tag entry)
     460                (3 "int ")
     461                (4 "float "))
     462              stream))
     463     (princ (constant-float/int-value entry) stream))
     464    (t
     465     (call-next-method))))
     466
    334467(declaim (inline make-constant-float make-constant-int))
    335468(defun make-constant-float (index value)
     
    347480in the constant pool."
    348481  value)
     482
     483(defmethod print-pool-constant (pool (entry constant-double/long) stream
     484                                &key recursive)
     485  (cond
     486    ((and (null *print-escape*)
     487          (null *print-readably*))
     488     (unless recursive
     489       (princ (case (constant-tag entry)
     490                (5 "long ")
     491                (6 "double "))
     492              stream))
     493     (princ (constant-double/long-value entry) stream))
     494    (t
     495     (call-next-method))))
    349496
    350497(declaim (inline make-constant-double make-constant-float))
     
    367514  name-index
    368515  descriptor-index)
     516
     517(defun parse-descriptor (descriptor)
     518  (let (arguments
     519        method-descriptor-p
     520        (index 0))
     521    (when (eql (aref descriptor 0) #\()
     522      ;; parse the arguments here...
     523      (assert (find #\) descriptor))
     524      (setf method-descriptor-p t)
     525      (loop until (eql (aref descriptor index) #\))
     526         do (incf index)
     527         if (find (aref descriptor index) "IJFDZCBSV")
     528         do (push (aref descriptor index) arguments)
     529         if (eql (aref descriptor index) #\L)
     530         do (loop for i upfrom index
     531               until (eql (aref descriptor i) #\;)
     532               finally (push (subseq descriptor index (1+ i))
     533                             arguments)
     534               finally (setf index i))
     535         finally (incf index)))
     536    (values (let ((return-value (subseq descriptor index)))
     537              (if (= (length return-value) 1)
     538                  (aref return-value 0)
     539                  return-value))
     540            (nreverse arguments)
     541            method-descriptor-p)))
     542
     543(defmethod print-pool-constant (pool (entry constant-name/type) stream
     544                                &key name-prefix package)
     545  (cond
     546    ((and (null *print-readably*)
     547          (null *print-escape*))
     548     (multiple-value-bind
     549           (type arguments method-descriptor-p)
     550         (let ((entry (find-pool-entry pool
     551                            (constant-name/type-descriptor-index entry))))
     552           (if (constant-utf8-p entry)
     553               (parse-descriptor (constant-utf8-value entry))
     554               (class-ref entry)))
     555       (princ (pretty-type type package) stream)
     556       (princ #\Space stream)
     557       (when name-prefix
     558         (princ name-prefix stream))
     559       (print-pool-constant pool
     560                            (find-pool-entry pool (constant-name/type-name-index entry))
     561                            stream
     562                            :recursive t)
     563       (when method-descriptor-p
     564         (format stream "(~{~A~^,~})" (mapcar (lambda (x)
     565                                                (pretty-type x package))
     566                                              arguments)))))
     567    (t
     568     (call-next-method))))
    369569
    370570(defstruct (constant-utf8 (:constructor make-constant-utf8 (index value))
     
    763963      (let ((tag (constant-tag entry)))
    764964        (when *jvm-class-debug-pool*
    765           (print-constant entry t))
     965          (print-entry entry t))
    766966        (write-u1 tag stream)
    767967        (case tag
     
    789989
    790990
    791 (defun print-constant (entry stream)
     991(defun print-entry (entry stream)
    792992  "Debugging helper to print the content of a constant-pool entry."
    793993  (let ((tag (constant-tag entry))
     
    8081008
    8091009
     1010(defmethod print-pool-constant (pool (entry constant-utf8) stream &key)
     1011  (if (and (null *print-escape*)
     1012           (null *print-readably*))
     1013      (princ (constant-utf8-value entry) stream)
     1014      (call-next-method)))
     1015
     1016
    8101017#|
    8111018
     
    10441251                            (mapcar #'exception-end-pc handlers)
    10451252                            (mapcar #'exception-handler-pc handlers))
    1046                      (code-optimize code))))
     1253                     (code-optimize code)
     1254                     (class-file-constants class))))
    10471255    (invoke-callbacks :code-finalized class parent
    10481256                      (coerce c 'list) handlers)
     
    10561264          (c labels)
    10571265        (code-bytes c)
     1266      (assert (< 0 (length c) 65536))
    10581267      (setf (code-code code) c
    10591268            (code-labels code) labels)))
  • trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r13792 r14073  
    449449       (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
    450450
    451 (defun print-code (code)
     451(defun format-instruction-args (instruction pool)
     452  (if (memql (instruction-opcode instruction) '(18 19 20
     453                                                178 179 180 181 182 183 184 185
     454                                                187
     455                                                192 193))
     456      (let ((*print-readably* nil)
     457            (*print-escape* nil))
     458        (with-output-to-string (s)
     459          (print-pool-constant pool
     460                               (find-pool-entry pool
     461                                                (car (instruction-args instruction))) s
     462                               :package "org/armedbear/lisp")))
     463      (when (instruction-args instruction)
     464        (format nil "~S" (instruction-args instruction)))))
     465
     466(defun print-code (code pool)
     467  (declare (ignorable pool))
    452468  (dotimes (i (length code))
    453469    (let ((instruction (elt code i)))
    454       (sys::%format t "~D ~A ~S ~S ~S~%"
     470      (format t "~3D ~A ~19T~A ~A ~A~%"
    455471                    i
    456472                    (opcode-name (instruction-opcode instruction))
    457                     (instruction-args instruction)
    458                     (instruction-stack instruction)
    459                     (instruction-depth instruction)))))
    460 
    461 (defun print-code2 (code)
     473                    (or (format-instruction-args instruction pool) "")
     474                    (or (instruction-stack instruction) "")
     475                    (or (instruction-depth instruction) "")))))
     476
     477(defun print-code2 (code pool)
     478  (declare (ignorable pool))
    462479  (dotimes (i (length code))
    463480    (let ((instruction (elt code i)))
     
    483500                      (inst 'aload (car (instruction-args instruction)))
    484501                      (inst 'aconst_null)
    485                       (inst 'putfield (u2 (pool-field +lisp-thread+ "_values"
    486                                                       +lisp-object-array+)))))
     502                      (inst 'putfield (list (pool-field +lisp-thread+ "_values"
     503                                                        +lisp-object-array+)))))
    487504             (vector-push-extend instruction vector)))
    488505          (t
     
    603620                 176 ; areturn
    604621                 177 ; return
    605                  178 ; getstatic
    606                  179 ; putstatic
    607                  180 ; getfield
    608                  181 ; putfield
    609                  182 ; invokevirtual
    610                  183 ; invockespecial
    611                  184 ; invokestatic
    612                  187 ; new
    613622                 189 ; anewarray
    614623                 190 ; arraylength
    615624                 191 ; athrow
    616                  192 ; checkcast
    617                  193 ; instanceof
    618625                 194 ; monitorenter
    619626                 195 ; monitorexit
     
    715722      (error "IINC argument ~A out of bounds." n))
    716723    (inst 132 (list register (s1 n)))))
     724
     725(define-resolver (178 179 180 181 182 183 184 185 192 193 187)
     726    (instruction)
     727  (let* ((arg (car (instruction-args instruction))))
     728    (setf (instruction-args instruction)
     729          (u2 arg))
     730    instruction))
    717731
    718732(defknown resolve-instruction (t) t)
     
    971985
    972986(defknown optimize-code (t t) t)
    973 (defun optimize-code (code handler-labels)
     987(defun optimize-code (code handler-labels pool)
    974988  (unless *enable-optimization*
    975989    (format t "optimizations are disabled~%"))
     
    977991    (when *compiler-debug*
    978992      (format t "----- before optimization -----~%")
    979       (print-code code))
     993      (print-code code pool))
    980994    (loop
    981995       (let ((changed-p nil))
     
    10041018    (when *compiler-debug*
    10051019      (sys::%format t "----- after optimization -----~%")
    1006       (print-code code)))
     1020      (print-code code pool)))
    10071021  code)
    10081022
     
    10371051                                (symbol-value (the symbol label)))
    10381052                              index)))
     1053              (assert (<= -32768 offset 32767))
    10391054              (setf (instruction-args instruction) (s2 offset))))
    10401055          (unless (= (instruction-opcode instruction) 202) ; LABEL
     
    10551070      (values bytes labels))))
    10561071
    1057 (defun finalize-code (code handler-labels optimize)
     1072(defun finalize-code (code handler-labels optimize pool)
    10581073  (setf code (coerce (nreverse code) 'vector))
    10591074  (when optimize
    1060     (setf code (optimize-code code handler-labels)))
     1075    (setf code (optimize-code code handler-labels pool)))
    10611076  (resolve-instructions (expand-virtual-instructions code)))
    10621077
Note: See TracChangeset for help on using the changeset viewer.