Changeset 12838
- Timestamp:
- 07/31/10 18:24:34 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12832 r12838 443 443 (defparameter *descriptors* (make-hash-table :test #'equal)) 444 444 445 ;; Just an experiment...446 (defmacro defsubst (name lambda-list &rest body)447 (let* ((block-name (fdefinition-block-name name))448 (expansion (generate-inline-expansion block-name lambda-list body)))449 `(progn450 (%defun ',name (lambda ,lambda-list (block ,block-name ,@body)))451 (precompile ',name)452 (eval-when (:compile-toplevel :load-toplevel :execute)453 (setf (inline-expansion ',name) ',expansion))454 ',name)))455 456 #+nil457 (defmacro defsubst (&rest args)458 `(defun ,@args))459 460 461 445 (declaim (ftype (function (t t) cons) get-descriptor-info)) 462 446 (defun get-descriptor-info (arg-types return-type) … … 470 454 (setf (gethash key ht) (make-descriptor-info arg-types return-type))))) 471 455 472 (defsubst get-descriptor (arg-types return-type) 456 (declaim (inline get-descriptor)) 457 (defun get-descriptor (arg-types return-type) 473 458 (car (get-descriptor-info arg-types return-type))) 474 459 … … 479 464 (stack-effect (cdr info)) 480 465 (class-name (!class-name class-name)) 481 (instruction (emit 'invokestatic class-name method-name descriptor))) 466 (index (pool-method class-name method-name descriptor)) 467 (instruction (apply #'%emit 'invokestatic (u2 index)))) 482 468 (setf (instruction-stack instruction) stack-effect))) 469 470 471 472 (declaim (ftype (function t string) pretty-java-class)) 473 (defun pretty-java-class (class) 474 (cond ((equal (!class-name class) (!class-name +lisp-object+)) 475 "LispObject") 476 ((equal class +lisp-symbol+) 477 "Symbol") 478 ((equal class +lisp-thread+) 479 "LispThread") 480 (t 481 class))) 482 483 (defknown emit-invokevirtual (t t t t) t) 484 (defun emit-invokevirtual (class-name method-name arg-types return-type) 485 (let* ((info (get-descriptor-info arg-types return-type)) 486 (descriptor (car info)) 487 (stack-effect (cdr info)) 488 (class-name (!class-name class-name)) 489 (index (pool-method class-name method-name descriptor)) 490 (instruction (apply #'%emit 'invokevirtual (u2 index)))) 491 (declare (type (signed-byte 8) stack-effect)) 492 (let ((explain *explain*)) 493 (when (and explain (memq :java-calls explain)) 494 (unless (string= method-name "execute") 495 (format t "; call to ~A ~A.~A(~{~A~^,~})~%" 496 (pretty-java-type return-type) 497 (pretty-java-class class-name) 498 method-name 499 (mapcar 'pretty-java-type arg-types))))) 500 (setf (instruction-stack instruction) (1- stack-effect)))) 501 502 (defknown emit-invokespecial-init (string list) t) 503 (defun emit-invokespecial-init (class-name arg-types) 504 (let* ((info (get-descriptor-info arg-types nil)) 505 (descriptor (car info)) 506 (stack-effect (cdr info)) 507 (class-name (!class-name class-name)) 508 (index (pool-method class-name "<init>" descriptor)) 509 (instruction (apply #'%emit 'invokespecial (u2 index)))) 510 (declare (type (signed-byte 8) stack-effect)) 511 (setf (instruction-stack instruction) (1- stack-effect)))) 512 483 513 484 514 (defknown pretty-java-type (t) string) … … 644 674 (return-from common-representation result))))) 645 675 646 647 648 (declaim (ftype (function t string) pretty-java-class))649 (defun pretty-java-class (class)650 (cond ((equal (!class-name class) (!class-name +lisp-object+))651 "LispObject")652 ((equal class +lisp-symbol+)653 "Symbol")654 ((equal class +lisp-thread+)655 "LispThread")656 (t657 class)))658 659 (defknown emit-invokevirtual (t t t t) t)660 (defun emit-invokevirtual (class-name method-name arg-types return-type)661 (let* ((info (get-descriptor-info arg-types return-type))662 (descriptor (car info))663 (stack-effect (cdr info))664 (class-name (!class-name class-name))665 (instruction (emit 'invokevirtual class-name method-name descriptor)))666 (declare (type (signed-byte 8) stack-effect))667 (let ((explain *explain*))668 (when (and explain (memq :java-calls explain))669 (unless (string= method-name "execute")670 (format t "; call to ~A ~A.~A(~{~A~^,~})~%"671 (pretty-java-type return-type)672 (pretty-java-class class-name)673 method-name674 (mapcar 'pretty-java-type arg-types)))))675 (setf (instruction-stack instruction) (1- stack-effect))))676 677 (defknown emit-invokespecial-init (string list) t)678 (defun emit-invokespecial-init (class-name arg-types)679 (let* ((info (get-descriptor-info arg-types nil))680 (descriptor (car info))681 (stack-effect (cdr info))682 (class-name (!class-name class-name))683 (instruction (emit 'invokespecial class-name "<init>" descriptor)))684 (declare (type (signed-byte 8) stack-effect))685 (setf (instruction-stack instruction) (1- stack-effect))))686 676 687 677 ;; Index of local variable used to hold the current thread. … … 1197 1187 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor 1198 1188 (define-resolver (182 183 184) (instruction) 1199 (let* ((args (instruction-args instruction)) 1200 (index (pool-method (!class-name (first args)) 1201 (second args) (third args)))) 1202 (setf (instruction-args instruction) (u2 index)) 1203 instruction)) 1189 ;; we used to create the pool-method here; that moved to the emit-* layer 1190 instruction) 1204 1191 1205 1192 ;; ldc
Note: See TracChangeset
for help on using the changeset viewer.