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

Work in progress.

File:
1 edited

Legend:

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

    r4681 r4682  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.20 2003-11-08 19:08:36 piso Exp $
     4;;; $Id: jvm.lisp,v 1.21 2003-11-08 20:17:34 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    724724          ()))))
    725725
    726 (defun analyze-stack (code)
    727   (sys::require-type code 'vector)
    728   (dotimes (i (length code))
    729     (let* ((instruction (svref code i))
     726(defun analyze-stack ()
     727  (sys::require-type *code* 'vector)
     728  (dotimes (i (length *code*))
     729    (let* ((instruction (svref *code* i))
    730730           (opcode (instruction-opcode instruction)))
    731731      (when (eql opcode 202)
     
    734734      (unless (instruction-stack instruction)
    735735        (setf (instruction-stack instruction) (stack-effect opcode)))))
    736   (walk-code code 0 0)
     736  (walk-code *code* 0 0)
    737737  (let ((max-stack 0))
    738     (dotimes (i (length code))
    739       (let ((instruction (svref code i)))
     738    (dotimes (i (length *code*))
     739      (let ((instruction (svref *code* i)))
    740740        (setf max-stack (max max-stack (instruction-depth instruction)))))
    741741;;     (format t "max-stack = ~D~%" max-stack)
    742742    max-stack))
    743743
     744(defun finalize-code ()
     745  (setf *code* (nreverse (coerce *code* 'vector))))
     746
     747(defun optimize-code ()
     748  (dotimes (i (length *code*))
     749    (let ((instruction (svref *code* i)))
     750      (when (and (< i (1- (length *code*)))
     751                 (= (instruction-opcode instruction) 167) ; GOTO
     752                 (let ((next-instruction (svref *code* (1+ i))))
     753                   (when (and (= (instruction-opcode next-instruction) 202) ; LABEL
     754                              (eq (car (instruction-args instruction))
     755                                  (car (instruction-args next-instruction))))
     756                     (setf (instruction-opcode instruction) 0)))))))
     757
     758  (setf *code* (delete 0 *code* :key #'instruction-opcode))
     759  )
     760
    744761(defvar *max-stack*)
    745762
    746763;; CODE is a list of INSTRUCTIONs.
    747764(defun code-bytes (code)
    748   (setf code (coerce code 'vector))
    749   (setf code (nreverse code))
    750765
    751766;;   (fresh-line)
     
    771786;;               (setf (instruction-opcode instruction) 0)))))))
    772787
    773   (dotimes (i (length code))
    774     (let ((instruction (svref code i)))
    775       (when (and (< i (1- (length code)))
    776                  (= (instruction-opcode instruction) 167) ; GOTO
    777         (let ((next-instruction (svref code (1+ i))))
    778           (when (and (= (instruction-opcode next-instruction) 202) ; LABEL
    779                      (eq (car (instruction-args instruction))
    780                          (car (instruction-args next-instruction))))
    781             (setf (instruction-opcode instruction) 0)))))))
    782 
    783   (setf code (delete 0 code :key #'instruction-opcode))
     788;;   (dotimes (i (length code))
     789;;     (let ((instruction (svref code i)))
     790;;       (when (and (< i (1- (length code)))
     791;;                  (= (instruction-opcode instruction) 167) ; GOTO
     792;;         (let ((next-instruction (svref code (1+ i))))
     793;;           (when (and (= (instruction-opcode next-instruction) 202) ; LABEL
     794;;                      (eq (car (instruction-args instruction))
     795;;                          (car (instruction-args next-instruction))))
     796;;             (setf (instruction-opcode instruction) 0)))))))
     797
     798;;   (setf code (delete 0 code :key #'instruction-opcode))
    784799
    785800;;   (fresh-line)
     
    792807
    793808  ;; FIXME Do stack analysis here!
    794   (setf *max-stack* (analyze-stack code))
     809;;   (setf *max-stack* (analyze-stack code))
    795810
    796811  (let ((code (resolve-opcodes code))
     
    912927                               "()V"
    913928                               0)))
    914     (setq *code* (append *static-code* *code*))
     929    (setf *code* (append *static-code* *code*))
    915930    (emit 'return)
     931    (finalize-code)
     932    (optimize-code)
     933    (setf (method-max-stack constructor) (analyze-stack))
    916934    (setf (method-code constructor) (code-bytes *code*))
    917935    constructor))
     
    20162034      (emit-push-value)) ; leave result on stack
    20172035    (emit 'areturn)
     2036    (finalize-code)
     2037    (optimize-code)
     2038    (setf (method-max-stack execute-method) (analyze-stack))
    20182039    (setf (method-code execute-method) (code-bytes *code*))
    2019     (setf (method-max-stack execute-method) *max-stack*)
     2040;;     (setf (method-max-stack execute-method) *max-stack*)
    20202041    (setf (method-max-locals execute-method) *max-locals*)
    20212042
Note: See TracChangeset for help on using the changeset viewer.