Ignore:
Timestamp:
12/26/04 14:54:07 (17 years ago)
Author:
piso
Message:

Unboxed fixnums (work in progress).

File:
1 edited

Legend:

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

    r8282 r8292  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.314 2004-12-21 20:25:55 piso Exp $
     4;;; $Id: jvm.lisp,v 1.315 2004-12-26 14:54:07 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    3939(defparameter *trust-user-type-declarations* t)
    4040
    41 (defmacro show (form)
    42   (let ((format-control (concatenate 'string (write-to-string form) " = ~S~%")))
    43     `(%format t ,format-control ,form)))
     41(defvar *enable-dformat* nil)
     42
     43(defun dformat (destination control-string &rest args)
     44  (when *enable-dformat*
     45    (apply #'sys::%format destination control-string args)))
    4446
    4547(defun inline-expansion (name)
     
    8486(defvar *pool-entries* nil)
    8587
    86 (defvar *stream* nil)
     88;; (defvar *stream* nil)
    8789(defvar *this-class* nil)
    8890
     
    146148  register ; register number or NIL
    147149  (level *nesting-level*)
    148   index)
     150  index
     151  (reads 0)
     152  (writes 0))
     153
     154;; obj can be a symbol or variable
     155;; returns variable or nil
     156(defun unboxed-fixnum-variable (obj)
     157  (cond ((symbolp obj)
     158         (let ((variable (find-visible-variable obj)))
     159           (if (and variable
     160                    (eq (variable-representation variable) :unboxed-fixnum))
     161               variable
     162               nil)))
     163        ((variable-p obj)
     164         (if (eq (variable-representation obj) :unboxed-fixnum)
     165             obj
     166             nil))
     167        (t
     168         nil)))
     169
     170(defun arg-is-fixnum-p (arg)
     171  (or (fixnump arg)
     172      (unboxed-fixnum-variable arg)))
    149173
    150174;; True for local functions defined with FLET or LABELS.
     
    178202
    179203(defun unboxed-fixnum-variable-p (obj)
    180   (let ((variable (and (symbolp obj)
    181                        (find-visible-variable obj))))
    182     (and variable
    183          (eq (variable-representation variable) :unboxed-fixnum))))
     204;;   (let ((variable (and (symbolp obj)
     205;;                        (find-visible-variable obj))))
     206;;     (and variable
     207;;          (eq (variable-representation variable) :unboxed-fixnum))))
     208  (unboxed-fixnum-variable obj))
    184209
    185210(defun allocate-register ()
    186   (prog1
    187    *register*
    188    (incf *register*)
    189    (when (< *registers-allocated* *register*)
    190      (setf *registers-allocated* *register*))))
     211;;   (prog1
     212;;    *register*
     213;;    (incf *register*)
     214;;    (when (< *registers-allocated* *register*)
     215;;      (setf *registers-allocated* *register*))))
     216  (let* ((register *register*)
     217         (next-register (1+ register)))
     218    (declare (type fixnum register next-register))
     219    (setf *register* next-register)
     220    (when (< *registers-allocated* next-register)
     221      (setf *registers-allocated* next-register))
     222    register))
    191223
    192224(defstruct local-function
     
    363395  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
    364396
     397(defun p1-quote (form)
     398  (if (numberp (second form))
     399      (second form)
     400      form))
     401
    365402(defun p1-setq (form)
    366403  (unless (= (length form) 3)
     
    391428
    392429(defun p1 (form)
    393   (if (atom form)
    394       (progn
    395 ;;         (assert (not (node-p form)))
    396         form)
    397       (let ((op (car form))
    398             handler)
    399         (cond ((symbolp op)
    400                (cond ((setf handler (get op 'p1-handler))
    401                       (funcall handler form))
    402                      ((macro-function op)
    403                       (p1 (macroexpand form)))
    404                      ((special-operator-p op)
    405                       (error "P1: unsupported special operator ~S" op))
    406                      (t
    407                       ;; Function call.
    408                       (let ((new-form (rewrite-function-call form)))
    409                         (when (neq new-form form)
    410                           (return-from p1 (p1 new-form))))
    411                       (let ((source-transform (source-transform op)))
    412                         (when source-transform
    413                           (let ((new-form (expand-source-transform form)))
    414                             (when (neq new-form form)
    415                               (return-from p1 (p1 new-form))))))
    416                       (let ((expansion (inline-expansion op)))
    417                         (when expansion
    418                           (return-from p1 (p1 (expand-inline form expansion)))))
    419                       (p1-default form))))
    420               ((and (consp op) (eq (car op) 'LAMBDA))
    421                (unless (and *current-compiland*
    422                             (compiland-contains-lambda *current-compiland*))
    423                  (do ((compiland *current-compiland* (compiland-parent compiland)))
    424                      ((null compiland))
    425                    (setf (compiland-contains-lambda compiland) t)))
    426                form)
    427               (t
    428                form)))))
     430  (cond
     431;;    ((and (symbolp form) (constantp form)) ; a DEFCONSTANT
     432;;     (let ((value (symbol-value form)))
     433;;       (if (numberp value)
     434;;           value
     435;;           form)))
     436   ((symbolp form)
     437    (cond
     438     ((constantp form) ; a DEFCONSTANT
     439      (let ((value (symbol-value form)))
     440        (if (numberp value)
     441            value
     442            form)))
     443     (t
     444      form)))
     445   ((atom form)
     446    form)
     447   (t
     448    (let ((op (car form))
     449          handler)
     450      (cond ((symbolp op)
     451             (cond ((setf handler (get op 'p1-handler))
     452                    (funcall handler form))
     453                   ((macro-function op)
     454                    (p1 (macroexpand form)))
     455                   ((special-operator-p op)
     456                    (error "P1: unsupported special operator ~S" op))
     457                   (t
     458                    ;; Function call.
     459                    (let ((new-form (rewrite-function-call form)))
     460                      (when (neq new-form form)
     461                        (return-from p1 (p1 new-form))))
     462                    (let ((source-transform (source-transform op)))
     463                      (when source-transform
     464                        (let ((new-form (expand-source-transform form)))
     465                          (when (neq new-form form)
     466                            (return-from p1 (p1 new-form))))))
     467                    (let ((expansion (inline-expansion op)))
     468                      (when expansion
     469                        (return-from p1 (p1 (expand-inline form expansion)))))
     470                    (p1-default form))))
     471            ((and (consp op) (eq (car op) 'LAMBDA))
     472             (unless (and *current-compiland*
     473                          (compiland-contains-lambda *current-compiland*))
     474               (do ((compiland *current-compiland* (compiland-parent compiland)))
     475                   ((null compiland))
     476                 (setf (compiland-contains-lambda compiland) t)))
     477             form)
     478            (t
     479             form))))))
    429480
    430481(defun install-p1-handler (symbol handler)
     
    452503(install-p1-handler 'progn                'p1-default)
    453504(install-p1-handler 'progv                'identity)
    454 (install-p1-handler 'quote                'identity)
     505(install-p1-handler 'quote                'p1-quote)
    455506(install-p1-handler 'return-from          'p1-return-from)
    456507(install-p1-handler 'setq                 'p1-setq)
     
    830881
    831882(defun emit-unbox-fixnum ()
     883  (declare (optimize speed))
    832884  (cond ((= *safety* 3)
    833885         (emit-invokestatic +lisp-fixnum-class+
     
    840892
    841893(defun emit-box-long ()
     894  (declare (optimize speed))
    842895  (emit-invokestatic +lisp-class+
    843896                     "number"
     
    894947             132 ; IINC
    895948             133 ; I2L
     949             136 ; L2I
    896950             153 ; IFEQ
    897951             154 ; IFNE
     952             155 ; IFGE
     953             156 ; IFGT
     954             157 ; IFGT
     955             158 ; IFLE
    898956             159 ; IF_ICMPEQ
    899957             160 ; IF_ICMPNE
     
    10451103  '(153 ; IFEQ
    10461104    154 ; IFNE
     1105    155 ; IFLT
     1106    156 ; IFGE
     1107    157 ; IFGT
     1108    158 ; IFLE
    10471109    159 ; IF_ICMPEQ
    10481110    160 ; IF_ICMPNE
     
    11981260             (emit-move-from-stack target)))
    11991261           (when (eq representation :unboxed-fixnum)
    1200              (%format t "resolve-variables calling emit-unbox-fixnum~%")
     1262             (dformat t "resolve-variables calling emit-unbox-fixnum~%")
    12011263             (emit-unbox-fixnum))))
    12021264        (207 ; VAR-SET
     
    14371499      bytes)))
    14381500
    1439 (defsubst write-u1 (n)
     1501(defsubst write-u1 (n stream)
    14401502  (declare (optimize speed))
    1441   (sys::write-8-bits n *stream*))
    1442 
    1443 (defun write-u2 (n)
     1503  (sys::write-8-bits n stream))
     1504
     1505(defun write-u2 (n stream)
    14441506  (declare (optimize speed))
    1445   (let ((stream *stream*))
    1446     (sys::write-8-bits (ash n -8) stream)
    1447     (sys::write-8-bits (logand n #xFF) stream)))
    1448 
    1449 (defun write-u4 (n)
     1507  (sys::write-8-bits (ash n -8) stream)
     1508  (sys::write-8-bits (logand n #xFF) stream))
     1509
     1510(defun write-u4 (n stream)
    14501511  (declare (optimize speed))
    1451   (write-u2 (ash n -16))
    1452   (write-u2 (logand n #xFFFF)))
    1453 
    1454 (defun write-s4 (n)
     1512  (write-u2 (ash n -16) stream)
     1513  (write-u2 (logand n #xFFFF) stream))
     1514
     1515(defun write-s4 (n stream)
    14551516  (declare (optimize speed))
    14561517  (cond ((minusp n)
    1457          (write-u4 (1+ (logxor (- n) #xFFFFFFFF))))
     1518         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
    14581519        (t
    1459          (write-u4 n))))
    1460 
    1461 (defun write-utf8 (string)
     1520         (write-u4 n stream))))
     1521
     1522(defun write-utf8 (string stream)
    14621523  (declare (optimize speed))
    1463   (let ((stream *stream*))
    1464     (dotimes (i (length string))
    1465       (declare (type fixnum i))
    1466       (let ((c (schar string i)))
    1467         (if (eql c #\null)
    1468             (progn
    1469               (sys::write-8-bits #xC0 stream)
    1470               (sys::write-8-bits #x80 stream))
    1471             (sys::write-8-bits (char-int c) stream))))))
     1524  (dotimes (i (length string))
     1525    (declare (type fixnum i))
     1526    (let ((c (schar string i)))
     1527      (if (eql c #\null)
     1528          (progn
     1529            (sys::write-8-bits #xC0 stream)
     1530            (sys::write-8-bits #x80 stream))
     1531          (sys::write-8-bits (char-int c) stream)))))
    14721532
    14731533(defun utf8-length (string)
     
    14811541    length))
    14821542
    1483 (defun write-constant-pool-entry (entry)
     1543(defun write-constant-pool-entry (entry stream)
     1544  (declare (optimize speed))
    14841545  (let ((tag (first entry)))
    1485     (write-u1 tag)
     1546    (write-u1 tag stream)
    14861547    (case tag
    14871548      (1 ; UTF8
    1488        (write-u2 (utf8-length (third entry)))
    1489        (write-utf8 (third entry)))
     1549       (write-u2 (utf8-length (third entry)) stream)
     1550       (write-utf8 (third entry) stream))
    14901551      (3 ; int
    1491        (write-s4 (second entry)))
     1552       (write-s4 (second entry) stream))
    14921553      ((5 6)
    1493        (write-u4 (second entry))
    1494        (write-u4 (third entry)))
     1554       (write-u4 (second entry) stream)
     1555       (write-u4 (third entry)) stream)
    14951556      ((9 10 11 12)
    1496        (write-u2 (second entry))
    1497        (write-u2 (third entry)))
     1557       (write-u2 (second entry) stream)
     1558       (write-u2 (third entry) stream))
    14981559      ((7 8)
    1499        (write-u2 (second entry)))
     1560       (write-u2 (second entry) stream))
    15001561      (t
    15011562       (error "WRITE-CP-ENTRY unhandled tag ~D~%" tag)))))
    15021563
    1503 (defun write-constant-pool ()
    1504   (write-u2 *pool-count*)
     1564(defun write-constant-pool (stream)
     1565  (declare (optimize speed))
     1566  (write-u2 *pool-count* stream)
    15051567  (dolist (entry (reverse *pool*))
    1506     (write-constant-pool-entry entry)))
     1568    (write-constant-pool-entry entry stream)))
    15071569
    15081570(defstruct field
     
    15831645    constructor))
    15841646
    1585 (defun write-exception-table (method)
     1647(defun write-exception-table (method stream)
    15861648  (let ((handlers (method-handlers method)))
    1587     (write-u2 (length handlers)) ; number of entries
     1649    (write-u2 (length handlers) stream) ; number of entries
    15881650    (dolist (handler handlers)
    1589       (write-u2 (symbol-value (handler-from handler)))
    1590       (write-u2 (symbol-value (handler-to handler)))
    1591       (write-u2 (symbol-value (handler-code handler)))
    1592       (write-u2 (handler-catch-type handler)))))
    1593 
    1594 (defun write-code-attr (method)
     1651      (write-u2 (symbol-value (handler-from handler)) stream)
     1652      (write-u2 (symbol-value (handler-to handler)) stream)
     1653      (write-u2 (symbol-value (handler-code handler)) stream)
     1654      (write-u2 (handler-catch-type handler) stream))))
     1655
     1656(defun write-code-attr (method stream)
     1657  (declare (optimize speed))
    15951658  (let* ((name-index (pool-name "Code"))
    15961659         (code (method-code method))
     
    16001663         (max-stack (or (method-max-stack method) 20))
    16011664         (max-locals (or (method-max-locals method) 1)))
    1602     (write-u2 name-index)
    1603     (write-u4 length)
    1604     (write-u2 max-stack)
    1605     (write-u2 max-locals)
    1606     (write-u4 code-length)
     1665    (write-u2 name-index stream)
     1666    (write-u4 length stream)
     1667    (write-u2 max-stack stream)
     1668    (write-u2 max-locals stream)
     1669    (write-u4 code-length stream)
    16071670    (dotimes (i code-length)
    1608       (write-u1 (svref code i)))
    1609     (write-exception-table method)
    1610     (write-u2 0) ; attributes count
     1671      (declare (type fixnum i))
     1672      (write-u1 (svref code i) stream))
     1673    (write-exception-table method stream)
     1674    (write-u2 0 stream) ; attributes count
    16111675    ))
    16121676
    1613 (defun write-method (method)
    1614   (write-u2 (or (method-access-flags method) #x1)) ; access flags
    1615   (write-u2 (method-name-index method))
    1616   (write-u2 (method-descriptor-index method))
    1617   (write-u2 1) ; attributes count
    1618   (write-code-attr method))
    1619 
    1620 (defun write-field (field)
    1621   (write-u2 (or (field-access-flags field) #x1)) ; access flags
    1622   (write-u2 (field-name-index field))
    1623   (write-u2 (field-descriptor-index field))
    1624   (write-u2 0)) ; attributes count
     1677(defun write-method (method stream)
     1678  (declare (optimize speed))
     1679  (write-u2 (or (method-access-flags method) #x1) stream) ; access flags
     1680  (write-u2 (method-name-index method) stream)
     1681  (write-u2 (method-descriptor-index method) stream)
     1682  (write-u2 1 stream) ; attributes count
     1683  (write-code-attr method stream))
     1684
     1685(defun write-field (field stream)
     1686  (declare (optimize speed))
     1687  (write-u2 (or (field-access-flags field) #x1) stream) ; access flags
     1688  (write-u2 (field-name-index field) stream)
     1689  (write-u2 (field-descriptor-index field) stream)
     1690  (write-u2 0 stream)) ; attributes count
    16251691
    16261692(defun declare-field (name descriptor)
     
    16321698
    16331699(defun sanitize (symbol)
     1700  (declare (optimize speed))
    16341701  (let* ((input (symbol-name symbol))
    16351702         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
    16361703    (dotimes (i (length input))
     1704      (declare (type fixnum i))
    16371705      (let ((c (char-upcase (char input i))))
    16381706        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
     
    16671735              g
    16681736              +lisp-symbol+)
    1669         (setq *static-code* *code*)
     1737        (setf *static-code* *code*)
     1738        (setf (gethash symbol *declared-symbols*) g)))
     1739    g))
     1740
     1741(defun declare-keyword (symbol)
     1742  (let ((g (gethash symbol *declared-symbols*)))
     1743    (unless g
     1744      (let ((*code* *static-code*))
     1745        (setf g (symbol-name (gensym)))
     1746        (declare-field g +lisp-symbol+)
     1747        (emit 'ldc (pool-string (symbol-name symbol)))
     1748        (emit-invokestatic "org/armedbear/lisp/Keyword"
     1749                           "internKeyword"
     1750                           "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
     1751                           0)
     1752        (emit 'putstatic
     1753              *this-class*
     1754              g
     1755              +lisp-symbol+)
     1756        (setf *static-code* *code*)
    16701757        (setf (gethash symbol *declared-symbols*) g)))
    16711758    g))
     
    17401827    f))
    17411828
    1742 (defun declare-keyword (symbol)
    1743   (let ((g (symbol-name (gensym)))
    1744         (*code* *static-code*))
    1745     (declare-field g +lisp-symbol+)
    1746     (emit 'ldc (pool-string (symbol-name symbol)))
    1747     (emit-invokestatic "org/armedbear/lisp/Keyword"
    1748                        "internKeyword"
    1749                        "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
    1750                        0)
    1751     (emit 'putstatic
    1752           *this-class*
    1753           g
    1754           +lisp-symbol+)
    1755     (setq *static-code* *code*)
    1756     g))
    1757 
    17581829(defun declare-fixnum (n)
     1830  (declare (type fixnum n))
    17591831  (let ((g (gethash n *declared-fixnums*)))
    17601832    (unless g
     
    20072079  (emit-move-from-stack target))
    20082080
    2009 (defun compile-binary-operation (op args &key (target *val*) representation)
    2010   (compile-form (first args) :target :stack)
    2011   (compile-form (second args) :target :stack)
    2012   (unless (and (single-valued-p (first args))
    2013                (single-valued-p (second args)))
    2014     (emit-clear-values))
    2015   (emit-invokevirtual +lisp-object-class+
    2016                       op
    2017                       "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    2018                       -1)
    2019   (when (eq representation :unboxed-fixnum)
    2020     (emit-unbox-fixnum))
    2021   (emit-move-from-stack target))
    2022 
    20232081(defparameter unary-operators (make-hash-table :test 'eq))
    20242082
     
    20672125  (let ((arg (first args)))
    20682126    (when (and (eq fun '1+) (symbolp arg))
    2069       (let ((variable (find-visible-variable arg)))
    2070         (when (and variable
    2071                    (eq (variable-representation variable) :unboxed-fixnum))
     2127      (dformat t "compile-function-call-1 1+ case~%")
     2128      (let ((variable (unboxed-fixnum-variable arg)))
     2129        (when variable
    20722130          (aver (variable-register variable))
    20732131          (emit 'iload (variable-register variable))
     
    20762134          (emit 'i2l)
    20772135          (emit 'ladd)
    2078           (emit-box-long)
     2136          (if (eq representation :unboxed-fixnum)
     2137              (emit 'l2i)
     2138              (emit-box-long))
    20792139          (return-from compile-function-call-1 t))))
    20802140    (let ((s (gethash fun unary-operators)))
     
    21242184(define-binary-operator 'sys::%rplacd        "_RPLACD")
    21252185
    2126 (defun compile-function-call-2 (fun args target representation)
    2127   (let ((translation (gethash fun binary-operators)))
     2186(defun compile-binary-operation (op args target representation)
     2187;;   (dformat t "compile-binary-operation op = ~S representation = ~S~%"
     2188;;            op representation)
     2189  (compile-form (first args) :target :stack)
     2190  (compile-form (second args) :target :stack)
     2191  (unless (and (single-valued-p (first args))
     2192               (single-valued-p (second args)))
     2193    (emit-clear-values))
     2194  (emit-invokevirtual +lisp-object-class+
     2195                      op
     2196                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2197                      -1)
     2198  (when (eq representation :unboxed-fixnum)
     2199    (emit-unbox-fixnum))
     2200  (emit-move-from-stack target))
     2201
     2202(defun compile-function-call-2 (op args target representation)
     2203  (let ((translation (gethash op binary-operators))
     2204        (first (first args))
     2205        (second (second args)))
    21282206    (if translation
    2129         (compile-binary-operation translation args :target target)
    2130         (case fun
     2207        (compile-binary-operation translation args target representation)
     2208        (case op
    21312209          (EQ
    2132            (compile-form (first args) :target :stack)
    2133            (compile-form (second args) :target :stack)
    2134            (unless (and (single-valued-p (first args))
    2135                         (single-valued-p (second args)))
     2210           (compile-form first :target :stack)
     2211           (compile-form second :target :stack)
     2212           (unless (and (single-valued-p first)
     2213                        (single-valued-p second))
    21362214             (emit-clear-values))
    21372215           (let ((label1 (gensym))
     
    21462224           t)
    21472225          (LIST
    2148            (compile-form (first args) :target :stack)
    2149            (compile-form (second args) :target :stack)
    2150            (unless (and (single-valued-p (first args))
    2151                         (single-valued-p (second args)))
     2226           (compile-form first :target :stack)
     2227           (compile-form second :target :stack)
     2228           (unless (and (single-valued-p first)
     2229                        (single-valued-p second))
    21522230             (emit-clear-values))
    21532231           (emit-invokestatic +lisp-class+
     
    21582236           t)
    21592237          (SYS::%STRUCTURE-REF
    2160            (when (fixnump (second args))
    2161              (compile-form (first args) :target :stack)
    2162              (maybe-emit-clear-values (first args))
    2163              (emit 'sipush (second args))
     2238           (when (fixnump second)
     2239             (compile-form first :target :stack)
     2240             (maybe-emit-clear-values first)
     2241             (emit 'sipush second)
    21642242             (emit-invokevirtual +lisp-object-class+
    21652243                                 "getSlotValue"
     
    21732251           nil)))))
    21742252
    2175 (defun compile-function-call-3 (fun args target)
    2176   (case fun
     2253(defun fixnum-or-unboxed-variable-p (arg)
     2254  (or (fixnump arg)
     2255      (unboxed-fixnum-variable arg)))
     2256
     2257(defun emit-push-int (arg)
     2258  (if (fixnump arg)
     2259      (emit-push-constant-int arg)
     2260      (let ((variable (unboxed-fixnum-variable arg)))
     2261        (if variable
     2262            (emit 'iload (variable-register variable))
     2263            (aver nil)))))
     2264
     2265(defun p2-eql (form &key (target *val*) representation)
     2266;;   (dformat t "p2-eql form = ~S~%" form)
     2267  (unless (= (length form) 3)
     2268    (error "Wrong number of arguments for EQL."))
     2269  (let ((arg1 (second form))
     2270        (arg2 (third form)))
     2271;;     (dformat t "arg1 = ~S~%" arg1)
     2272;;     (dformat t "arg2 = ~S~%" arg2)
     2273    (cond
     2274     ((and (fixnum-or-unboxed-variable-p arg1)
     2275           (fixnum-or-unboxed-variable-p arg2))
     2276;;       (dformat t "p2-eql case 1~%")
     2277      (emit-push-int arg1)
     2278      (emit-push-int arg2)
     2279      (let ((label1 (gensym))
     2280            (label2 (gensym)))
     2281        (emit 'if_icmpeq `,label1)
     2282        (emit-push-nil)
     2283        (emit 'goto `,label2)
     2284        (emit 'label `,label1)
     2285        (emit-push-t)
     2286        (emit 'label `,label2))
     2287      (emit-move-from-stack target))
     2288     ((fixnum-or-unboxed-variable-p arg1)
     2289      (emit-push-int arg1)
     2290      (compile-form arg2 :target :stack)
     2291      (maybe-emit-clear-values arg2)
     2292      (emit 'swap)
     2293      (emit-invokevirtual +lisp-object-class+
     2294                          "eql"
     2295                          "(I)Z"
     2296                          -1)
     2297      (let ((label1 (gensym))
     2298            (label2 (gensym)))
     2299        (emit 'ifne `,label1)
     2300        (emit-push-nil)
     2301        (emit 'goto `,label2)
     2302        (emit 'label `,label1)
     2303        (emit-push-t)
     2304        (emit 'label `,label2))
     2305      (emit-move-from-stack target))
     2306     ((fixnum-or-unboxed-variable-p arg2)
     2307      (compile-form arg1 :target :stack)
     2308      (maybe-emit-clear-values arg1)
     2309      (emit-push-int arg2)
     2310      (emit-invokevirtual +lisp-object-class+
     2311                          "eql"
     2312                          "(I)Z"
     2313                          -1)
     2314      (let ((label1 (gensym))
     2315            (label2 (gensym)))
     2316        (emit 'ifne `,label1)
     2317        (emit-push-nil)
     2318        (emit 'goto `,label2)
     2319        (emit 'label `,label1)
     2320        (emit-push-t)
     2321        (emit 'label `,label2))
     2322      (emit-move-from-stack target))
     2323     (t
     2324;;       (dformat t "p2-eql case 3~%")
     2325      (compile-form arg1 :target :stack)
     2326      (compile-form arg2 :target :stack)
     2327      (unless (and (single-valued-p arg1)
     2328                   (single-valued-p arg2))
     2329        (emit-clear-values))
     2330      (emit-invokevirtual +lisp-object-class+
     2331                          "EQL"
     2332                          "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2333                          -1)
     2334      (emit-move-from-stack target))))
     2335  )
     2336
     2337(defun compile-function-call-3 (op args target)
     2338  (case op
    21772339    (LIST
    21782340     (compile-form (first args) :target :stack)
     
    23052467    (emit-invokevirtual +lisp-thread-class+ "execute" descriptor stack-effect)))
    23062468
    2307 (defun compile-function-call (form &key (target *val*) representation)
     2469(defun compile-function-call (form target representation)
    23082470  (let ((new-form (rewrite-function-call form)))
    23092471    (when (neq new-form form)
     
    23452507          (emit-call-execute numargs)
    23462508          (emit-call-thread-execute numargs))
     2509      (when (eq representation :unboxed-fixnum)
     2510        (emit-unbox-fixnum))
    23472511      (emit-move-from-stack target))))
    23482512
     
    23802544    (error "Wrong number of arguments for FUNCALL."))
    23812545  (when (> *debug* *speed*)
    2382     (return-from compile-funcall (compile-function-call form :target target)))
     2546    (return-from compile-funcall (compile-function-call form target representation)))
    23832547  (let ((new-form (rewrite-function-call form)))
    23842548    (when (neq new-form form)
     
    24862650
    24872651(defun compile-test-2 (form negatep)
    2488   (let ((op (car form))
    2489         (args (cdr form)))
     2652;;   (dformat t "compile-test-2 ~S~%" form)
     2653  (let* ((op (car form))
     2654         (args (cdr form))
     2655         (arg (car args))
     2656         variable)
    24902657    (when (memq op '(NOT NULL))
    2491       (return-from compile-test-2 (compile-test (car args) (not negatep))))
     2658      (return-from compile-test-2 (compile-test arg (not negatep))))
     2659    (when (setf variable (unboxed-fixnum-variable arg))
     2660      (case op
     2661        (MINUSP
     2662         (dformat t "compile-test-2 minusp case~%")
     2663         (aver (variable-register variable))
     2664         (emit 'iload (variable-register variable))
     2665         (return-from compile-test-2 (if negatep 'iflt 'ifge))
     2666         )
     2667        ))
    24922668    (when (eq op 'SYMBOLP)
    24932669      (process-args args)
     
    25202696  (if negatep 'if_acmpne 'if_acmpeq))
    25212697
     2698(defun p2-numeric-comparison (form &key (target *val*) representation)
     2699  (let ((op (car form))
     2700        (args (cdr form)))
     2701    (case (length args)
     2702      (2
     2703       (let ((first (first args))
     2704             (second (second args))
     2705             var1 var2)
     2706         (cond
     2707          ((and (fixnump first) (fixnump second))
     2708           (dformat t "p2-numeric-comparison form = ~S~%" form)
     2709           (if (funcall op first second)
     2710               (emit-push-t)
     2711               (emit-push-nil))
     2712           (return-from p2-numeric-comparison))
     2713          ((fixnump second)
     2714           (dformat t "p2-numeric-comparison form = ~S~%" form)
     2715           (compile-form (car args) :target :stack)
     2716           (unless (single-valued-p first)
     2717             (emit-clear-values))
     2718           (emit-push-constant-int second)
     2719           (emit-invokevirtual +lisp-object-class+
     2720                               (case op
     2721                                 (<  "isLessThan")
     2722                                 (<= "isLessThanOrEqualTo")
     2723                                 (>  "isGreaterThan")
     2724                                 (>= "isGreaterThanOrEqualTo")
     2725                                 (=  "isEqualTo")
     2726                                 (/= "isNotEqualTo"))
     2727                               "(I)Z"
     2728                               -1)
     2729           ;; Java boolean on stack here
     2730           (let ((LABEL1 (gensym))
     2731                 (LABEL2 (gensym)))
     2732             (emit 'ifeq LABEL1)
     2733             (emit-push-t)
     2734             (emit 'goto LABEL2)
     2735             (label LABEL1)
     2736             (emit-push-nil)
     2737             (label LABEL2)
     2738             (emit-move-from-stack target))
     2739           (return-from p2-numeric-comparison))
     2740          ((and (setf var1 (unboxed-fixnum-variable first))
     2741                (setf var2 (unboxed-fixnum-variable second)))
     2742           (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form)
     2743           (let ((LABEL1 (gensym))
     2744                 (LABEL2 (gensym)))
     2745           (emit 'iload (variable-register var1))
     2746           (emit 'iload (variable-register var2))
     2747           (emit (case op
     2748                   (<  'if_icmpge)
     2749                   (<= 'if_icmpgt)
     2750                   (>  'if_icmple)
     2751                   (>= 'if_icmplt)
     2752                   (=  'if_icmpne)
     2753                   (/= 'if_icmpeq))
     2754                 LABEL1)
     2755             (emit-push-t)
     2756             (emit 'goto LABEL2)
     2757             (label LABEL1)
     2758             (emit-push-nil)
     2759             (label LABEL2)
     2760             (emit-move-from-stack target)
     2761             (return-from p2-numeric-comparison))
     2762           )
     2763          ) ; cond
     2764       ))))
     2765  ;; Still here?
     2766  (compile-function-call form target representation)
     2767  )
     2768
    25222769(defun compile-test-3 (form negatep)
     2770;;   (dformat t "compile-test-3 form = ~S~%" form)
    25232771  (let ((op (car form))
    25242772        (args (cdr form)))
     
    25282776    (let ((first (first args))
    25292777          (second (second args)))
    2530       ;; An experiment...
    25312778      (when (and (memq op '(< <= > >= = /=)) (fixnump second))
    2532         (when (symbolp (first args))
    2533           (let ((variable (find-visible-variable (first args))))
    2534             (when (and variable
    2535                        (eq (variable-representation variable) :unboxed-fixnum))
    2536               (%format t "compile-test-3 unboxed fixnum constant comparison case~%")
    2537               (aver (variable-register variable))
    2538               (emit 'iload (variable-register variable))
    2539               (emit-push-constant-int (second args))
    2540               (case op
    2541                 (<
    2542                  (return-from compile-test-3 (if negatep 'if_icmplt 'if_icmpge)))
    2543                 (<=
    2544                  (return-from compile-test-3 (if negatep 'if_icmple 'if_icmpgt)))
    2545                 (>
    2546                  (return-from compile-test-3 (if negatep 'if_icmpgt 'if_icmple)))
    2547                 (>=
    2548                  (return-from compile-test-3 (if negatep 'if_icmpge 'if_icmplt)))
    2549                 (=
    2550                  (return-from compile-test-3 (if negatep 'if_icmpeq 'if_icmpne)))
    2551                 (/=
    2552                  (return-from compile-test-3 (if negatep 'if_icmpne 'if_icmpeq)))
    2553                 ))))
     2779        (let ((variable (unboxed-fixnum-variable first)))
     2780          (when variable
     2781            (dformat t "compile-test-3 unboxed fixnum constant comparison case~%")
     2782            (aver (variable-register variable))
     2783            (emit 'iload (variable-register variable))
     2784            (emit-push-constant-int second)
     2785            (case op
     2786              (<
     2787               (return-from compile-test-3 (if negatep 'if_icmplt 'if_icmpge)))
     2788              (<=
     2789               (return-from compile-test-3 (if negatep 'if_icmple 'if_icmpgt)))
     2790              (>
     2791               (return-from compile-test-3 (if negatep 'if_icmpgt 'if_icmple)))
     2792              (>=
     2793               (return-from compile-test-3 (if negatep 'if_icmpge 'if_icmplt)))
     2794              (=
     2795               (return-from compile-test-3 (if negatep 'if_icmpeq 'if_icmpne)))
     2796              (/=
     2797               (return-from compile-test-3 (if negatep 'if_icmpne 'if_icmpeq)))
     2798              )))
     2799
    25542800        ;; Otherwise...
    2555         (compile-form (car args) :target :stack)
    2556         (unless (single-valued-p first)
    2557           (emit-clear-values))
     2801;;         (dformat t "compile-test-3 constant comparison case~%")
     2802        (compile-form first :target :stack)
     2803        (maybe-emit-clear-values first)
    25582804        (emit-push-constant-int second)
    25592805        (emit-invokevirtual +lisp-object-class+
     
    25692815        (return-from compile-test-3 (if negatep 'ifne 'ifeq)))
    25702816
    2571       (when (and (eq op '<) (unboxed-fixnum-variable-p first))
    2572         (%format t "compile-test-3 unboxed fixnum variable comparison case~%")
    2573         (aver (variable-register (find-visible-variable first)))
    2574         (emit 'iload (variable-register (find-visible-variable first)))
    2575         (compile-form second :target :stack)
    2576         (emit 'swap)
    2577         (emit-invokevirtual +lisp-object-class+
    2578                             "isGreaterThan"
    2579                             "(I)Z"
    2580                             -1)
    2581         (return-from compile-test-3 (if negatep 'ifne 'ifeq))))
     2817      (when (eq op '<)
     2818        (let ((variable (unboxed-fixnum-variable first)))
     2819          (when variable
     2820            (dformat t "compile-test-3 unboxed fixnum variable comparison case~%")
     2821            (aver (variable-register variable))
     2822            (emit 'iload (variable-register variable))
     2823            (compile-form second :target :stack)
     2824            (emit 'swap)
     2825            (emit-invokevirtual +lisp-object-class+
     2826                                "isGreaterThan"
     2827                                "(I)Z"
     2828                                -1)
     2829            (return-from compile-test-3 (if negatep 'ifne 'ifeq))))))
    25822830
    25832831    (let ((s (cdr (assq op
     
    25922840                          (EQUALP . "equalp"))))))
    25932841      (when s
    2594         (process-args args)
    2595         (emit-invokevirtual +lisp-object-class+
    2596                             s
    2597                             "(Lorg/armedbear/lisp/LispObject;)Z"
    2598                             -1)
    2599         (return-from compile-test-3 (if negatep 'ifne 'ifeq)))))
     2842        (let ((first (first args))
     2843              (second (second args))
     2844              variable)
     2845          (cond
     2846           ((fixnump second)
     2847            (compile-form first :target :stack)
     2848            (maybe-emit-clear-values first)
     2849            (emit-push-constant-int second)
     2850            (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))
     2851           ((setf variable (unboxed-fixnum-variable second))
     2852            (compile-form first :target :stack)
     2853            (maybe-emit-clear-values first)
     2854            (aver (variable-register variable))
     2855            (emit 'iload (variable-register variable))
     2856            (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))
     2857           (t
     2858            (process-args args)
     2859            (emit-invokevirtual +lisp-object-class+
     2860                                s
     2861                                "(Lorg/armedbear/lisp/LispObject;)Z"
     2862                                -1)))
     2863          (return-from compile-test-3 (if negatep 'ifne 'ifeq))))))
    26002864
    26012865  ;; Otherwise...
     
    28693133         (form (block-form block))
    28703134         (*visible-variables* *visible-variables*)
    2871          (specials ())
    28723135         (varlist (cadr form))
    28733136         (specialp nil))
     
    28863149    (ecase (car form)
    28873150      (LET
    2888        (compile-let-bindings block specials))
     3151       (compile-let-bindings block))
    28893152      (LET*
    2890        (compile-let*-bindings block specials)))
     3153       (compile-let*-bindings block)))
    28913154    ;; Body of LET/LET*.
    28923155    (compile-progn-body (cddr form) target)
     
    28973160      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
    28983161
    2899 (defun compile-let-bindings (block specials)
     3162(defun compile-let-bindings (block)
    29003163  (dolist (variable (block-vars block))
    29013164    (unless (variable-special-p variable)
     
    29203183                      (variable-declared-type variable)
    29213184                      (subtypep (variable-declared-type variable) 'FIXNUM))
    2922                  (%format t "compile-let-bindings unboxed-fixnum case~%")
     3185                 (dformat t "compile-let-bindings unboxed-fixnum case~%")
    29233186                 (setf (variable-representation variable) :unboxed-fixnum)
    29243187                 (compile-form initform :target :stack :representation :unboxed-fixnum))
     
    29513214    (push variable *all-variables*)))
    29523215
    2953 (defun compile-let*-bindings (block specials)
     3216(defun compile-let*-bindings (block)
    29543217  (let ((must-clear-values nil))
    29553218    ;; Generate code to evaluate initforms and bind variables.
     
    29763239                      (variable-declared-type variable)
    29773240                      (subtypep (variable-declared-type variable) 'FIXNUM))
    2978                  (%format t "compile-let*-bindings unboxed-fixnum case~%")
     3241                 (dformat t "compile-let*-bindings unboxed-fixnum case~%")
    29793242                 (setf (variable-representation variable) :unboxed-fixnum)
    29803243                 (compile-form initform :target :stack :representation :unboxed-fixnum)
     
    31243387    (label EXIT)
    31253388    (when must-clear-values
    3126 ;;       (%format t "compile-tagbody-node calling emit-clear-values~%")
     3389;;       (dformat t "compile-tagbody-node calling emit-clear-values~%")
    31273390      (emit-clear-values))
    31283391    ;; TAGBODY returns NIL.
     
    32173480
    32183481(defun compile-block-node (block target)
    3219 ;;   (%format t "COMPILE-BLOCK-NODE ~S block-return-p = ~S~%"
     3482;;   (dformat t "COMPILE-BLOCK-NODE ~S block-return-p = ~S~%"
    32203483;;            (block-name block) (block-return-p block))
    32213484  (unless (block-node-p block)
     
    32913554
    32923555      ;; Added Dec 9 2004 7:28 AM
    3293 ;;       (%format t "compile-return-from calling emit-clear-values~%")
     3556;;       (dformat t "compile-return-from calling emit-clear-values~%")
    32943557      (emit-clear-values)
    32953558
     
    33513614               (unless must-clear-values
    33523615                 (unless (single-valued-p form)
    3353 ;;                    (%format t "compile-progn-body not single-valued: ~S~%" form)
     3616;;                    (dformat t "compile-progn-body not single-valued: ~S~%" form)
    33543617                   (setf must-clear-values t)))))))))
    33553618
     
    36923955          (emit-move-from-stack target)
    36933956          (return-from compile-ash t)))))
    3694   (compile-function-call form :target target))
     3957  (compile-function-call form target representation))
    36953958
    36963959(defun compile-logand (form &key (target *val*) representation)
     
    37133976          (emit-move-from-stack target)
    37143977          (return-from compile-logand t)))))
    3715   (compile-function-call form :target target))
     3978  (compile-function-call form target representation))
    37163979
    37173980(defun compile-length (form &key (target *val*) representation)
     
    37594022    (when (neq new-form form)
    37604023      (return-from compile-plus (compile-form new-form :target target))))
    3761   (let* ((args (cdr form)))
    3762     (case (length args)
    3763       (2
    3764        (let ((first (first args))
    3765              (second (second args)))
     4024  (case (length form)
     4025    (3
     4026     (let* ((args (cdr form))
     4027            (arg1 (first args))
     4028            (arg2 (second args))
     4029            (var1 (unboxed-fixnum-variable arg1))
     4030            (var2 (unboxed-fixnum-variable arg2)))
     4031       (cond
     4032        ((and (numberp arg1) (numberp arg2))
     4033         (compile-constant (+ arg1 arg2) :target target))
     4034        ((and var1 var2)
     4035         (dformat t "compile-plus case 1~%")
     4036         (aver (variable-register var1))
     4037         (emit 'iload (variable-register var1))
     4038         (emit 'i2l)
     4039         (aver (variable-register var2))
     4040         (emit 'iload (variable-register var2))
     4041         (emit 'i2l)
     4042         (emit 'ladd)
     4043         (when (null representation)
     4044           (emit-box-long))
     4045         (emit-move-from-stack target representation))
     4046        ((and var1 (fixnump arg2))
     4047         (dformat t "compile-plus case 2~%")
     4048         (aver (variable-register var1))
    37664049         (cond
    3767           ((and (numberp first) (numberp second))
    3768            (compile-constant (+ first second) :target target))
    3769           ((eql first 1)
    3770            (compile-form second :target :stack)
    3771            (emit-invoke-method "incr" target representation))
    3772           ((eql second 1)
    3773            (compile-form first :target :stack)
    3774            (emit-invoke-method "incr" target representation))
    3775           ((fixnump second)
    3776            (compile-form first :target :stack)
    3777            (maybe-emit-clear-values first)
    3778            (emit-push-constant-int second)
    3779            (emit-invokevirtual +lisp-object-class+
    3780                                "add"
    3781                                "(I)Lorg/armedbear/lisp/LispObject;"
    3782                                -1)
    3783            (when (eq representation :unboxed-fixnum)
    3784              (emit-unbox-fixnum))
    3785            (emit-move-from-stack target))
    3786           ((and (unboxed-fixnum-variable-p first)
    3787                 (unboxed-fixnum-variable-p second))
    3788            (aver (variable-register (find-visible-variable first)))
    3789            (emit 'iload (variable-register (find-visible-variable first)))
     4050          ((eq representation :unboxed-fixnum)
     4051           (emit-push-int var1)
     4052           (emit-push-int arg2)
     4053           (emit 'iadd))
     4054          (t
     4055           (emit-push-int var1)
    37904056           (emit 'i2l)
    3791            (aver (variable-register (find-visible-variable second)))
    3792            (emit 'iload (variable-register (find-visible-variable second)))
     4057           (emit-push-int arg2)
    37934058           (emit 'i2l)
    37944059           (emit 'ladd)
    3795            (emit-box-long)
    3796            (emit-move-from-stack target))
     4060           (emit-box-long)))
     4061         (emit-move-from-stack target representation))
     4062        ((and (fixnump arg1) var2)
     4063         (dformat t "compile-plus case 3~%")
     4064         (aver (variable-register var2))
     4065         (cond
     4066          ((eq representation :unboxed-fixnum)
     4067           (emit-push-int arg1)
     4068           (emit-push-int var2)
     4069           (emit 'iadd))
    37974070          (t
    3798            (compile-binary-operation "add" args
    3799                                      :target target
    3800                                      :representation representation)))))
    3801       (t
    3802        (compile-function-call form :target target)))))
     4071           (emit-push-int arg1)
     4072           (emit 'i2l)
     4073           (emit-push-int var2)
     4074           (emit 'i2l)
     4075           (emit 'ladd)
     4076           (emit-box-long)))
     4077         (emit-move-from-stack target representation))
     4078        ((eql arg1 1)
     4079         (dformat t "compile-plus case 4~%")
     4080         (compile-form arg2 :target :stack)
     4081         (maybe-emit-clear-values arg2)
     4082         (emit-invoke-method "incr" target representation))
     4083        ((eql arg2 1)
     4084         (dformat t "compile-plus case 5~%")
     4085         (compile-form arg1 :target :stack)
     4086         (maybe-emit-clear-values arg2)
     4087         (emit-invoke-method "incr" target representation))
     4088        ((arg-is-fixnum-p arg1)
     4089         (dformat t "compile-plus case 6~%")
     4090         (compile-form arg2 :target :stack)
     4091         (maybe-emit-clear-values arg2)
     4092         (emit-push-int arg1)
     4093         (emit-invokevirtual +lisp-object-class+
     4094                             "add"
     4095                             "(I)Lorg/armedbear/lisp/LispObject;"
     4096                             -1)
     4097         (when (eq representation :unboxed-fixnum)
     4098           (emit-unbox-fixnum))
     4099         (emit-move-from-stack target representation))
     4100        ((arg-is-fixnum-p arg2)
     4101         (dformat t "compile-plus case 7~%")
     4102         (compile-form arg1 :target :stack)
     4103         (maybe-emit-clear-values arg1)
     4104         (emit-push-int arg2)
     4105         (emit-invokevirtual +lisp-object-class+
     4106                             "add"
     4107                             "(I)Lorg/armedbear/lisp/LispObject;"
     4108                             -1)
     4109         (when (eq representation :unboxed-fixnum)
     4110           (emit-unbox-fixnum))
     4111         (emit-move-from-stack target representation))
     4112        (t
     4113         (dformat t "compile-plus case 8~%")
     4114         (compile-binary-operation "add" args target representation)))))
     4115    (t
     4116     (dformat t "compile-plus case 9~%")
     4117     (compile-function-call form target representation))))
    38034118
    38044119(defun compile-minus (form &key (target *val*) representation)
     
    38304145             (emit-invoke-method "decr" target representation))))
    38314146          ((fixnump second)
    3832            (%format t "compile-minus fixnump second case~%")
     4147           (dformat t "compile-minus fixnump second case~%")
    38334148           (cond
    38344149            ((unboxed-fixnum-variable-p first)
    3835              (%format t "unboxed-fixnum-variable-p first case~%")
     4150             (dformat t "unboxed-fixnum-variable-p first case~%")
    38364151             (aver (variable-register (find-visible-variable first)))
    38374152             (emit 'iload (variable-register (find-visible-variable first)))
     
    38544169             (emit-move-from-stack target representation))))
    38554170          (t
    3856            (compile-binary-operation "subtract" args
    3857                                      :target target
    3858                                      :representation representation)))))
     4171           (compile-binary-operation "subtract" args target representation)))))
    38594172      (t
    3860        (compile-function-call form :target target)))))
     4173       (compile-function-call form target representation)))))
    38614174
    38624175(defun compile-schar (form &key (target *val*) representation)
     
    38774190
    38784191(defun compile-aref (form &key (target *val*) representation)
    3879 ;;   (%format t "compile-aref form = ~S~%" form)
     4192;;   (dformat t "compile-aref form = ~S~%" form)
    38804193  (unless (= (length form) 3)
    3881     (return-from compile-aref (compile-function-call form :target target)))
     4194    (return-from compile-aref (compile-function-call form target representation)))
    38824195  (compile-form (second form) :target :stack)
    38834196  (compile-form (third form) :target :stack :representation :unboxed-fixnum)
     
    38974210           :format-arguments (list (car form))))
    38984211  (let ((arg (second form)))
    3899 ;;     (%format t "arg = ~S~%" arg)
     4212;;     (dformat t "arg = ~S~%" arg)
    39004213    (cond ((null arg)
    39014214           (emit-push-t))
    39024215          ((and (constantp arg) (not (block-node-p arg)))
    3903 ;;            (%format t "compile-not/null constantp case~%")
     4216;;            (dformat t "compile-not/null constantp case~%")
    39044217           (emit-push-nil))
    39054218          ((and (consp arg)
     
    39684281       (emit-move-from-stack target))
    39694282      (t
    3970        (compile-function-call form :target target)))))
     4283       (compile-function-call form target representation)))))
    39714284
    39724285(defun compile-special-reference (name target representation)
     
    40044317      (compile-special-reference name target representation))
    40054318     ((eq (variable-representation variable) :unboxed-fixnum)
    4006       (%format t "compile-variable-reference unboxed-fixnum case~%")
     4319      (dformat t "compile-variable-reference unboxed-fixnum case~%")
    40074320      (cond
    40084321       ((eq representation :unboxed-fixnum)
     
    40104323        (emit 'iload (variable-register variable)))
    40114324       (t
    4012         (%format t "compile-variable-reference constructing boxed fixnum for ~S~%"
     4325        (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%"
    40134326                 name)
    40144327        (emit 'new +lisp-fixnum-class+)
     
    40194332      (emit-move-from-stack target representation))
    40204333     (t
    4021 ;;       (%format t "compile-variable-reference name = ~S representation = ~S~%"
     4334;;       (dformat t "compile-variable-reference name = ~S representation = ~S~%"
    40224335;;                name representation)
    40234336      (emit 'var-ref variable target representation)))))
     
    40314344
    40324345(defun compile-setq (form &key (target *val*) representation)
    4033 ;;   (%format t "compile-setq form = ~S target = ~S representation = ~S~%"
     4346;;   (dformat t "compile-setq form = ~S target = ~S representation = ~S~%"
    40344347;;            form target representation)
    40354348  (unless (= (length form) 3)
     
    40644377                    (equal value-form (list '+ (variable-name variable) 1))
    40654378                    (equal value-form (list '+ 1 (variable-name variable)))))
    4066            (%format t "compile-setq incf unboxed-fixnum case~%")
     4379           (dformat t "compile-setq incf unboxed-fixnum case~%")
    40674380           (emit 'iinc (variable-register variable) 1)
    40684381           (when target
    4069              (%format t "compile-setq constructing boxed fixnum for ~S~%"
     4382             (dformat t "compile-setq constructing boxed fixnum for ~S~%"
    40704383                      (variable-name variable))
    40714384             (emit 'new +lisp-fixnum-class+)
     
    40764389             (emit-move-from-stack target)))
    40774390          ((eq (variable-representation variable) :unboxed-fixnum)
    4078            (%format t "compile-setq unboxed-fixnum case value-form = ~S~%" value-form)
     4391           (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%" value-form)
    40794392           (compile-form value-form :target :stack)
    40804393           (maybe-emit-clear-values value-form)
     
    42854598                         (error "COMPILE-FORM: unsupported special operator ~S" op))
    42864599                        (t
    4287                          (compile-function-call form
    4288                                                 :target target
    4289                                                 :representation representation))))
     4600                         (compile-function-call form target representation))))
    42904601                 ((and (consp op) (eq (car op) 'LAMBDA))
    42914602                  (let ((new-form (list* 'FUNCALL form)))
     
    42964607                  (error "COMPILE-FORM unhandled case ~S" form)))))
    42974608        ((symbolp form)
    4298 ;;          (%format t "compile-form symbolp case form = ~S~%" form)
     4609;;          (dformat t "compile-form symbolp case form = ~S~%" form)
    42994610         (cond
    43004611          ((null form)
     
    43154626             (if (eq expansion form)
    43164627                 (compile-variable-reference form target representation)
    4317                  (compile-form expansion :target target))))))
     4628                 (compile-form expansion :target target :representation representation))))))
    43184629        ((block-node-p form)
    43194630         (cond ((equal (block-name form) '(TAGBODY))
     
    43244635                (compile-block-node form target))))
    43254636        ((constantp form)
    4326 ;;          (%format t "compile-form constantp case~%")
     4637;;          (dformat t "compile-form constantp case~%")
    43274638         (compile-constant form :target target :representation representation))
    43284639        (t
     
    43704681
    43714682    ;; Write out the class file.
    4372     (with-open-file (*stream* classfile
    4373                               :direction :output
    4374                               :element-type '(unsigned-byte 8)
    4375                               :if-exists :supersede)
    4376       (write-u4 #xCAFEBABE)
    4377       (write-u2 3)
    4378       (write-u2 45)
    4379       (write-constant-pool)
     4683    (with-open-file (stream classfile
     4684                            :direction :output
     4685                            :element-type '(unsigned-byte 8)
     4686                            :if-exists :supersede)
     4687      (write-u4 #xCAFEBABE stream)
     4688      (write-u2 3 stream)
     4689      (write-u2 45 stream)
     4690      (write-constant-pool stream)
    43804691      ;; access flags
    4381       (write-u2 #x21)
    4382       (write-u2 this-index)
    4383       (write-u2 super-index)
     4692      (write-u2 #x21 stream)
     4693      (write-u2 this-index stream)
     4694      (write-u2 super-index stream)
    43844695      ;; interfaces count
    4385       (write-u2 0)
     4696      (write-u2 0 stream)
    43864697      ;; fields count
    4387       (write-u2 (length *fields*))
     4698      (write-u2 (length *fields*) stream)
    43884699      ;; fields
    43894700      (dolist (field *fields*)
    4390         (write-field field))
     4701        (write-field field stream))
    43914702      ;; methods count
    4392       (write-u2 2)
     4703      (write-u2 2 stream)
    43934704      ;; methods
    4394       (write-method execute-method)
    4395       (write-method constructor)
     4705      (write-method execute-method stream)
     4706      (write-method constructor stream)
    43964707      ;; attributes count
    4397       (write-u2 0))))
     4708      (write-u2 0 stream))))
    43984709
    43994710(defun compile-1 (compiland)
     
    44034714    ;; Pass 1.
    44044715    (setf precompiled-form (p1 precompiled-form))
    4405 
     4716    ;; Pass 2.
    44064717    (let* ((*speed* *speed*)
    44074718           (*safety* *safety*)
     
    45224833                       (when variable
    45234834                         (setf (variable-declared-type variable) (cadr decl))
    4524                          (when (and (subtypep (variable-declared-type variable) 'FIXNUM)
    4525                                     (not (variable-special-p variable)))
     4835                         (when (and (variable-register variable)
     4836                                    (not (variable-special-p variable))
     4837                                    (subtypep (variable-declared-type variable) 'FIXNUM))
    45264838                           (setf (variable-representation variable) :unboxed-fixnum))))))))))))
    45274839
     
    46384950
    46394951(defun compile-defun (name form environment &optional (classfile "out.class"))
    4640   ;;   (%format t "COMPILE-DEFUN ~S ~S~%" name classfile)
     4952  ;;   (dformat t "COMPILE-DEFUN ~S ~S~%" name classfile)
    46414953  (unless (eq (car form) 'LAMBDA)
    46424954    (return-from compile-defun nil))
     
    47765088                             values))
    47775089
    4778 (install-p2-handler '+    'compile-plus)
    4779 (install-p2-handler '-    'compile-minus)
    4780 (install-p2-handler 'not  'compile-not/null)
    4781 (install-p2-handler 'null 'compile-not/null)
     5090(install-p2-handler '<      'p2-numeric-comparison)
     5091(install-p2-handler '<=     'p2-numeric-comparison)
     5092(install-p2-handler '>      'p2-numeric-comparison)
     5093(install-p2-handler '>=     'p2-numeric-comparison)
     5094(install-p2-handler '=      'p2-numeric-comparison)
     5095(install-p2-handler '/=     'p2-numeric-comparison)
     5096(install-p2-handler '+      'compile-plus)
     5097(install-p2-handler '-      'compile-minus)
     5098(install-p2-handler 'eql    'p2-eql)
     5099(install-p2-handler 'not    'compile-not/null)
     5100(install-p2-handler 'null   'compile-not/null)
    47825101
    47835102(defun process-optimization-declarations (forms)
Note: See TracChangeset for help on using the changeset viewer.