Changeset 8456


Ignore:
Timestamp:
02/03/05 20:36:46 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

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

    r8455 r8456  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.387 2005-02-03 17:13:33 piso Exp $
     4;;; $Id: jvm.lisp,v 1.388 2005-02-03 20:36:46 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    16591659  (setf *code* (nreverse (coerce *code* 'vector))))
    16601660
    1661 (defun print-code()
     1661(defun print-code ()
    16621662  (dotimes (i (length *code*))
    1663     (let ((instruction (aref *code* i)))
     1663    (let ((instruction (elt *code* i)))
    16641664      (%format t "~D ~A ~S ~S ~S~%"
    16651665               i
     
    16691669               (instruction-depth instruction)))))
    16701670
    1671 (defun validate-labels (code)
    1672   (let ((code (coerce code 'list))
    1673         (i 0))
    1674     (dolist (instruction code)
    1675       (when (eql (instruction-opcode instruction) 202) ; LABEL
    1676         (let ((label (car (instruction-args instruction))))
    1677           (set label i)))
    1678       (incf i))))
     1671(defun print-code2 (code)
     1672  (dotimes (i (length code))
     1673    (let ((instruction (elt code i)))
     1674      (case (instruction-opcode instruction)
     1675        (202 ; LABEL
     1676         (format t "~A:~%" (car (instruction-args instruction))))
     1677        (t
     1678         (format t "~8D:   ~A ~S~%"
     1679                 i
     1680                 (opcode-name (instruction-opcode instruction))
     1681                 (instruction-args instruction)))))))
    16791682
    16801683(defun label-p (instruction)
     
    18111814(defun delete-unreachable-code ()
    18121815  (when *delete-unreachable-code-flag*
    1813     ;; Look for unreachable code after GOTO.
    1814     (unless (listp *code*)
    1815       (setf *code* (coerce *code* 'list)))
    1816     (validate-labels *code*)
    1817     (let* ((code *code*)
    1818            (tail code)
    1819            (locally-changed-p nil)
    1820            (after-goto nil))
    1821       (loop
    1822         (when (null tail)
    1823           (return))
    1824         (let ((instruction (car tail)))
    1825           (cond (after-goto
    1826                  (if (= (instruction-opcode instruction) 202) ; LABEL
    1827                      (setf after-goto nil)
    1828                      ;; Unreachable.
    1829                      (progn
    1830                        (setf (car tail) nil)
    1831                        (setf locally-changed-p t))))
    1832                 ((= (instruction-opcode instruction) 167) ; GOTO
    1833                  (setf after-goto t))))
    1834         (setf tail (cdr tail)))
    1835       (when locally-changed-p
    1836         (setf *code* (delete nil code))
    1837         t))))
     1816      ;; Look for unreachable code after GOTO.
     1817      (unless (listp *code*)
     1818        (setf *code* (coerce *code* 'list)))
     1819      (let* ((code *code*)
     1820             (tail code)
     1821             (locally-changed-p nil)
     1822             (after-goto nil))
     1823        (loop
     1824          (when (null tail)
     1825            (return))
     1826          (let ((instruction (car tail)))
     1827            (cond (after-goto
     1828                   (if (= (instruction-opcode instruction) 202) ; LABEL
     1829                       (setf after-goto nil)
     1830                       ;; Unreachable.
     1831                       (progn
     1832                         (setf (car tail) nil)
     1833                         (setf locally-changed-p t))))
     1834                  ((= (instruction-opcode instruction) 167) ; GOTO
     1835                   (setf after-goto t))))
     1836          (setf tail (cdr tail)))
     1837        (when locally-changed-p
     1838          (setf *code* (delete nil code))
     1839          t))))
    18381840
    18391841(defvar *enable-optimization* t)
Note: See TracChangeset for help on using the changeset viewer.