Changeset 4776


Ignore:
Timestamp:
11/16/03 03:07:21 (18 years ago)
Author:
piso
Message:

OPTIMIZE-CODE: work in progress.

File:
1 edited

Legend:

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

    r4775 r4776  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.34 2003-11-16 01:47:08 piso Exp $
     4;;; $Id: jvm.lisp,v 1.35 2003-11-16 03:07:21 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    792792              (instruction-args instruction)))))
    793793
     794(defun validate-labels ()
     795  (dotimes (i (length *code*))
     796    (let* ((instruction (svref *code* i))
     797           (opcode (instruction-opcode instruction)))
     798      (when (eql opcode 202)
     799        (let ((label (car (instruction-args instruction))))
     800          (set label i))))))
     801
    794802(defun optimize-code ()
    795803  (when *debug*
     
    831839                              ))))))
    832840      (setf *code* (delete 0 *code* :key #'instruction-opcode))
     841      ;; Reduce GOTOs.
     842      (validate-labels)
     843      (dotimes (i (length *code*))
     844        (let ((instruction (svref *code* i)))
     845          (when (eql (instruction-opcode instruction) 167) ; GOTO
     846            (let* ((label (car (instruction-args instruction)))
     847                   (target-index (1+ (symbol-value label)))
     848                   (instr1 (svref *code* target-index))
     849                   (instr2 (if (eql (instruction-opcode instr1) 203) ; PUSH-VALUE
     850                               (svref *code* (1+ target-index))
     851                               nil)))
     852              (when (and instr2 (eql (instruction-opcode instr2) 176)) ; ARETURN
     853                (let ((previous-instruction (svref *code* (1- i))))
     854                  (when (eql (instruction-opcode previous-instruction) 204) ; STORE-VALUE
     855                    (setf (instruction-opcode previous-instruction) 176) ; ARETURN
     856                    (setf (instruction-opcode instruction) 0)
     857                    (setf changed-p t))))))))
     858      (setf *code* (delete 0 *code* :key #'instruction-opcode))
     859      ;; Look for sequence STORE-VALUE LOAD-VALUE ARETURN.
     860      (dotimes (i (- (length *code*) 2))
     861        (let ((instr1 (svref *code* i))
     862              (instr2 (svref *code* (+ i 1)))
     863              (instr3 (svref *code* (+ i 2))))
     864          (when (and (eql (instruction-opcode instr1) 204)
     865                     (eql (instruction-opcode instr2) 203)
     866                     (eql (instruction-opcode instr3) 176))
     867            (setf (instruction-opcode instr1) 176)
     868            (setf (instruction-opcode instr2) 0)
     869            (setf (instruction-opcode instr3) 0)
     870            (setf changed-p t))))
     871      (setf *code* (delete 0 *code* :key #'instruction-opcode))
    833872      (unless changed-p
    834873          (return))))
     
    841880;; CODE is a list of INSTRUCTIONs.
    842881(defun code-bytes (code)
    843 
    844 ;;   (fresh-line)
    845 ;;   (format t "-- begin code --~%")
    846 ;;   (dotimes (i (length code))
    847 ;;     (format t "~S~%" (svref code i)))
    848 ;;   (format t "--- end code ---~%")
    849 
    850 ;;   ;; Make a list of the labels that are actually branched to.
    851 ;;   (let ((branch-targets ()))
    852 ;;     (dotimes (i (length code))
    853 ;;       (let ((instruction (svref code i)))
    854 ;;         (when (branch-opcode-p (instruction-opcode instruction))
    855 ;;           (push branch-targets (car (instruction-args instruction))))))
    856 ;;     (format t "branch-targets = ~S~%" branch-targets)
    857 
    858 ;;     ;; Remove labels that are not used as branch targets.
    859 ;;     (dotimes (i (length code))
    860 ;;       (let ((instruction (svref code i)))
    861 ;;         (when (= (instruction-opcode instruction) 202) ; LABEL
    862 ;;           (let ((label (car (instruction-args instruction))))
    863 ;;             (unless (member label branch-targets)
    864 ;;               (setf (instruction-opcode instruction) 0)))))))
    865 
    866 ;;   (dotimes (i (length code))
    867 ;;     (let ((instruction (svref code i)))
    868 ;;       (when (and (< i (1- (length code)))
    869 ;;                  (= (instruction-opcode instruction) 167) ; GOTO
    870 ;;         (let ((next-instruction (svref code (1+ i))))
    871 ;;           (when (and (= (instruction-opcode next-instruction) 202) ; LABEL
    872 ;;                      (eq (car (instruction-args instruction))
    873 ;;                          (car (instruction-args next-instruction))))
    874 ;;             (setf (instruction-opcode instruction) 0)))))))
    875 
    876 ;;   (setf code (delete 0 code :key #'instruction-opcode))
    877 
    878 ;;   (fresh-line)
    879 ;;   (format t "-- begin code --~%")
    880 ;;   (dotimes (i (length code))
    881 ;;     (format t "~S~%" (svref code i)))
    882 ;;   (format t "--- end code ---~%")
    883 
    884 ;;   (setf code (coerce code 'list))
    885 
    886   ;; FIXME Do stack analysis here!
    887 ;;   (setf *max-stack* (analyze-stack code))
    888 
    889882  (let ((code (resolve-opcodes code))
    890883        (length 0))
     
    907900          (unless (= (instruction-opcode instruction) 202) ; LABEL
    908901            (incf index (opcode-size (instruction-opcode instruction)))))))
    909 
    910902    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
    911903    (let ((bytes (make-array length))
Note: See TracChangeset for help on using the changeset viewer.