Changeset 12838


Ignore:
Timestamp:
07/31/10 18:24:34 (13 years ago)
Author:
ehuelsmann
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12832 r12838  
    443443(defparameter *descriptors* (make-hash-table :test #'equal))
    444444
    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     `(progn
    450        (%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 #+nil
    457 (defmacro defsubst (&rest args)
    458   `(defun ,@args))
    459 
    460 
    461445(declaim (ftype (function (t t) cons) get-descriptor-info))
    462446(defun get-descriptor-info (arg-types return-type)
     
    470454        (setf (gethash key ht) (make-descriptor-info arg-types return-type)))))
    471455
    472 (defsubst get-descriptor (arg-types return-type)
     456(declaim (inline get-descriptor))
     457(defun get-descriptor (arg-types return-type)
    473458  (car (get-descriptor-info arg-types return-type)))
    474459
     
    479464         (stack-effect (cdr info))
    480465         (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))))
    482468    (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
    483513
    484514(defknown pretty-java-type (t) string)
     
    644674        (return-from common-representation result)))))
    645675
    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         (t
    657          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-name
    674                   (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))))
    686676
    687677;; Index of local variable used to hold the current thread.
     
    11971187;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
    11981188(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)
    12041191
    12051192;; ldc
Note: See TracChangeset for help on using the changeset viewer.