Changeset 4676


Ignore:
Timestamp:
11/08/03 14:41:21 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4668 r4676  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.14 2003-11-07 19:14:00 piso Exp $
     4;;; $Id: jvm.lisp,v 1.15 2003-11-08 14:41:21 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    626626  (map 'vector #'resolve-args code))
    627627
     628(defun is-branch-opcode (opcode)
     629  (member opcode
     630    '(153 ; IFEQ
     631      154 ; IFNE
     632      166 ; IF_ACMPNE
     633      165 ; IF_ACMPEQ
     634      167 ; GOTO
     635      )))
     636
    628637;; CODE is a list of INSTRUCTIONs.
    629638(defun code-bytes (code)
    630639  (setf code (coerce code 'vector))
    631640  (setf code (nreverse code))
     641
     642;;   (fresh-line)
     643;;   (format t "-- begin code --~%")
     644;;   (dotimes (i (length code))
     645;;     (format t "~S~%" (svref code i)))
     646;;   (format t "--- end code ---~%")
     647
     648;;   ;; Make a list of the labels that are actually branched to.
     649;;   (let ((branch-targets ()))
     650;;     (dotimes (i (length code))
     651;;       (let ((instruction (svref code i)))
     652;;         (when (is-branch-opcode (instruction-opcode instruction))
     653;;           (push branch-targets (car (instruction-args instruction))))))
     654;;     (format t "branch-targets = ~S~%" branch-targets)
     655
     656;;     ;; Remove labels that are never branched to.
     657;;     (dotimes (i (length code))
     658;;       (let ((instruction (svref code i)))
     659;;         (when (= (instruction-opcode instruction) 202) ; LABEL
     660;;           (let ((label (car (instruction-args instruction))))
     661;;             (unless (member label branch-targets)
     662;;               (setf (instruction-opcode instruction) 0)))))))
    632663
    633664  (dotimes (i (length code))
     
    639670                     (eq (car (instruction-args instruction))
    640671                         (car (instruction-args next-instruction))))
    641             (setf (instruction-opcode instruction) 'nop)))))))
    642 
    643   (setf code (delete 'nop code :key #'instruction-opcode))
     672            (setf (instruction-opcode instruction) 0)))))))
     673
     674  (setf code (delete 0 code :key #'instruction-opcode))
     675
     676;;   (fresh-line)
     677;;   (format t "-- begin code --~%")
     678;;   (dotimes (i (length code))
     679;;     (format t "~S~%" (svref code i)))
     680;;   (format t "--- end code ---~%")
     681
    644682;;   (setf code (coerce code 'list))
    645683
     
    658696      (dotimes (i (length code))
    659697        (let ((instruction (aref code i)))
    660           (case (instruction-opcode instruction)
    661             ((153 ; IFEQ
    662               154 ; IFNE
    663               166 ; IF_ACMPNE
    664               165 ; IF_ACMPEQ
    665               167 ; GOTO
    666               )
    667              (let* ((label (car (instruction-args instruction)))
    668                     (offset (- (symbol-value `,label) index)))
    669                (setf (instruction-args instruction) (u2 offset)))))
     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))
     706            (let* ((label (car (instruction-args instruction)))
     707                   (offset (- (symbol-value `,label) index)))
     708              (setf (instruction-args instruction) (u2 offset))))
    670709          (unless (= (instruction-opcode instruction) 202) ; LABEL
    671710            (incf index (opcode-size (instruction-opcode instruction)))))))
     
    15541593          (block-label (car rest))
    15551594          (block-exit (gensym))
    1556           (*blocks* (acons block-label block-exit *blocks*))
    1557           (forms (cdr rest)))
    1558      (dolist (form forms)
    1559        (compile-form form))
     1595          (*blocks* (acons block-label block-exit *blocks*)))
     1596     (do* ((forms (cdr rest) (cdr forms)))
     1597          ((null forms))
     1598       (compile-form (car forms) (cdr forms)))
    15601599     (emit 'label `,block-exit)))
    15611600
Note: See TracChangeset for help on using the changeset viewer.