Changeset 8388


Ignore:
Timestamp:
01/23/05 16:50:39 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8387 r8388  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.364 2005-01-23 03:23:35 piso Exp $
     4;;; $Id: jvm.lisp,v 1.365 2005-01-23 16:50:39 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    888888      (emit 'ldc (pool-int n))))
    889889
     890(defun make-descriptor-info (arg-types return-type)
     891  (let ((descriptor (with-output-to-string (s)
     892                      (princ #\( s)
     893                      (dolist (type arg-types)
     894                        (princ type s))
     895                      (princ #\) s)
     896                      (princ (or return-type "V") s)))
     897        (stack-effect (let ((result (cond ((null return-type) 0)
     898                                          ((equal return-type "J") 2)
     899                                          (t 1))))
     900                        (dolist (type arg-types result)
     901                          (decf result (if (equal type "J") 2 1))))))
     902    (cons descriptor stack-effect)))
     903
    890904(defparameter *descriptors* (make-hash-table :test #'equal))
    891905
    892 (defun make-descriptor (arg-types return-type)
     906(defun get-descriptor-info (arg-types return-type)
    893907  (let* ((key (list arg-types return-type))
    894          (descriptor (gethash key *descriptors*)))
    895     (or descriptor
     908         (descriptor-info (gethash key *descriptors*)))
     909    (or descriptor-info
    896910        (setf (gethash key *descriptors*)
    897               (with-output-to-string (s)
    898                 (princ #\( s)
    899                 (dolist (type arg-types)
    900                   (princ type s))
    901                 (princ #\) s)
    902                 (princ (or return-type "V") s))))))
    903 
    904 (defun %emit-invokestatic (class-name method-name descriptor stack)
    905   (let ((instruction (emit 'invokestatic class-name method-name descriptor)))
    906     (setf (instruction-stack instruction) stack)))
    907 
    908 ;; FIXME
    909 ;; The way we calculate the stack effect here assumes that each argument
    910 ;; occupies one slot. This is NOT CORRECT for Java longs ("J")!
     911              (make-descriptor-info arg-types return-type)))))
     912
     913(defsubst get-descriptor (arg-types return-type)
     914  (car (get-descriptor-info arg-types return-type)))
     915
    911916(defun emit-invokestatic (class-name method-name arg-types return-type)
    912   (let* ((descriptor (make-descriptor arg-types return-type))
    913          (stack (- (if return-type 1 0) (length arg-types)))
    914          (instruction (emit 'invokestatic
    915                            class-name method-name descriptor)))
    916     (setf (instruction-stack instruction) stack)))
    917 
    918 ;; FIXME
    919 ;; The way we calculate the stack effect here assumes that each argument
    920 ;; occupies one slot. This is NOT CORRECT for Java longs ("J")!
     917  (let* ((info (get-descriptor-info arg-types return-type))
     918         (descriptor (car info))
     919         (stack-effect (cdr info))
     920         (instruction (emit 'invokestatic class-name method-name descriptor)))
     921    (setf (instruction-stack instruction) stack-effect)))
     922
    921923(defun emit-invokevirtual (class-name method-name arg-types return-type)
    922   (let* ((descriptor (make-descriptor arg-types return-type))
    923          (stack (- (if return-type 1 0) 1 (length arg-types)))
     924  (let* ((info (get-descriptor-info arg-types return-type))
     925         (descriptor (car info))
     926         (stack-effect (cdr info))
    924927         (instruction (emit 'invokevirtual class-name method-name descriptor)))
    925     (setf (instruction-stack instruction) stack)))
     928    (setf (instruction-stack instruction) (1- stack-effect))))
    926929
    927930(defun emit-invokespecial-init (class-name arg-types)
    928   (let* ((descriptor (make-descriptor arg-types nil))
    929          (stack (- (1+ (length arg-types))))
     931  (let* ((info (get-descriptor-info arg-types nil))
     932         (descriptor (car info))
     933         (stack-effect (cdr info))
    930934         (instruction (emit 'invokespecial class-name "<init>" descriptor)))
    931     (setf (instruction-stack instruction) stack)))
     935    (setf (instruction-stack instruction) (1- stack-effect))))
    932936
    933937;; Index of local variable used to hold the current thread.
     
    11281132(defun emit-box-long ()
    11291133  (declare (optimize speed))
    1130 ;;   (emit-invokestatic +lisp-class+ "number" (list "J") +lisp-object+)
    1131   (%emit-invokestatic +lisp-class+ "number"
    1132                       (make-descriptor (list "J") +lisp-object+)
    1133                       -1))
     1134  (emit-invokestatic +lisp-class+ "number" (list "J") +lisp-object+))
    11341135
    11351136;; Expects value on stack.
     
    11671168
    11681169(defun unsupported-opcode (instruction)
    1169   (error "Unsupported opcode ~D."
    1170          (instruction-opcode instruction)))
     1170  (error "Unsupported opcode ~D." (instruction-opcode instruction)))
    11711171
    11721172(dotimes (n (1+ *last-opcode*))
     
    48054805        (return-from analyze-args
    48064806                     (if *closure-variables*
    4807                          (make-descriptor (list +lisp-object-array+ +lisp-object-array+)
     4807                         (get-descriptor (list +lisp-object-array+ +lisp-object-array+)
    48084808                                          +lisp-object+)
    4809                          (make-descriptor (list +lisp-object-array+)
     4809                         (get-descriptor (list +lisp-object-array+)
    48104810                                          +lisp-object+))))
    48114811      (cond
     
    48134813        (return-from analyze-args
    48144814                     (cond ((<= arg-count 4)
    4815                             (make-descriptor (list* +lisp-object-array+
     4815                            (get-descriptor (list* +lisp-object-array+
    48164816                                                    (make-list arg-count :initial-element +lisp-object+))
    48174817                                             +lisp-object+))
    48184818                           (t (setf *using-arg-array* t)
    48194819                              (setf *arity* arg-count)
    4820                               (make-descriptor (list +lisp-object-array+ +lisp-object-array+)
     4820                              (get-descriptor (list +lisp-object-array+ +lisp-object-array+)
    48214821                                               +lisp-object+)))))
    48224822       (t
    48234823        (return-from analyze-args
    48244824                     (cond ((<= arg-count 4)
    4825                             (make-descriptor (make-list arg-count :initial-element +lisp-object+)
     4825                            (get-descriptor (make-list arg-count :initial-element +lisp-object+)
    48264826                                             +lisp-object+))
    48274827                           (t (setf *using-arg-array* t)
    48284828                              (setf *arity* arg-count)
    4829                               (make-descriptor (list +lisp-object-array+)
     4829                              (get-descriptor (list +lisp-object-array+)
    48304830                                               +lisp-object+)))))))
    48314831    (when (or (memq '&KEY args)
     
    48354835      (setf *hairy-arglist-p* t)
    48364836      (return-from analyze-args
    4837                    (make-descriptor (list +lisp-object-array+) +lisp-object+)))
     4837                   (get-descriptor (list +lisp-object-array+) +lisp-object+)))
    48384838    (cond ((<= arg-count 4)
    4839            (make-descriptor (make-list (length args) :initial-element +lisp-object+)
     4839           (get-descriptor (make-list (length args) :initial-element +lisp-object+)
    48404840                            +lisp-object+))
    48414841          (t
    48424842           (setf *using-arg-array* t)
    48434843           (setf *arity* arg-count)
    4844            (make-descriptor (list +lisp-object-array+) +lisp-object+)))))
     4844           (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
    48454845
    48464846(defun write-class-file (args execute-method classfile)
Note: See TracChangeset for help on using the changeset viewer.