Changeset 12870


Ignore:
Timestamp:
08/07/10 10:14:30 (12 years ago)
Author:
ehuelsmann
Message:

Move OPTIMIZE-2B (renaming it to OPTIMIZE-JUMPS)
to jvm-instructions.lisp.

Location:
branches/generic-class-file/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12869 r12870  
    964964      t)))
    965965
    966 (declaim (ftype (function (t) hash-table) hash-labels))
    967 (defun hash-labels (code)
    968   (let ((ht (make-hash-table :test 'eq))
    969         (code (coerce code 'vector))
    970         (pending-labels '()))
    971     (dotimes (i (length code))
    972       (declare (type (unsigned-byte 16) i))
    973       (let ((instruction (aref code i)))
    974         (cond ((label-p instruction)
    975                (push (instruction-label instruction) pending-labels))
    976               (t
    977                ;; Not a label.
    978                (when pending-labels
    979                  (dolist (label pending-labels)
    980                    (setf (gethash label ht) instruction))
    981                  (setf pending-labels nil))))))
    982     ht))
    983 
    984 (defun optimize-2b ()
    985   (let* ((code (coerce *code* 'vector))
    986          (ht (hash-labels code))
    987          (changed nil))
    988     (dotimes (i (length code))
    989       (declare (type (unsigned-byte 16) i))
    990       (let ((instruction (aref code i)))
    991         (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
    992           (let* ((target-label (car (instruction-args instruction)))
    993                  (next-instruction (gethash1 target-label ht)))
    994             (when next-instruction
    995               (case (instruction-opcode next-instruction)
    996                 (167 ; GOTO
    997                  (setf (instruction-args instruction)
    998                        (instruction-args next-instruction)
    999                        changed t))
    1000                 (176 ; ARETURN
    1001                  (setf (instruction-opcode instruction) 176
    1002                        (instruction-args instruction) nil
    1003                        changed t))))))))
    1004     (when changed
    1005       (setf *code* code)
    1006       t)))
    1007 
    1008966;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
    1009967;; GETSTATIC POP => nothing
     
    10461004            (*code* changed-p)
    10471005          (delete-unused-labels *code*
    1048                                 (append
     1006                                (nconc
    10491007                                 (mapcar #'handler-from *handlers*)
    10501008                                 (mapcar #'handler-to *handlers*)
    10511009                                 (mapcar #'handler-code *handlers*))))
    10521010        (setf changed-p (or (optimize-2) changed-p))
    1053         (setf changed-p (or (optimize-2b) changed-p))
     1011        (if changed-p
     1012            (setf *code* (optimize-jumps *code*))
     1013            (multiple-value-setq
     1014                (*code* changed-p)
     1015              (optimize-jumps *code*)))
    10541016        (setf changed-p (or (optimize-3) changed-p))
    10551017        (if changed-p
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r12869 r12870  
    819819            changed)))
    820820
     821
     822(declaim (ftype (function (t) hash-table) hash-labels))
     823(defun label-target-instructions (code)
     824  (let ((ht (make-hash-table :test 'eq))
     825        (code (coerce code 'vector))
     826        (pending-labels '()))
     827    (dotimes (i (length code))
     828      (declare (type (unsigned-byte 16) i))
     829      (let ((instruction (aref code i)))
     830        (cond ((label-p instruction)
     831               (push (instruction-label instruction) pending-labels))
     832              (t
     833               ;; Not a label.
     834               (when pending-labels
     835                 (dolist (label pending-labels)
     836                   (setf (gethash label ht) instruction))
     837                 (setf pending-labels nil))))))
     838    ht))
     839
     840(defun optimize-jumps (code)
     841  (let* ((code (coerce code 'vector))
     842         (ht (label-target-instructions code))
     843         (changed nil))
     844    (dotimes (i (length code))
     845      (declare (type (unsigned-byte 16) i))
     846      (let ((instruction (aref code i)))
     847        (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
     848          ;; we're missing conditional jumps here?
     849          (let* ((target-label (car (instruction-args instruction)))
     850                 (next-instruction (gethash1 target-label ht)))
     851            (when next-instruction
     852              (case (instruction-opcode next-instruction)
     853                ((167 200)                  ;; GOTO
     854                 (setf (instruction-args instruction)
     855                       (instruction-args next-instruction)
     856                       changed t))
     857                (176 ; ARETURN
     858                 (setf (instruction-opcode instruction) 176
     859                       (instruction-args instruction) nil
     860                       changed t))))))))
     861    (values code changed)))
     862
    821863(defun code-bytes (code)
    822864  (let ((length 0)
Note: See TracChangeset for help on using the changeset viewer.