Changeset 12786


Ignore:
Timestamp:
07/06/10 21:24:56 (11 years ago)
Author:
ehuelsmann
Message:

First step of integration of CLASS-NAME structure in pass2.

Location:
branches/generic-class-file/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r12764 r12786  
    201201(defconstant +fasl-loader-class+
    202202  "org/armedbear/lisp/FaslClassLoader")
    203 (defconstant +java-string+ "Ljava/lang/String;")
    204 (defconstant +java-object+ "Ljava/lang/Object;")
    205 (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
    206 (defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil")
    207203(defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass")
    208204(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
     
    262258(defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;")
    263259
     260(defun !class-name (class-name)
     261  "To be eliminated when all hard-coded strings are replaced by `class-name'
     262structures"
     263  (if (typep class-name 'class-name)
     264      (class-name-internal class-name)
     265      class-name))
     266
     267(defun !class-ref (class-name)
     268  "To be eliminated when all hard-coded strings are
     269replaced by `class-name' structures"
     270  (if (typep class-name 'class-name)
     271      (class-ref class-name)
     272      class-name))
     273
    264274(defstruct (instruction (:constructor %make-instruction (opcode args)))
    265275  (opcode 0 :type (integer 0 255))
     
    343353(declaim (inline emit-push-nil))
    344354(defun emit-push-nil ()
    345   (emit 'getstatic +lisp-class+ "NIL" +lisp-object+))
     355  (emit 'getstatic +lisp+ "NIL" +lisp-object+))
    346356
    347357(defknown emit-push-nil-symbol () t)
    348358(declaim (inline emit-push-nil-symbol))
    349359(defun emit-push-nil-symbol ()
    350   (emit 'getstatic +lisp-nil-class+ "NIL" +lisp-symbol+))
     360  (emit 'getstatic +lisp-nil+ "NIL" +lisp-symbol+))
    351361
    352362(defknown emit-push-t () t)
    353363(declaim (inline emit-push-t))
    354364(defun emit-push-t ()
    355   (emit 'getstatic +lisp-class+ "T" +lisp-symbol+))
     365  (emit 'getstatic +lisp+ "T" +lisp-symbol+))
    356366
    357367(defknown emit-push-false (t) t)
     
    495505(declaim (ftype (function (t t) cons) get-descriptor-info))
    496506(defun get-descriptor-info (arg-types return-type)
    497   (let* ((key (list arg-types return-type))
     507  (let* ((arg-types (mapcar #'!class-ref arg-types))
     508         (return-type (!class-ref return-type))
     509         (key (list arg-types return-type))
    498510         (ht *descriptors*)
    499511         (descriptor-info (gethash1 key ht)))
     
    510522         (descriptor (car info))
    511523         (stack-effect (cdr info))
     524         (class-name (!class-name class-name))
    512525         (instruction (emit 'invokestatic class-name method-name descriptor)))
    513526    (setf (instruction-stack instruction) stack-effect)))
     
    575588(defknown emit-unbox-boolean () t)
    576589(defun emit-unbox-boolean ()
    577   (emit 'instanceof +lisp-nil-class+)
     590  (emit 'instanceof +lisp-nil+)
    578591  (emit 'iconst_1)
    579592  (emit 'ixor))  ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit
     
    693706         (descriptor (car info))
    694707         (stack-effect (cdr info))
     708         (class-name (!class-name class-name))
    695709         (instruction (emit 'invokevirtual class-name method-name descriptor)))
    696710    (declare (type (signed-byte 8) stack-effect))
     
    710724         (descriptor (car info))
    711725         (stack-effect (cdr info))
     726         (class-name (!class-name class-name))
    712727         (instruction (emit 'invokespecial class-name "<init>" descriptor)))
    713728    (declare (type (signed-byte 8) stack-effect))
     
    785800    (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name
    786801          +lisp-symbol+)
    787     (emit-invokestatic +lisp-class+ "type_error"
     802    (emit-invokestatic +lisp+ "type_error"
    788803                       (lisp-object-arg-types 2) +lisp-object+)
    789804    (emit 'pop) ; Needed for JVM stack consistency.
     
    843858  (unless (> *speed* *safety*)
    844859    (let ((label1 (gensym)))
    845       (emit 'getstatic +lisp-class+ "interrupted" "Z")
     860      (emit 'getstatic +lisp+ "interrupted" "Z")
    846861      (emit 'ifeq label1)
    847       (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil)
     862      (emit-invokestatic +lisp+ "handleInterrupt" nil nil)
    848863      (label label1))))
    849864
     
    12081223(define-resolver (178 179) (instruction)
    12091224  (let* ((args (instruction-args instruction))
    1210          (index (pool-field (first args) (second args) (third args))))
     1225         (index (pool-field (!class-name (first args))
     1226                            (second args) (third args))))
    12111227    (inst (instruction-opcode instruction) (u2 index))))
    12121228
     
    12261242(define-resolver (182 183 184) (instruction)
    12271243  (let* ((args (instruction-args instruction))
    1228          (index (pool-method (first args) (second args) (third args))))
     1244         (index (pool-method (!class-name (first args))
     1245                             (second args) (third args))))
    12291246    (setf (instruction-args instruction) (u2 index))
    12301247    instruction))
     
    12491266(define-resolver (180 181) (instruction)
    12501267  (let* ((args (instruction-args instruction))
    1251          (index (pool-field (first args) (second args) (third args))))
     1268         (index (pool-field (!class-name (first args))
     1269                            (second args) (third args))))
    12521270    (inst (instruction-opcode instruction) (u2 index))))
    12531271
     
    12551273(define-resolver (187 189 192 193) (instruction)
    12561274  (let* ((args (instruction-args instruction))
    1257          (index (pool-class (first args))))
     1275         (index (pool-class (!class-name (first args)))))
    12581276    (inst (instruction-opcode instruction) (u2 index))))
    12591277
     
    17741792         (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name))))
    17751793         (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name)))))
    1776          (emit-invokestatic +lisp-class+ "internInPackage"
    1777                             (list +java-string+ +java-string+) +lisp-symbol+))
     1794         (emit-invokestatic +lisp+ "internInPackage"
     1795                            (list +java-string+ +java-string+)
     1796                            +lisp-symbol+))
    17781797        (t
    17791798         ;; No name.
     
    17861805             (s (sys::%format nil "~S" lambda-list)))
    17871806        (emit 'ldc (pool-string s))
    1788         (emit-invokestatic +lisp-class+ "readObjectFromString"
     1807        (emit-invokestatic +lisp+ "readObjectFromString"
    17891808                           (list +java-string+) +lisp-object+))
    17901809      (emit-push-nil)))
     
    18561875                   (progn
    18571876                     (emit 'ldc (pool-string (symbol-name keyword)))
    1858                      (emit-invokestatic +lisp-class+ "internKeyword"
     1877                     (emit-invokestatic +lisp+ "internKeyword"
    18591878                                        (list +java-string+) +lisp-symbol+))
    18601879                   ;; symbol is not really a keyword; yes, that's allowed!
     
    18631882                     (emit 'ldc (pool-string
    18641883                                 (package-name (symbol-package keyword))))
    1865                      (emit-invokestatic +lisp-class+ "internInPackage"
     1884                     (emit-invokestatic +lisp+ "internInPackage"
    18661885                                        (list +java-string+ +java-string+)
    18671886                                        +lisp-symbol+))))
     
    20942113  (emit 'ldc (pool-string (concatenate 'string "#.(FIND-PACKAGE \""
    20952114                                       (package-name pkg) "\")")))
    2096   (emit-invokestatic +lisp-class+ "readObjectFromString"
     2115  (emit-invokestatic +lisp+ "readObjectFromString"
    20972116                     (list +java-string+) +lisp-object+))
    20982117
     
    21032122             (dump-form object stream))))
    21042123    (emit 'ldc (pool-string s))
    2105     (emit-invokestatic +lisp-class+ "readObjectFromString"
     2124    (emit-invokestatic +lisp+ "readObjectFromString"
    21062125                       (list +java-string+) +lisp-object+)))
    21072126
     
    21212140      ((keywordp symbol)
    21222141       (emit 'ldc (pool-string (symbol-name symbol)))
    2123        (emit-invokestatic +lisp-class+ "internKeyword"
     2142       (emit-invokestatic +lisp+ "internKeyword"
    21242143                          (list +java-string+) +lisp-symbol+))
    21252144      (t
    21262145       (emit 'ldc (pool-string (symbol-name symbol)))
    21272146       (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    2128        (emit-invokestatic +lisp-class+ "internInPackage"
     2147       (emit-invokestatic +lisp+ "internInPackage"
    21292148                          (list +java-string+ +java-string+)
    21302149                          +lisp-symbol+)))))
     
    21902209           (remember field-name object)
    21912210           (emit 'ldc (pool-string field-name))
    2192            (emit-invokestatic +lisp-class+ "recall"
     2211           (emit-invokestatic +lisp+ "recall"
    21932212                              (list +java-string+) +lisp-object+)
    21942213           (when (string/= field-type +lisp-object+)
     
    23082327      (declare-field g +lisp-object+ +field-access-private+)
    23092328      (emit 'ldc (pool-string s))
    2310       (emit-invokestatic +lisp-class+ "readObjectFromString"
     2329      (emit-invokestatic +lisp+ "readObjectFromString"
    23112330                         (list +java-string+) +lisp-object+)
    23122331      (emit 'putstatic *this-class* g +lisp-object+)
     
    23282347      (declare-field g +lisp-object+ +field-access-private+)
    23292348      (emit 'ldc (pool-string s))
    2330       (emit-invokestatic +lisp-class+ "readObjectFromString"
     2349      (emit-invokestatic +lisp+ "readObjectFromString"
    23312350                         (list +java-string+) +lisp-object+)
    2332       (emit-invokestatic +lisp-class+ "loadTimeValue"
     2351      (emit-invokestatic +lisp+ "loadTimeValue"
    23332352                         (lisp-object-arg-types 1) +lisp-object+)
    23342353      (emit 'putstatic *this-class* g +lisp-object+)
     
    23532372      (declare-field g obj-ref +field-access-private+)
    23542373      (emit 'ldc (pool-string g))
    2355       (emit-invokestatic +lisp-class+ "recall"
     2374      (emit-invokestatic +lisp+ "recall"
    23562375                         (list +java-string+) +lisp-object+)
    23572376      (when (and obj-class (string/= obj-class +lisp-object-class+))
     
    27072726           (compile-form arg1 'stack nil)
    27082727           (compile-form arg2 'stack nil)
    2709            (emit-invokestatic +lisp-class+ "memq"
     2728           (emit-invokestatic +lisp+ "memq"
    27102729                              (lisp-object-arg-types 2) "Z")
    27112730           (emit-move-from-stack target representation)))
     
    27242743           (compile-form arg2 'stack nil)
    27252744           (cond ((eq type1 'SYMBOL) ; FIXME
    2726                   (emit-invokestatic +lisp-class+ "memq"
     2745                  (emit-invokestatic +lisp+ "memq"
    27272746                                     (lisp-object-arg-types 2) "Z"))
    27282747                 (t
    2729                   (emit-invokestatic +lisp-class+ "memql"
     2748                  (emit-invokestatic +lisp+ "memql"
    27302749                                     (lisp-object-arg-types 2) "Z")))
    27312750           (emit-move-from-stack target representation)))
     
    27362755  (cond ((and (null representation) (null (cdr form)))
    27372756         (emit-push-current-thread)
    2738          (emit-invokestatic +lisp-class+ "gensym"
     2757         (emit-invokestatic +lisp+ "gensym"
    27392758                            (list +lisp-thread+) +lisp-symbol+)
    27402759         (emit-move-from-stack target))
     
    27572776              (compile-form arg3 'stack nil)
    27582777              (maybe-emit-clear-values arg1 arg2 arg3)))
    2759        (emit-invokestatic +lisp-class+ "get"
     2778       (emit-invokestatic +lisp+ "get"
    27602779                          (lisp-object-arg-types (if arg3 3 2))
    27612780                          +lisp-object+)
     
    27792798                arg2 'stack nil
    27802799                arg3 'stack nil)
    2781          (emit-invokestatic +lisp-class+ "getf"
     2800         (emit-invokestatic +lisp+ "getf"
    27822801                            (lisp-object-arg-types 3) +lisp-object+)
    27832802         (fix-boxing representation nil)
     
    30853104               (emit 'checkcast +lisp-compiled-closure-class+)
    30863105               (duplicate-closure-array compiland)
    3087                (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     3106               (emit-invokestatic +lisp+ "makeCompiledClosure"
    30883107                                  (list +lisp-object+ +closure-binding-array+)
    30893108                                  +lisp-object+)))))
     
    35683587      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35693588             arg2 'stack nil)
    3570       (emit-invokestatic +lisp-class+ "memq"
     3589      (emit-invokestatic +lisp+ "memq"
    35713590                         (lisp-object-arg-types 2) "Z")
    35723591      'ifeq)))
     
    35783597      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35793598             arg2 'stack nil)
    3580       (emit-invokestatic +lisp-class+ "memql"
     3599      (emit-invokestatic +lisp+ "memql"
    35813600                         (lisp-object-arg-types 2) "Z")
    35823601      'ifeq)))
     
    38183837  (emit-clear-values)
    38193838  (compile-form (second form) 'stack nil)
    3820   (emit-invokestatic +lisp-class+ "multipleValueList"
     3839  (emit-invokestatic +lisp+ "multipleValueList"
    38213840                     (lisp-object-arg-types 1) +lisp-object+)
    38223841  (fix-boxing representation nil)
     
    38543873    (2
    38553874     (compile-form (second form) 'stack nil)
    3856      (emit-invokestatic +lisp-class+ "coerceToFunction"
     3875     (emit-invokestatic +lisp+ "coerceToFunction"
    38573876                        (lisp-object-arg-types 1) +lisp-object+)
    38583877     (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+))
     
    38643883       (aload function-register)
    38653884       (emit-push-current-thread)
    3866        (emit-invokestatic +lisp-class+ "multipleValueCall1"
     3885       (emit-invokestatic +lisp+ "multipleValueCall1"
    38673886                          (list +lisp-object+ +lisp-object+ +lisp-thread+)
    38683887                          +lisp-object+)))
     
    38733892            (values-register (allocate-register)))
    38743893       (compile-form (second form) 'stack nil)
    3875        (emit-invokestatic +lisp-class+ "coerceToFunction"
     3894       (emit-invokestatic +lisp+ "coerceToFunction"
    38763895                          (lisp-object-arg-types 1) +lisp-object+)
    38773896       (emit-move-from-stack function-register)
     
    45784597    (emit-push-variable (tagbody-id-variable tag-block))
    45794598    (emit-load-externalized-object (tag-label tag)) ; Tag.
    4580     (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2)
     4599    (emit-invokestatic +lisp+ "nonLocalGo" (lisp-object-arg-types 2)
    45814600                       +lisp-object+)
    45824601    ;; Following code will not be reached, but is needed for JVM stack
     
    46554674  ((check-arg-count form 1))
    46564675  (compile-forms-and-maybe-emit-clear-values (%cadr form) 'stack nil)
    4657   (emit-invokestatic +lisp-class+ "coerceToFunction"
     4676  (emit-invokestatic +lisp+ "coerceToFunction"
    46584677                     (lisp-object-arg-types 1) +lisp-object+)
    46594678  (emit-move-from-stack target))
     
    47484767    (emit-clear-values)
    47494768    (compile-form result-form 'stack nil)
    4750     (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3)
     4769    (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
    47514770                       +lisp-object+)
    47524771    ;; Following code will not be reached, but is needed for JVM stack
     
    48254844    ;; Compile call to Lisp.progvBindVars().
    48264845    (emit-push-current-thread)
    4827     (emit-invokestatic +lisp-class+ "progvBindVars"
     4846    (emit-invokestatic +lisp+ "progvBindVars"
    48284847                       (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
    48294848      ;; Implicit PROGN.
     
    49394958      (emit 'checkcast +lisp-compiled-closure-class+)
    49404959      (duplicate-closure-array parent)
    4941       (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     4960      (emit-invokestatic +lisp+ "makeCompiledClosure"
    49424961       (list +lisp-object+ +closure-binding-array+)
    49434962       +lisp-object+)))
     
    50325051          ((compiland-closure-register *current-compiland*)
    50335052           (duplicate-closure-array *current-compiland*)
    5034            (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     5053           (emit-invokestatic +lisp+ "makeCompiledClosure"
    50355054                              (list +lisp-object+ +closure-binding-array+)
    50365055                              +lisp-object+))
     
    50695088                 (emit 'checkcast +lisp-compiled-closure-class+)
    50705089                 (duplicate-closure-array *current-compiland*)
    5071                  (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     5090                 (emit-invokestatic +lisp+ "makeCompiledClosure"
    50725091                                    (list +lisp-object+ +closure-binding-array+)
    50735092                                    +lisp-object+)))))
     
    55265545     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    55275546                  arg2 'stack :int)
    5528            (emit-invokestatic +lisp-class+ "mod" '("I" "I") "I")
     5547           (emit-invokestatic +lisp+ "mod" '("I" "I") "I")
    55295548           (emit-move-from-stack target representation))
    55305549          ((fixnum-type-p type2)
     
    58215840           (compile-form arg2 'stack nil)
    58225841           (maybe-emit-clear-values arg1 arg2)
    5823            (emit-invokestatic +lisp-class+ "writeByte"
     5842           (emit-invokestatic +lisp+ "writeByte"
    58245843                              (list "I" +lisp-object+) nil)
    58255844           (when target
     
    74817500    (emit 'ifne LABEL1)
    74827501    (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+)
    7483     (emit-invokestatic +lisp-class+ "type_error"
     7502    (emit-invokestatic +lisp+ "type_error"
    74847503                       (lisp-object-arg-types 2) +lisp-object+)
    74857504    (label LABEL1))
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r12785 r12786  
    103103     ,documentation))
    104104
    105 (define-class-name +!java-object+ "java.lang.Object")
    106 (define-class-name +!java-string+ "java.lang.String")
     105(define-class-name +java-object+ "java.lang.Object")
     106(define-class-name +java-string+ "java.lang.String")
    107107(define-class-name +!lisp-object+ "org.armedbear.lisp.LispObject")
    108108(define-class-name +!lisp-simple-string+ "org.armedbear.lisp.SimpleString")
    109 (define-class-name +!lisp+ "org.armedbear.lisp.Lisp")
    110 (define-class-name +!lisp-nil+ "org.armedbear.lisp.Nil")
     109(define-class-name +lisp+ "org.armedbear.lisp.Lisp")
     110(define-class-name +lisp-nil+ "org.armedbear.lisp.Nil")
    111111(define-class-name +!lisp-class+ "org.armedbear.lisp.LispClass")
    112112(define-class-name +!lisp-symbol+ "org.armedbear.lisp.Symbol")
Note: See TracChangeset for help on using the changeset viewer.