Changeset 4677


Ignore:
Timestamp:
11/08/03 16:09:17 (20 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r4676 r4677  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.15 2003-11-08 14:41:21 piso Exp $
     4;;; $Id: jvm.lisp,v 1.16 2003-11-08 16:09:17 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
    … …  
    464464
    465465(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
    466 
    467466(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
    468467(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
    469 
    470468(defconstant +lisp-string+ "Lorg/armedbear/lisp/LispString;")
    471 
     469(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
    472470(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
    473471
    … …  
    504502    (setf *thread-var-initialized* t)))
    505503
     504(defun emit-invokevirtual (class-name method-name descriptor)
     505  (emit 'invokevirtual class-name method-name descriptor))
     506
    506507(defun emit-clear-values ()
    507508  (ensure-thread-var-initialized)
    508509  (emit 'aload *thread*)
    509   (emit 'invokevirtual
    510         +lisp-thread-class+
    511         "clearValues"
    512         "()V"))
     510;;   (emit 'invokevirtual
     511;;         +lisp-thread-class+
     512;;         "clearValues"
     513;;         "()V"))
     514  (emit-invokevirtual +lisp-thread-class+ "clearValues" "()V"))
    513515
    514516(defun emit-invoke-method (method-name)
    515517  (unless (remove-store-value)
    516518    (emit-push-value))
    517   (emit 'invokevirtual
    518         +lisp-object-class+
    519         method-name
    520         "()Lorg/armedbear/lisp/LispObject;")
     519  (emit-invokevirtual +lisp-object-class+
     520                      method-name
     521                      "()Lorg/armedbear/lisp/LispObject;")
    521522  (emit-store-value))
    522523
    … …  
    626627  (map 'vector #'resolve-args code))
    627628
    628 (defun is-branch-opcode (opcode)
     629(defun branch-opcode-p (opcode)
    629630  (member opcode
    630631    '(153 ; IFEQ
    … …  
    635636      )))
    636637
     638(defun analyze-stack (code)
     639  (require-type code vector)
     640  )
     641
    637642;; CODE is a list of INSTRUCTIONs.
    638643(defun code-bytes (code)
    … …  
    650655;;     (dotimes (i (length code))
    651656;;       (let ((instruction (svref code i)))
    652 ;;         (when (is-branch-opcode (instruction-opcode instruction))
     657;;         (when (branch-opcode-p (instruction-opcode instruction))
    653658;;           (push branch-targets (car (instruction-args instruction))))))
    654659;;     (format t "branch-targets = ~S~%" branch-targets)
    … …  
    696701      (dotimes (i (length code))
    697702        (let ((instruction (aref code i)))
    698 ;;           (case (instruction-opcode instruction)
    699 ;;             ((153 ; IFEQ
    700 ;;               154 ; IFNE
    701 ;;               166 ; IF_ACMPNE
    702 ;;               165 ; IF_ACMPEQ
    703 ;;               167 ; GOTO
    704 ;;               )
    705           (when (is-branch-opcode (instruction-opcode instruction))
     703          (when (branch-opcode-p (instruction-opcode instruction))
    706704            (let* ((label (car (instruction-args instruction)))
    707705                   (offset (- (symbol-value `,label) index)))
    … …  
    709707          (unless (= (instruction-opcode instruction) 202) ; LABEL
    710708            (incf index (opcode-size (instruction-opcode instruction)))))))
     709
    711710    ;; FIXME Do stack analysis here!
    712     ;; Convert list to vector.
    713     (let ((vector (make-array length))
     711    (analyze-stack code)
     712
     713    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
     714    (let ((bytes (make-array length))
    714715          (index 0))
    715716      (dotimes (i (length code))
    716717        (let ((instruction (aref code i)))
    717718          (unless (= (instruction-opcode instruction) 202) ; LABEL
    718             (setf (svref vector index) (instruction-opcode instruction))
     719            (setf (svref bytes index) (instruction-opcode instruction))
    719720            (incf index)
    720721            (dolist (byte (instruction-args instruction))
    721               (setf (svref vector index) byte)
     722              (setf (svref bytes index) byte)
    722723              (incf index)))))
    723       vector)))
     724      bytes)))
    724725
    725726(defun write-u1 (n)
    … …  
    914915                     "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;")))
    915916        (declare-field f "Lorg/armedbear/lisp/LispObject;")
    916         (emit 'invokevirtual
    917               "org/armedbear/lisp/Symbol"
    918               "getSymbolFunctionOrDie"
    919               "()Lorg/armedbear/lisp/LispObject;")
     917        (emit-invokevirtual +lisp-symbol-class+
     918                            "getSymbolFunctionOrDie"
     919                            "()Lorg/armedbear/lisp/LispObject;")
    920920        (emit 'putstatic
    921921              *this-class*
    … …  
    10811081  (unless (remove-store-value)
    10821082    (emit-push-value))
    1083   (emit 'invokevirtual
    1084         "org/armedbear/lisp/LispObject"
    1085         op
    1086         "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
     1083  (emit-invokevirtual +lisp-object-class+
     1084                      op
     1085                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
    10871086  (emit-store-value))
    10881087
    … …  
    12661265              g
    12671266              "Lorg/armedbear/lisp/Symbol;"))
    1268       (emit 'invokevirtual
    1269             "org/armedbear/lisp/Symbol"
    1270             "getSymbolFunctionOrDie"
    1271             "()Lorg/armedbear/lisp/LispObject;")))
     1267      (emit-invokevirtual +lisp-symbol-class+
     1268                          "getSymbolFunctionOrDie"
     1269                          "()Lorg/armedbear/lisp/LispObject;")))
    12721270    (case numargs
    12731271      (0
    1274        (emit 'invokevirtual
    1275              "org/armedbear/lisp/LispObject"
    1276              "execute"
    1277              "()Lorg/armedbear/lisp/LispObject;"))
     1272       (emit-invokevirtual +lisp-object-class+
     1273                           "execute"
     1274                           "()Lorg/armedbear/lisp/LispObject;"))
    12781275      (1
    12791276       (compile-form (first args))
    12801277       (unless (remove-store-value)
    12811278         (emit-push-value))
    1282        (emit 'invokevirtual
    1283              "org/armedbear/lisp/LispObject"
    1284              "execute"
    1285              "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
     1279       (emit-invokevirtual +lisp-object-class+
     1280                           "execute"
     1281                           "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
    12861282      (2
    12871283       (compile-form (first args))
    … …  
    12911287       (unless (remove-store-value)
    12921288         (emit-push-value))
    1293        (emit 'invokevirtual
    1294              "org/armedbear/lisp/LispObject"
    1295              "execute"
    1296              "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
     1289       (emit-invokevirtual +lisp-object-class+
     1290                           "execute"
     1291                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
    12971292      (3
    12981293       (compile-form (first args))
    … …  
    13051300       (unless (remove-store-value)
    13061301         (emit-push-value))
    1307        (emit 'invokevirtual
    1308              "org/armedbear/lisp/LispObject"
    1309              "execute"
    1310              "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
     1302       (emit-invokevirtual +lisp-object-class+
     1303                           "execute"
     1304                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
    13111305      (t
    13121306       (emit 'sipush (length args))
    … …  
    13221316           (incf i))) ; array left on stack here
    13231317       ;; Stack: function array-ref
    1324        (emit 'invokevirtual
    1325              "org/armedbear/lisp/LispObject"
    1326              "execute"
    1327              "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")))
     1318       (emit-invokevirtual +lisp-object-class+
     1319                           "execute"
     1320                           "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")))
    13281321    (if for-effect
    13291322        (emit 'pop)
    … …  
    13591352             (unless (remove-store-value)
    13601353               (emit-push-value))
    1361              (emit 'invokevirtual
    1362                    +lisp-object-class+
    1363                    s
    1364                    "()Z")
     1354             (emit-invokevirtual +lisp-object-class+
     1355                                 s
     1356                                 "()Z")
    13651357             (return-from compile-test 'ifeq))))
    13661358      (3 (when (eq (car form) 'EQ)
    … …  
    13901382             (unless (remove-store-value)
    13911383               (emit-push-value))
    1392              (emit 'invokevirtual
    1393                    +lisp-object-class+
    1394                    s
    1395                    "(Lorg/armedbear/lisp/LispObject;)Z")
     1384             (emit-invokevirtual +lisp-object-class+
     1385                                 s
     1386                                 "(Lorg/armedbear/lisp/LispObject;)Z")
    13961387             (return-from compile-test 'ifeq))))))
    13971388  ;; Otherwise...
    … …  
    14451436      (ensure-thread-var-initialized)
    14461437      (emit 'aload *thread*)
    1447       (emit 'invokevirtual
    1448             +lisp-thread-class+
    1449             "getDynamicEnvironment"
    1450             "()Lorg/armedbear/lisp/Environment;")
     1438      (emit-invokevirtual +lisp-thread-class+
     1439                          "getDynamicEnvironment"
     1440                          "()Lorg/armedbear/lisp/Environment;")
    14511441      (emit 'astore env-var))
    14521442    (ecase (car form)
    … …  
    14641454      (emit 'aload *thread*)
    14651455      (emit 'aload env-var)
    1466       (emit 'invokevirtual
    1467             +lisp-thread-class+
    1468             "setDynamicEnvironment"
    1469             "(Lorg/armedbear/lisp/Environment;)V"))
     1456      (emit-invokevirtual +lisp-thread-class+
     1457                          "setDynamicEnvironment"
     1458                          "(Lorg/armedbear/lisp/Environment;)V"))
    14701459    ;; Restore fill pointer to its saved value so the slots used by these
    14711460    ;; bindings will again be available.
    … …  
    16831672                    g
    16841673                    "Lorg/armedbear/lisp/Symbol;")
    1685               (emit 'invokevirtual
    1686                     +lisp-object-class+
    1687                     "getSymbolFunctionOrDie"
    1688                     "()Lorg/armedbear/lisp/LispObject;")
     1674              (emit-invokevirtual +lisp-object-class+
     1675                                  "getSymbolFunctionOrDie"
     1676                                  "()Lorg/armedbear/lisp/LispObject;")
    16891677              (emit-store-value)))
    16901678           #+nil
    … …  
    17761764          g
    17771765          "Lorg/armedbear/lisp/Symbol;")
    1778     (emit 'invokevirtual
    1779           "org/armedbear/lisp/Symbol"
    1780           "symbolValue"
    1781           "()Lorg/armedbear/lisp/LispObject;")
     1766    (emit-invokevirtual +lisp-symbol-class+
     1767                        "symbolValue"
     1768                        "()Lorg/armedbear/lisp/LispObject;")
    17821769    (emit-store-value)
    17831770    (return-from compile-variable-ref)))
    … …  
    19011888      (emit 'aload_0)
    19021889      (emit 'aload_1)
    1903       (emit 'invokevirtual
    1904             *this-class*
    1905             "processArgs"
    1906             "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;")
     1890      (emit-invokevirtual *this-class*
     1891                          "processArgs"
     1892                          "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;")
    19071893      (emit 'astore_1))
    19081894    (dolist (f body)
Note: See TracChangeset for help on using the changeset viewer.