Changeset 8455


Ignore:
Timestamp:
02/03/05 17:13:33 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

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

    r8453 r8455  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.386 2005-02-03 02:28:06 piso Exp $
     4;;; $Id: jvm.lisp,v 1.387 2005-02-03 17:13:33 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    11681168                sys:single-valued-p
    11691169                sys:write-8-bits
     1170                sys::require-type
    11701171                ))
    11711172    (setf (sys:single-valued-p op) t)))
     
    16771678      (incf i))))
    16781679
     1680(defun label-p (instruction)
     1681;;   (declare (optimize safety))
     1682;;   (declare (type instruction instruction))
     1683  (and instruction
     1684       (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
     1685
     1686(defun instruction-label (instruction)
     1687  (declare (optimize safety))
     1688;;   (declare (type instruction instruction))
     1689  (and instruction
     1690       (= (instruction-opcode (the instruction instruction)) 202)
     1691       (car (instruction-args instruction))))
     1692
    16791693;; Remove unused labels.
    16801694(defun optimize-1 ()
     
    17351749      t)))
    17361750
     1751(defun optimize-2a ()
     1752  (let* ((code (coerce *code* 'list))
     1753         (tail code)
     1754         (changed nil))
     1755    (dolist (instruction code)
     1756      (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
     1757        (let* ((target-label (car (instruction-args instruction)))
     1758               (target-instruction nil)
     1759               (next-instruction nil))
     1760          (dolist (instr code)
     1761            (when target-instruction
     1762              (setf next-instruction instr)
     1763              (return))
     1764            (when (and instr
     1765                       (label-p instr)
     1766                       (eq (car (instruction-args instr)) target-label))
     1767              (setf target-instruction instr)))
     1768          (when next-instruction
     1769            (case (instruction-opcode next-instruction)
     1770              (167 ; GOTO
     1771               (setf (instruction-args instruction)
     1772                     (instruction-args next-instruction)
     1773                     changed t))
     1774              (176 ; ARETURN
     1775               (setf (instruction-opcode instruction) 176
     1776                     (instruction-args instruction) nil
     1777                     changed t)))))))
     1778    (when changed
     1779      (setf *code* (delete nil code))
     1780      t)))
     1781
    17371782;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
    17381783;; GETSTATIC POP => nothing
     
    18051850        (setf changed-p (or (optimize-1) changed-p))
    18061851        (setf changed-p (or (optimize-2) changed-p))
     1852        (setf changed-p (or (optimize-2a) changed-p))
    18071853        (setf changed-p (or (optimize-3) changed-p))
    18081854        (setf changed-p (or (delete-unreachable-code) changed-p))
     
    29553001    (case (length args)
    29563002      (2
     3003       (dformat t "p2-numeric-comparison form = ~S~%" form)
    29573004       (let ((first (first args))
    29583005             (second (second args))
    29593006             var1 var2)
    29603007         (cond ((and (fixnump first) (fixnump second))
    2961                 (dformat t "p2-numeric-comparison form = ~S~%" form)
    29623008                (if (funcall op first second)
    29633009                    (emit-push-t)
    29643010                    (emit-push-nil))
     3011                (emit-move-from-stack target)
    29653012                (return-from p2-numeric-comparison))
     3013               ((and (setf var1 (unboxed-fixnum-variable first))
     3014                     (setf var2 (unboxed-fixnum-variable second)))
     3015                (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form)
     3016                (let ((LABEL1 (gensym))
     3017                      (LABEL2 (gensym)))
     3018                  (emit 'iload (variable-register var1))
     3019                  (emit 'iload (variable-register var2))
     3020                  (emit (case op
     3021                          (<  'if_icmpge)
     3022                          (<= 'if_icmpgt)
     3023                          (>  'if_icmple)
     3024                          (>= 'if_icmplt)
     3025                          (=  'if_icmpne)
     3026                          (/= 'if_icmpeq))
     3027                        LABEL1)
     3028                  (emit-push-t)
     3029                  (emit 'goto LABEL2)
     3030                  (label LABEL1)
     3031                  (emit-push-nil)
     3032                  (label LABEL2)
     3033                  (emit-move-from-stack target)
     3034                  (return-from p2-numeric-comparison)))
     3035               ((and (subtypep (derive-type first) 'FIXNUM)
     3036                     (subtypep (derive-type second) 'FIXNUM))
     3037                (let ((LABEL1 (gensym))
     3038                      (LABEL2 (gensym)))
     3039                  (compile-form first :target :stack :representation :unboxed-fixnum)
     3040                  (compile-form second :target :stack :representation :unboxed-fixnum)
     3041                  (unless (and (single-valued-p first) (single-valued-p second))
     3042                    (emit-clear-values))
     3043                  (emit (case op
     3044                          (<  'if_icmpge)
     3045                          (<= 'if_icmpgt)
     3046                          (>  'if_icmple)
     3047                          (>= 'if_icmplt)
     3048                          (=  'if_icmpne)
     3049                          (/= 'if_icmpeq))
     3050                        LABEL1)
     3051                  (emit-push-t)
     3052                  (emit 'goto LABEL2)
     3053                  (label LABEL1)
     3054                  (emit-push-nil)
     3055                  (label LABEL2)
     3056                  (emit-move-from-stack target)
     3057                  (return-from p2-numeric-comparison)))
    29663058               ((fixnump second)
    2967                 (dformat t "p2-numeric-comparison form = ~S~%" form)
    2968                 (compile-form (car args) :target :stack)
    2969                 (unless (single-valued-p first)
    2970                   (emit-clear-values))
     3059                (compile-form first :target :stack)
     3060                (maybe-emit-clear-values first)
    29713061                (emit-push-constant-int second)
    29723062                (emit-invokevirtual +lisp-object-class+
     
    29913081                  (emit-move-from-stack target))
    29923082                (return-from p2-numeric-comparison))
    2993                ((and (setf var1 (unboxed-fixnum-variable first))
    2994                      (setf var2 (unboxed-fixnum-variable second)))
    2995                 (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form)
    2996                 (let ((LABEL1 (gensym))
    2997                       (LABEL2 (gensym)))
    2998                   (emit 'iload (variable-register var1))
    2999                   (emit 'iload (variable-register var2))
    3000                   (emit (case op
    3001                           (<  'if_icmpge)
    3002                           (<= 'if_icmpgt)
    3003                           (>  'if_icmple)
    3004                           (>= 'if_icmplt)
    3005                           (=  'if_icmpne)
    3006                           (/= 'if_icmpeq))
    3007                         LABEL1)
    3008                   (emit-push-t)
    3009                   (emit 'goto LABEL2)
    3010                   (label LABEL1)
    3011                   (emit-push-nil)
    3012                   (label LABEL2)
    3013                   (emit-move-from-stack target)
    3014                   (return-from p2-numeric-comparison))))))))
     3083               )))))
    30153084  ;; Still here?
    30163085  (compile-function-call form target representation))
Note: See TracChangeset for help on using the changeset viewer.