Changeset 12867


Ignore:
Timestamp:
08/06/10 22:18:06 (12 years ago)
Author:
ehuelsmann
Message:

Move and improve ANALYZE-STACK, DELETE-UNREACHABLE-CODE 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

    r12865 r12867  
    915915
    916916
    917 (declaim (ftype (function (t t t) t) walk-code))
    918 (defun walk-code (code start-index depth)
    919   (declare (optimize speed))
    920   (declare (type fixnum start-index depth))
    921   (do* ((i start-index (1+ i))
    922         (limit (length code)))
    923        ((>= i limit))
    924     (declare (type fixnum i limit))
    925     (let* ((instruction (aref code i))
    926            (instruction-depth (instruction-depth instruction))
    927            (instruction-stack (instruction-stack instruction)))
    928       (declare (type fixnum instruction-stack))
    929       (when instruction-depth
    930         (unless (= (the fixnum instruction-depth) (the fixnum (+ depth instruction-stack)))
    931           (internal-compiler-error
    932            "Stack inconsistency detected in ~A at index ~D: found ~S, expected ~S."
    933            (compiland-name *current-compiland*)
    934            i instruction-depth (+ depth instruction-stack)))
    935         (return-from walk-code))
    936       (let ((opcode (instruction-opcode instruction)))
    937         (setf depth (+ depth instruction-stack))
    938         (setf (instruction-depth instruction) depth)
    939         (when (branch-opcode-p opcode)
    940           (let ((label (car (instruction-args instruction))))
    941             (declare (type symbol label))
    942             (walk-code code (symbol-value label) depth)))
    943         (when (member opcode '(167 176 191)) ; GOTO ARETURN ATHROW
    944           ;; Current path ends.
    945           (return-from walk-code))))))
    946 
    947 (declaim (ftype (function (t) t) analyze-stack))
    948 (defun analyze-stack (code)
    949   (declare (optimize speed))
    950   (let* ((code-length (length code)))
    951     (declare (type vector code))
    952     (dotimes (i code-length)
    953       (declare (type (unsigned-byte 16) i))
    954       (let* ((instruction (aref code i))
    955              (opcode (instruction-opcode instruction)))
    956         (when (eql opcode 202) ; LABEL
    957           (let ((label (car (instruction-args instruction))))
    958             (set label i)))
    959         (if (instruction-stack instruction)
    960             (when (opcode-stack-effect opcode)
    961               (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode))
    962                 (sys::%format t "instruction-stack = ~S opcode-stack-effect = ~S~%"
    963                          (instruction-stack instruction)
    964                          (opcode-stack-effect opcode))
    965                 (sys::%format t "index = ~D instruction = ~A~%" i (print-instruction instruction))))
    966             (setf (instruction-stack instruction) (opcode-stack-effect opcode)))
    967         (unless (instruction-stack instruction)
    968           (sys::%format t "no stack information for instruction ~D~%" (instruction-opcode instruction))
    969           (aver nil))))
    970     (walk-code code 0 0)
    971     (dolist (handler *handlers*)
    972       ;; Stack depth is always 1 when handler is called.
    973       (walk-code code (symbol-value (handler-code handler)) 1))
    974     (let ((max-stack 0))
    975       (declare (type fixnum max-stack))
    976       (dotimes (i code-length)
    977         (declare (type (unsigned-byte 16) i))
    978         (let* ((instruction (aref code i))
    979                (instruction-depth (instruction-depth instruction)))
    980           (when instruction-depth
    981             (setf max-stack (max max-stack (the fixnum instruction-depth))))))
    982       max-stack)))
    983 
    984 
    985917(defun finalize-code ()
    986918  (setf *code* (nreverse (coerce *code* 'vector))))
     
    11291061      t)))
    11301062
    1131 (defun delete-unreachable-code ()
    1132   ;; Look for unreachable code after GOTO.
    1133   (let* ((code (coerce *code* 'vector))
    1134          (changed nil)
    1135          (after-goto/areturn nil))
    1136     (dotimes (i (length code))
    1137       (declare (type (unsigned-byte 16) i))
    1138       (let* ((instruction (aref code i))
    1139              (opcode (instruction-opcode instruction)))
    1140         (cond (after-goto/areturn
    1141                (if (= opcode 202) ; LABEL
    1142                    (setf after-goto/areturn nil)
    1143                    ;; Unreachable.
    1144                    (progn
    1145                      (setf (aref code i) nil)
    1146                      (setf changed t))))
    1147               ((= opcode 176) ; ARETURN
    1148                (setf after-goto/areturn t))
    1149               ((= opcode 167) ; GOTO
    1150                (setf after-goto/areturn t)))))
    1151     (when changed
    1152       (setf *code* (delete nil code))
    1153       t)))
    1154 
    11551063(defvar *enable-optimization* t)
    11561064
     
    11691077        (setf changed-p (or (optimize-2b) changed-p))
    11701078        (setf changed-p (or (optimize-3) changed-p))
    1171         (setf changed-p (or (delete-unreachable-code) changed-p))
     1079        (if changed-p
     1080            (setf *code* delete-unreachable-code *code*)
     1081            (multiple-value-setq
     1082                (*code* changed-p)
     1083              (delete-unreachable-code *code*)))
    11721084        (unless changed-p
    11731085          (return))))
     
    14901402    (finalize-code)
    14911403    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
    1492     (setf (method-max-stack constructor) (analyze-stack *code*))
     1404    (setf (method-max-stack constructor)
     1405          (analyze-stack *code* (mapcar #'handler-code *handlers*)))
    14931406    (setf (method-code constructor) (code-bytes *code*))
    14941407    (setf (method-handlers constructor) (nreverse *handlers*))
     
    77907703
    77917704    (setf *code* (resolve-instructions (expand-virtual-instructions *code*)))
    7792     (setf (method-max-stack execute-method) (analyze-stack *code*))
     7705    (setf (method-max-stack execute-method)
     7706          (analyze-stack *code* (mapcar #'handler-code *handlers*)))
    77937707    (setf (method-code execute-method) (code-bytes *code*))
    77947708
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp

    r12865 r12867  
    257257(define-opcode ifnonnull 199 3 nil)
    258258(define-opcode goto_w 200 5 nil)
    259 (define-opcode jsr_w 201 5 nil)
     259;; (define-opcode jsr_w 201 5 nil) Don't use: deprecated
    260260(define-opcode label 202 0 0)  ;; virtual: does not exist in the JVM
    261261;; (define-opcode push-value 203 nil 1)
     
    393393    (t (emit 'astore index))))
    394394
    395 (declaim (ftype (function (t) t) branch-opcode-p))
    396 (declaim (inline branch-opcode-p))
    397 (defun branch-opcode-p (opcode)
     395(declaim (ftype (function (t) t) branch-p)
     396         (inline branch-p))
     397(defun branch-p (opcode)
    398398  (declare (optimize speed))
    399399  (declare (type '(integer 0 255) opcode))
    400400  (or (<= 153 opcode 168)
    401       (= opcode 198)))
    402 
    403 (declaim (ftype (function (t) boolean) label-p))
     401      (<= 198 opcode 200))) ;; ifnull / ifnonnull / goto_w
     402
     403(declaim (ftype (function (t) t) unconditional-control-transfer-p)
     404         (inline unconditional-control-transfer-p))
     405(defun unconditional-control-transfer-p (opcode)
     406  (or (= 168 opcode) ;; goto
     407      (= 200 opcode) ;; goto_w
     408      (<= 172 opcode 177) ;; ?return
     409      (= 191 opcode) ;; athrow
     410      ))
     411
     412(declaim (ftype (function (t) boolean) label-p)
     413         (inline label-p))
    404414(defun label-p (instruction)
    405415  (and instruction
     
    681691        (vector-push-extend (resolve-instruction instruction) vector)))))
    682692
     693
     694
     695;; BYTE CODE ANALYSIS AND OPTIMIZATION
     696
     697(declaim (ftype (function (t t t) t) analyze-stack-path))
     698(defun analyze-stack-path (code start-index depth)
     699  (declare (optimize speed))
     700  (declare (type fixnum start-index depth))
     701  (do* ((i start-index (1+ i))
     702        (limit (length code)))
     703       ((>= i limit))
     704    (declare (type fixnum i limit))
     705    (let* ((instruction (aref code i))
     706           (instruction-depth (instruction-depth instruction))
     707           (instruction-stack (instruction-stack instruction)))
     708      (declare (type fixnum instruction-stack))
     709      (when instruction-depth
     710        (unless (= (the fixnum instruction-depth)
     711                   (the fixnum (+ depth instruction-stack)))
     712          (internal-compiler-error "Stack inconsistency detected ~
     713                                    in ~A at index ~D: ~
     714                                    found ~S, expected ~S."
     715                                   (compiland-name *current-compiland*)
     716                                   i instruction-depth
     717                                   (+ depth instruction-stack)))
     718        (return-from analyze-stack-path))
     719      (let ((opcode (instruction-opcode instruction)))
     720        (setf depth (+ depth instruction-stack))
     721        (setf (instruction-depth instruction) depth)
     722        (when (branch-opcode-p opcode)
     723          (let ((label (car (instruction-args instruction))))
     724            (declare (type symbol label))
     725            (analyze-stack-path code (symbol-value label) depth)))
     726        (when (unconditional-control-transfer-p opcode)
     727          ;; Current path ends.
     728          (return-from analyze-stack-path))))))
     729
     730(declaim (ftype (function (t) t) analyze-stack))
     731(defun analyze-stack (code exception-entry-points)
     732  (declare (optimize speed))
     733  (let* ((code-length (length code)))
     734    (declare (type vector code))
     735    (dotimes (i code-length)
     736      (declare (type (unsigned-byte 16) i))
     737      (let* ((instruction (aref code i))
     738             (opcode (instruction-opcode instruction)))
     739        (when (eql opcode 202) ; LABEL
     740          (let ((label (car (instruction-args instruction))))
     741            (set label i)))
     742        (if (instruction-stack instruction)
     743            (when (opcode-stack-effect opcode)
     744              (unless (eql (instruction-stack instruction)
     745                           (opcode-stack-effect opcode))
     746                (sys::%format t "instruction-stack = ~S ~
     747                                 opcode-stack-effect = ~S~%"
     748                              (instruction-stack instruction)
     749                              (opcode-stack-effect opcode))
     750                (sys::%format t "index = ~D instruction = ~A~%" i
     751                              (print-instruction instruction))))
     752            (setf (instruction-stack instruction)
     753                  (opcode-stack-effect opcode)))
     754        (unless (instruction-stack instruction)
     755          (sys::%format t "no stack information for instruction ~D~%"
     756                        (instruction-opcode instruction))
     757          (aver nil))))
     758    (analyze-stack-path code 0 0)
     759    (dolist (entry-point exception-entry-points)
     760      ;; Stack depth is always 1 when handler is called.
     761      (analyze-stack-path code (symbol-value entry-point) 1))
     762    (let ((max-stack 0))
     763      (declare (type fixnum max-stack))
     764      (dotimes (i code-length)
     765        (declare (type (unsigned-byte 16) i))
     766        (let* ((instruction (aref code i))
     767               (instruction-depth (instruction-depth instruction)))
     768          (when instruction-depth
     769            (setf max-stack (max max-stack (the fixnum instruction-depth))))))
     770      max-stack)))
     771
     772(defun delete-unreachable-code (code)
     773  ;; Look for unreachable code after GOTO.
     774  (let* ((code (coerce code 'vector))
     775         (changed nil)
     776         (after-goto/areturn nil))
     777    (dotimes (i (length code))
     778      (declare (type (unsigned-byte 16) i))
     779      (let* ((instruction (aref code i))
     780             (opcode (instruction-opcode instruction)))
     781        (cond (after-goto/areturn
     782               (if (= opcode 202) ; LABEL
     783                   (setf after-goto/areturn nil)
     784                   ;; Unreachable.
     785                   (progn
     786                     (setf (aref code i) nil)
     787                     (setf changed t))))
     788              ((unconditional-control-transfer-p opcode)
     789               (setf after-goto/areturn t)))))
     790    (values (if changed (delete nil code) code)
     791            changed)))
     792
     793
     794
     795
    683796(provide '#:opcodes)
Note: See TracChangeset for help on using the changeset viewer.