Ignore:
Timestamp:
02/03/05 23:16:43 (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

    r8456 r8458  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.388 2005-02-03 20:36:46 piso Exp $
     4;;; $Id: jvm.lisp,v 1.389 2005-02-03 23:16:43 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    14851485           (vector-push-extend (resolve-instruction instruction) vector)))))))
    14861486
    1487 (defconstant +branch-opcodes+
    1488   '(153 ; IFEQ
    1489     154 ; IFNE
    1490     155 ; IFLT
    1491     156 ; IFGE
    1492     157 ; IFGT
    1493     158 ; IFLE
    1494     159 ; IF_ICMPEQ
    1495     160 ; IF_ICMPNE
    1496     161 ; IF_ICMPLT
    1497     162 ; IF_ICMPGE
    1498     163 ; IF_ICMPGT
    1499     164 ; IF_ICMPLE
    1500     165 ; IF_ACMPEQ
    1501     166 ; IF_ACMPNE
    1502     167 ; GOTO
    1503     168 ; JSR
    1504     198 ; IFNULL
    1505     ))
    1506 
    1507 (defsubst branch-opcode-p (opcode)
     1487;; (defconstant +branch-opcodes+
     1488;;   '(153 ; IFEQ
     1489;;     154 ; IFNE
     1490;;     155 ; IFLT
     1491;;     156 ; IFGE
     1492;;     157 ; IFGT
     1493;;     158 ; IFLE
     1494;;     159 ; IF_ICMPEQ
     1495;;     160 ; IF_ICMPNE
     1496;;     161 ; IF_ICMPLT
     1497;;     162 ; IF_ICMPGE
     1498;;     163 ; IF_ICMPGT
     1499;;     164 ; IF_ICMPLE
     1500;;     165 ; IF_ACMPEQ
     1501;;     166 ; IF_ACMPNE
     1502;;     167 ; GOTO
     1503;;     168 ; JSR
     1504;;     198 ; IFNULL
     1505;;     ))
     1506
     1507(defun branch-opcode-p (opcode)
    15081508  (declare (optimize speed))
    1509   (member opcode +branch-opcodes+))
     1509;;   (member opcode +branch-opcodes+)
     1510  (or (<= 153 opcode 168)
     1511      (= opcode 198)))
    15101512
    15111513(defun walk-code (code start-index depth)
     
    17521754      t)))
    17531755
    1754 (defun optimize-2a ()
     1756(defun hash-labels (code)
     1757  (let ((ht (make-hash-table :test 'eq))
     1758        (code (coerce code 'list))
     1759        (pending-label nil))
     1760    (dolist (instruction code)
     1761      (when pending-label
     1762        (setf (gethash pending-label ht) instruction)
     1763        (setf pending-label nil))
     1764      (when (label-p instruction)
     1765        (setf pending-label (instruction-label instruction))))
     1766    ht))
     1767
     1768;; (defun optimize-2a ()
     1769;;   (let* ((code (coerce *code* 'list))
     1770;;          (tail code)
     1771;;          (changed nil))
     1772;;     (dolist (instruction code)
     1773;;       (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
     1774;;         (let* ((target-label (car (instruction-args instruction)))
     1775;;                (target-instruction nil)
     1776;;                (next-instruction nil))
     1777;;           (dolist (instr code)
     1778;;             (when target-instruction
     1779;;               (setf next-instruction instr)
     1780;;               (return))
     1781;;             (when (and instr
     1782;;                        (label-p instr)
     1783;;                        (eq (car (instruction-args instr)) target-label))
     1784;;               (setf target-instruction instr)))
     1785;;           (when next-instruction
     1786;;             (case (instruction-opcode next-instruction)
     1787;;               (167 ; GOTO
     1788;;                (setf (instruction-args instruction)
     1789;;                      (instruction-args next-instruction)
     1790;;                      changed t))
     1791;;               (176 ; ARETURN
     1792;;                (setf (instruction-opcode instruction) 176
     1793;;                      (instruction-args instruction) nil
     1794;;                      changed t)))))))
     1795;;     (when changed
     1796;;       (setf *code* (delete nil code))
     1797;;       t)))
     1798
     1799(defun optimize-2b ()
    17551800  (let* ((code (coerce *code* 'list))
    1756          (tail code)
     1801         (ht (hash-labels code))
    17571802         (changed nil))
    17581803    (dolist (instruction code)
    17591804      (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
    17601805        (let* ((target-label (car (instruction-args instruction)))
    1761                (target-instruction nil)
    1762                (next-instruction nil))
    1763           (dolist (instr code)
    1764             (when target-instruction
    1765               (setf next-instruction instr)
    1766               (return))
    1767             (when (and instr
    1768                        (label-p instr)
    1769                        (eq (car (instruction-args instr)) target-label))
    1770               (setf target-instruction instr)))
     1806               (next-instruction (gethash target-label ht)))
    17711807          (when next-instruction
    17721808            (case (instruction-opcode next-instruction)
     
    18521888        (setf changed-p (or (optimize-1) changed-p))
    18531889        (setf changed-p (or (optimize-2) changed-p))
    1854         (setf changed-p (or (optimize-2a) changed-p))
     1890        (setf changed-p (or (optimize-2b) changed-p))
    18551891        (setf changed-p (or (optimize-3) changed-p))
    18561892        (setf changed-p (or (delete-unreachable-code) changed-p))
     
    18651901(defun code-bytes (code)
    18661902  (let ((length 0))
    1867 ;;     (declare (type fixnum length))
     1903    (declare (type fixnum length))
    18681904    ;; Pass 1: calculate label offsets and overall length.
    1869     (dotimes (i (length code))
     1905    (dotimes (i (the fixnum (length code)))
    18701906      (declare (type fixnum i))
    18711907      (let* ((instruction (aref code i))
     
    46464682(defun compile-special-reference (name target representation)
    46474683  (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+)
    4648   (emit-push-current-thread)
    4649   (emit-invokevirtual +lisp-symbol-class+ "symbolValue"
    4650                       (list +lisp-thread+) +lisp-object+)
     4684  (cond ((constantp name)
     4685         ;; "... a reference to a symbol declared with DEFCONSTANT always
     4686         ;; refers to its global value."
     4687         (emit-invokevirtual +lisp-symbol-class+ "getSymbolValue"
     4688                             nil +lisp-object+))
     4689        (t
     4690         (emit-push-current-thread)
     4691         (emit-invokevirtual +lisp-symbol-class+ "symbolValue"
     4692                             (list +lisp-thread+) +lisp-object+)))
    46514693  (when (eq representation :unboxed-fixnum)
    46524694    (emit-unbox-fixnum))
Note: See TracChangeset for help on using the changeset viewer.