Changeset 13153


Ignore:
Timestamp:
01/16/11 12:02:54 (13 years ago)
Author:
ehuelsmann
Message:

First batch of UNSAFE-P function conversions.

Location:
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r13151 r13153  
    11541154  '(
    11551155
    1156      constantp endp evenp floatp integerp listp minusp
    1157      numberp oddp plusp rationalp realp
    1158      ;; predicates not marked as such?
    1159        simple-vector-p
    1160        stringp
    1161        symbolp
    1162        vectorp
    1163        zerop
    1164        atom
    1165        consp
    1166        fixnump
    1167        packagep
    1168        readtablep
    1169        characterp
    1170        bit-vector-p
    1171        SIMPLE-TYPEP
    1172 
    1173      declare
    1174      multiple-value-call
    1175      multiple-value-list
    1176      multiple-value-prog1
    1177      nth
    1178      progn
    1179 
    1180      EQL EQUAL
    1181      + - / *
    1182      < < > >= = /=
    1183      ASH
    1184      AREF
    1185      RPLACA RPLACD
    11861156     %ldb
    11871157     and
    11881158     aset
    1189      car
    1190      cdr
    11911159     char
    11921160     char-code
    … …  
    12001168     delete
    12011169     elt
    1202      eq
    1203      eql
    12041170     find-class
    12051171     funcall
    … …  
    12101176     gethash
    12111177     gethash1
    1212      if
    12131178     sys::%length
    12141179     list
    … …  
    12261191     min
    12271192     mod
    1228      neq
    12291193     not
    12301194     nthcdr

  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13151 r13153  
    672672  `(let (*saved-operands*
    673673   *operand-representations*
    674    (*register* *register*)) ;; hmm can we do this?? either body
     674   (*register* *register*)
     675         ) ;; hmm can we do this?? either body
    675676                                  ;; could allocate registers ...
    676677     ,@argument-buildup-body
    … …  
    681682  "Load any operands which have been saved into registers
    682683back onto the stack in preparation of the execution of the opcode."
    683   (dolist (operand (reverse *saved-operands*))
    684     (emit 'aload operand)))
     684  (mapcar #'emit-push-register
     685          (reverse *saved-operands*)
     686          (reverse *operand-representations*)))
    685687
    686688(defun save-existing-operands ()
    687689  "If any operands have been compiled to the stack,
    688690save them in registers."
    689   (dotimes (i (length *operand-representations*))
     691  (dolist (representation *operand-representations*)
    690692    (let ((register (allocate-register)))
    691693      (push register *saved-operands*)
    692       (emit 'astore register)))
     694      (emit-move-from-stack register representation)))
    693695
    694696  (setf *saved-operands* (nreverse *saved-operands*)))
    695697
    696 (defun compile-operand (form representation)
     698(defun compile-operand (form representation &optional cast)
    697699  "Compiles `form` into `representation`, storing the resulting value
    698700on the operand stack, if it's safe to do so. Otherwise stores the value
    … …  
    705707   
    706708    (compile-form form 'stack representation)
     709    (when cast
     710      (emit-checkcast cast))
    707711    (when unsafe
    708712      (let ((register (allocate-register)))
    709713  (push register *saved-operands*)
    710   (assert (null representation))
    711   (emit 'astore register)))
     714  (emit-move-from-stack register representation)))
    712715   
    713716  (push representation *operand-representations*)))
    … …  
    830833         (sys::%format t "emit-move-from-stack general case~%")
    831834         (aver nil))))
     835
     836(defknown emit-push-register (t &optional t) t)
     837(defun emit-push-register (source &optional representation)
     838  (declare (optimize speed))
     839  (assert (fixnump source))
     840  (emit (ecase representation
     841               ((:int :boolean :char)
     842                        'iload)
     843               (:long   'lload)
     844               (:float  'fload)
     845               (:double 'dload)
     846               ((nil)   'aload))
     847        source))
    832848
    833849;; Expects value on stack.
    … …  
    15971613  (let ((arg1 (car args))
    15981614        (arg2 (cadr args)))
    1599     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1600                                                arg2 'stack nil)
    1601     (emit-invokevirtual +lisp-object+ op
    1602                         (lisp-object-arg-types 1) +lisp-object+)
     1615    (with-operand-accumulation
     1616        ((compile-operand arg1 nil)
     1617         (compile-operand arg2 nil)
     1618         (maybe-emit-clear-values arg1 arg2))
     1619      (emit-invokevirtual +lisp-object+ op
     1620                          (lisp-object-arg-types 1) +lisp-object+))
    16031621    (fix-boxing representation nil)
    16041622    (emit-move-from-stack target representation)))
    … …  
    16501668         (arg1 (%car args))
    16511669         (arg2 (%cadr args)))
    1652     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1653                                                arg2 'stack nil)
    1654      (let ((LABEL1 (gensym))
    1655            (LABEL2 (gensym)))
    1656        (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1)
    1657        (emit-push-true representation)
    1658        (emit 'goto LABEL2)
    1659        (label LABEL1)
    1660        (emit-push-false representation)
    1661        (label LABEL2))
     1670    (with-operand-accumulation
     1671         ((compile-operand arg1 nil)
     1672          (compile-operand arg2 nil)
     1673          (maybe-emit-clear-values arg1 arg2))
     1674      (let ((LABEL1 (gensym))
     1675            (LABEL2 (gensym)))
     1676        (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1)
     1677        (emit-push-true representation)
     1678        (emit 'goto LABEL2)
     1679        (label LABEL1)
     1680        (emit-push-false representation)
     1681        (label LABEL2)))
    16621682     (emit-move-from-stack target representation))
    16631683   t)
    … …  
    16771697    (cond ((and (fixnum-type-p type1)
    16781698                (fixnum-type-p type2))
    1679            (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    1680                                                       arg2 'stack :int)
     1699           (with-operand-accumulation
     1700                ((compile-operand arg1 :int)
     1701                 (compile-operand arg2 :int)
     1702                 (maybe-emit-clear-values arg1 arg2)))
    16811703           (let ((label1 (gensym))
    16821704                 (label2 (gensym)))
    … …  
    16881710             (label label2)))
    16891711          ((fixnum-type-p type2)
    1690            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1691                                                       arg2 'stack :int)
     1712           (with-operand-accumulation
     1713                ((compile-operand arg1 nil)
     1714                 (compile-operand arg2 :int)
     1715                 (maybe-emit-clear-values arg1 arg2)))
    16921716           (emit-ifne-for-eql representation '(:int)))
    16931717          ((fixnum-type-p type1)
    1694            (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    1695                                                       arg2 'stack nil)
     1718           (with-operand-accumulation
     1719                ((compile-operand arg1 :int)
     1720                 (compile-operand arg2 nil)
     1721                 (maybe-emit-clear-values arg1 arg2)))
    16961722           (emit 'swap)
    16971723           (emit-ifne-for-eql representation '(:int)))
    16981724          ((eq type2 'CHARACTER)
    1699            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1700                                                       arg2 'stack :char)
     1725           (with-operand-accumulation
     1726                ((compile-operand arg1 nil)
     1727                 (compile-operand arg2 :char)
     1728                 (maybe-emit-clear-values arg1 arg2)))
    17011729           (emit-ifne-for-eql representation '(:char)))
    17021730          ((eq type1 'CHARACTER)
    1703            (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    1704                                                       arg2 'stack nil)
     1731           (with-operand-accumulation
     1732                ((compile-operand arg1 :char)
     1733                 (compile-operand arg2 nil)
     1734                 (maybe-emit-clear-values arg1 arg2)))
    17051735           (emit 'swap)
    17061736           (emit-ifne-for-eql representation '(:char)))
    17071737          (t
    1708            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1709                                                       arg2 'stack nil)
     1738           (with-operand-accumulation
     1739                ((compile-operand arg1 nil)
     1740                 (compile-operand arg2 nil)
     1741                 (maybe-emit-clear-values arg1 arg2)))
    17101742           (ecase representation
    17111743             (:boolean
    … …  
    22132245                (let ((LABEL1 (gensym))
    22142246                      (LABEL2 (gensym)))
    2215                   (compile-forms-and-maybe-emit-clear-values
    2216                           arg1 'stack common-rep
    2217                           arg2 'stack common-rep)
    2218                   (emit-numeric-comparison op common-rep LABEL1)
    2219                   (emit-push-true representation)
    2220                   (emit 'goto LABEL2)
    2221                   (label LABEL1)
    2222                   (emit-push-false representation)
    2223                   (label LABEL2))
     2247                  (with-operand-accumulation
     2248                       ((compile-operand arg1 common-rep)
     2249                        (compile-operand arg2 common-rep)
     2250                        (maybe-emit-clear-values arg1 arg2))
     2251                    (emit-numeric-comparison op common-rep LABEL1)
     2252                    (emit-push-true representation)
     2253                    (emit 'goto LABEL2)
     2254                    (label LABEL1)
     2255                    (emit-push-false representation)
     2256                    (label LABEL2)))
    22242257                (emit-move-from-stack target representation)
    22252258                (return-from p2-numeric-comparison))
    … …  
    22652298                (arg3-register
    22662299                 (unless (node-constant-p arg3) (allocate-register))))
    2267            (compile-form arg1 'stack :int)
    2268            (compile-form arg2 'stack :int)
    2269            (when arg2-register
    2270              (emit 'dup)
    2271              (emit 'istore arg2-register))
    2272            (cond (arg3-register
    2273                   (compile-form arg3 'stack :int)
    2274                   (emit 'istore arg3-register)
    2275                   (maybe-emit-clear-values arg1 arg2 arg3))
    2276                  (t
    2277                   (maybe-emit-clear-values arg1 arg2)))
     2300           (with-operand-accumulation
     2301               ((compile-operand arg1 :int)
     2302                (compile-operand arg2 :int)
     2303                (when arg3-register
     2304                  (compile-operand arg3 :int))
     2305                (maybe-emit-clear-values arg1 arg2 arg3))
     2306             (when arg3-register
     2307               (emit 'istore arg3-register))
     2308             (when arg2-register
     2309               (emit 'dup)
     2310               (emit 'istore arg2-register)))
    22782311           ;; First test.
    22792312           (emit test LABEL1)
    … …  
    25252558    (let* ((arg1 (%cadr form))
    25262559           (arg2 (%caddr form)))
    2527       (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2528                                                  arg2 'stack :char)
     2560      (with-operand-accumulation
     2561           ((compile-operand arg1 :char)
     2562            (compile-operand arg2 :char)
     2563            (maybe-emit-clear-values arg1 arg2)))
    25292564      'if_icmpne)))
    25302565
    … …  
    25332568    (let ((arg1 (%cadr form))
    25342569          (arg2 (%caddr form)))
    2535       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2536                                                  arg2 'stack nil)
     2570      (with-operand-accumulation
     2571           ((compile-operand arg1 nil)
     2572            (compile-operand arg2 nil)
     2573            (maybe-emit-clear-values arg1 arg2)))
    25372574     'if_acmpne)))
    25382575
    … …  
    25632600           (type2 (derive-compiler-type arg2)))
    25642601      (cond ((and (fixnum-type-p type1) (fixnum-type-p type2))
    2565              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2566                                                         arg2 'stack :int)
     2602             (with-operand-accumulation
     2603                  ((compile-operand arg1 :int)
     2604                   (compile-operand arg2 :int)
     2605                   (maybe-emit-clear-values arg1 arg2)))
    25672606             'if_icmpne)
    25682607            ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER))
    2569              (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2570                                                         arg2 'stack :char)
     2608             (with-operand-accumulation
     2609                  ((compile-operand arg1 :char)
     2610                   (compile-operand arg2 :char)
     2611                   (maybe-emit-clear-values arg1 arg2)))
    25712612             'if_icmpne)
    25722613            ((eq type2 'CHARACTER)
    2573              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2574                                                         arg2 'stack :char)
     2614             (with-operand-accumulation
     2615                  ((compile-operand arg1 nil)
     2616                   (compile-operand arg2 :char)
     2617                   (maybe-emit-clear-values arg1 arg2)))
    25752618             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    25762619             'ifeq)
    25772620            ((eq type1 'CHARACTER)
    2578              (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2579                                                         arg2 'stack nil)
     2621             (with-operand-accumulation
     2622                  ((compile-operand arg1 :char)
     2623                   (compile-operand arg2 nil)
     2624                   (maybe-emit-clear-values arg1 arg2)))
    25802625             (emit 'swap)
    25812626             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    25822627             'ifeq)
    25832628            ((fixnum-type-p type2)
    2584              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2585                                                         arg2 'stack :int)
     2629             (with-operand-accumulation
     2630                  ((compile-operand arg1 nil)
     2631                   (compile-operand arg2 :int)
     2632                   (maybe-emit-clear-values arg1 arg2)))
    25862633             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    25872634             'ifeq)
    25882635            ((fixnum-type-p type1)
    2589              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2590                                                         arg2 'stack nil)
     2636             (with-operand-accumulation
     2637                  ((compile-operand arg1 :int)
     2638                   (compile-operand arg2 nil)
     2639                   (maybe-emit-clear-values arg1 arg2)))
    25912640             (emit 'swap)
    25922641             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    25932642             'ifeq)
    25942643            (t
    2595              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2596                                                         arg2 'stack nil)
     2644             (with-operand-accumulation
     2645                  ((compile-operand arg1 nil)
     2646                   (compile-operand arg2 nil)
     2647                   (maybe-emit-clear-values arg1 arg2)))
    25972648             (emit-invokevirtual +lisp-object+ "eql"
    25982649                                 (lisp-object-arg-types 1) :boolean)
    … …  
    26082659           (arg2 (%caddr form)))
    26092660      (cond ((fixnum-type-p (derive-compiler-type arg2))
    2610              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2611                                                         arg2 'stack :int)
     2661             (with-operand-accumulation
     2662                  ((compile-operand arg1 nil)
     2663                   (compile-operand arg2 :int)
     2664                   (maybe-emit-clear-values arg1 arg2)))
    26122665             (emit-invokevirtual +lisp-object+
    26132666                                 translated-op
    26142667                                 '(:int) :boolean))
    26152668            (t
    2616              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2617                                                         arg2 'stack nil)
     2669             (with-operand-accumulation
     2670                  ((compile-operand arg1 nil)
     2671                   (compile-operand arg2 nil)
     2672                   (maybe-emit-clear-values arg1 arg2)))
    26182673             (emit-invokevirtual +lisp-object+
    26192674                                 translated-op
    … …  
    26252680    (let ((arg1 (%cadr form))
    26262681          (arg2 (%caddr form)))
    2627       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2628                                                  arg2 'stack nil)
     2682      (with-operand-accumulation
     2683                  ((compile-operand arg1 nil)
     2684                   (compile-operand arg2 nil)
     2685                   (maybe-emit-clear-values arg1 arg2)))
    26292686      (emit-invokevirtual +lisp-object+ "typep"
    26302687                          (lisp-object-arg-types 1) +lisp-object+)
    … …  
    26362693    (let ((arg1 (%cadr form))
    26372694          (arg2 (%caddr form)))
    2638       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2639                                                  arg2 'stack nil)
     2695      (with-operand-accumulation
     2696                  ((compile-operand arg1 nil)
     2697                   (compile-operand arg2 nil)
     2698                   (maybe-emit-clear-values arg1 arg2)))
    26402699      (emit-invokestatic +lisp+ "memq"
    26412700                         (lisp-object-arg-types 2) :boolean)
    … …  
    26462705    (let ((arg1 (%cadr form))
    26472706          (arg2 (%caddr form)))
    2648       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2649                                                  arg2 'stack nil)
     2707      (with-operand-accumulation
     2708                  ((compile-operand arg1 nil)
     2709                   (compile-operand arg2 nil)
     2710                   (maybe-emit-clear-values arg1 arg2)))
    26502711      (emit-invokestatic +lisp+ "memql"
    26512712                         (lisp-object-arg-types 2) :boolean)
    … …  
    26622723            ((and (fixnum-type-p type1)
    26632724                  (fixnum-type-p type2))
    2664              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2665                                                         arg2 'stack :int)
     2725             (with-operand-accumulation
     2726                 ((compile-operand arg1 :int)
     2727                  (compile-operand arg2 :int)
     2728                  (maybe-emit-clear-values arg1 arg2)))
    26662729             'if_icmpeq)
    26672730            ((fixnum-type-p type2)
    2668              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2669                                                         arg2 'stack :int)
     2731             (with-operand-accumulation
     2732                 ((compile-operand arg1 nil)
     2733                  (compile-operand arg2 :int)
     2734                  (maybe-emit-clear-values arg1 arg2)))
    26702735             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    26712736             'ifeq)
    … …  
    26732738             ;; FIXME Compile the args in reverse order and avoid the swap if
    26742739             ;; either arg is a fixnum or a lexical variable.
    2675              (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2676                                                         arg2 'stack nil)
     2740             (with-operand-accumulation
     2741                 ((compile-operand arg1 :int)
     2742                  (compile-operand arg2 nil)
     2743                  (maybe-emit-clear-values arg1 arg2)))
    26772744             (emit 'swap)
    26782745             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    26792746             'ifeq)
    26802747            (t
    2681              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2682                                                         arg2 'stack nil)
     2748             (with-operand-accumulation
     2749                 ((compile-operand arg1 nil)
     2750                  (compile-operand arg2 nil)
     2751                  (maybe-emit-clear-values arg1 arg2)))
    26832752             (emit-invokevirtual +lisp-object+ "isNotEqualTo"
    26842753                                 (lisp-object-arg-types 1) :boolean)
    … …  
    26972766               (if (funcall op arg1 arg2) :consequent :alternate))
    26982767              ((and (fixnum-type-p type1) (fixnum-type-p type2))
    2699                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2700                                                           arg2 'stack :int)
     2768               (with-operand-accumulation
     2769                 ((compile-operand arg1 :int)
     2770                  (compile-operand arg2 :int)
     2771                  (maybe-emit-clear-values arg1 arg2)))
    27012772               (ecase op
    27022773                 (<  'if_icmpge)
    … …  
    27062777                 (=  'if_icmpne)))
    27072778              ((and (java-long-type-p type1) (java-long-type-p type2))
    2708                (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    2709                                                           arg2 'stack :long)
     2779               (with-operand-accumulation
     2780                 ((compile-operand arg1 :long)
     2781                  (compile-operand arg2 :long)
     2782                  (maybe-emit-clear-values arg1 arg2)))
    27102783               (emit 'lcmp)
    27112784               (ecase op
    … …  
    27162789                 (=  'ifne)))
    27172790              ((fixnum-type-p type2)
    2718                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2719                                                           arg2 'stack :int)
     2791               (with-operand-accumulation
     2792                 ((compile-operand arg1 nil)
     2793                  (compile-operand arg2 :int)
     2794                  (maybe-emit-clear-values arg1 arg2)))
    27202795               (emit-invokevirtual +lisp-object+
    27212796                                   (ecase op
    … …  
    27302805               ;; FIXME We can compile the args in reverse order and avoid
    27312806               ;; the swap if either arg is a fixnum or a lexical variable.
    2732                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2733                                                           arg2 'stack nil)
     2807               (with-operand-accumulation
     2808                 ((compile-operand arg1 :int)
     2809                  (compile-operand arg2 nil)
     2810                  (maybe-emit-clear-values arg1 arg2)))
    27342811               (emit 'swap)
    27352812               (emit-invokevirtual +lisp-object+
    … …  
    27432820               'ifeq)
    27442821              (t
    2745                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2746                                                           arg2 'stack nil)
     2822               (with-operand-accumulation
     2823                 ((compile-operand arg1 nil)
     2824                  (compile-operand arg2 nil)
     2825                  (maybe-emit-clear-values arg1 arg2)))
    27472826               (emit-invokevirtual +lisp-object+
    27482827                                   (ecase op
    … …  
    27752854                  (let ((arg1 (second arg))
    27762855                        (arg2 (third arg)))
    2777                     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2778                                                                arg2 'stack nil)
     2856                    (with-operand-accumulation
     2857                         ((compile-operand arg1 nil)
     2858                          (compile-operand arg2 nil)
     2859                          (maybe-emit-clear-values arg1 arg2)))
    27792860                    (emit 'if_acmpeq LABEL1)))
    27802861                 ((eq (derive-compiler-type arg) 'BOOLEAN)
    … …  
    54225503  (let ((index-form (second form))
    54235504        (list-form (third form)))
    5424     (compile-forms-and-maybe-emit-clear-values index-form 'stack :int
    5425                                                list-form 'stack nil)
    5426     (emit 'swap)
    5427     (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+)
     5505    (with-operand-accumulation
     5506        ((compile-operand index-form :int)
     5507         (compile-operand list-form nil)
     5508         (maybe-emit-clear-values index-form list-form))
     5509      (emit 'swap)
     5510      (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+))
    54285511    (fix-boxing representation nil) ; FIXME use derived result type
    54295512    (emit-move-from-stack target representation)))
    … …  
    54495532              (compile-constant value target representation))
    54505533             (result-rep
    5451               (compile-forms-and-maybe-emit-clear-values
    5452                           arg1 'stack result-rep
    5453                           arg2 'stack result-rep)
    5454               (emit (case result-rep
    5455                       (:int    'imul)
    5456                       (:long   'lmul)
    5457                       (:float  'fmul)
    5458                       (:double 'dmul)
    5459                       (t
    5460                        (sys::format t "p2-times: unsupported rep case"))))
     5534              (with-operand-accumulation
     5535                   ((compile-operand arg1 result-rep)
     5536                    (compile-operand arg2 result-rep)
     5537                    (maybe-emit-clear-values arg1 arg2))
     5538                 (emit (case result-rep
     5539                          (:int    'imul)
     5540                          (:long   'lmul)
     5541                          (:float  'fmul)
     5542                          (:double 'dmul)
     5543                          (t
     5544                           (sys::format t "p2-times: unsupported rep case")))))
    54615545              (convert-representation result-rep representation)
    54625546              (emit-move-from-stack target representation))
    … …  
    55555639              (emit-move-from-stack target representation))
    55565640             (result-rep
    5557               (compile-forms-and-maybe-emit-clear-values
    5558                         arg1 'stack result-rep
    5559                         arg2 'stack result-rep)
    5560               (emit (case result-rep
    5561                       (:int    'iadd)
    5562                       (:long   'ladd)
    5563                       (:float  'fadd)
    5564                       (:double 'dadd)
    5565                       (t
    5566                        (sys::format
    5567                         t "p2-plus: Unexpected result-rep ~S for form ~S."
    5568                         result-rep form)
    5569                        (assert nil))))
     5641              (with-operand-accumulation
     5642                   ((compile-operand arg1 result-rep)
     5643                    (compile-operand arg2 result-rep)
     5644                    (maybe-emit-clear-values arg1 arg2))
     5645                (emit (case result-rep
     5646                        (:int    'iadd)
     5647                        (:long   'ladd)
     5648                        (:float  'fadd)
     5649                        (:double 'dadd)
     5650                        (t
     5651                         (sys::format
     5652                          t "p2-plus: Unexpected result-rep ~S for form ~S."
     5653                          result-rep form)
     5654                         (assert nil)))))
    55705655              (convert-representation result-rep representation)
    55715656              (emit-move-from-stack target representation))
    … …  
    55775662              (emit-invoke-method "incr" target representation))
    55785663             ((or (fixnum-type-p type1) (fixnum-type-p type2))
    5579               (compile-forms-and-maybe-emit-clear-values
    5580                     arg1 'stack (when (fixnum-type-p type1) :int)
    5581                     arg2 'stack (when (null (fixnum-type-p type1)) :int))
    5582               (when (fixnum-type-p type1)
    5583                 (emit 'swap))
    5584               (emit-invokevirtual +lisp-object+ "add"
    5585                                   '(:int) +lisp-object+)
     5664              (with-operand-accumulation
     5665                   ((compile-operand arg1 (when (fixnum-type-p type1) :int))
     5666                    (compile-operand arg2 (when (null (fixnum-type-p type1))
     5667                                            :int))
     5668                    (maybe-emit-clear-values arg1 arg2))
     5669                 (when (fixnum-type-p type1)
     5670                   (emit 'swap))
     5671                 (emit-invokevirtual +lisp-object+ "add"
     5672                                     '(:int) +lisp-object+))
    55865673              (fix-boxing representation result-type)
    55875674              (emit-move-from-stack target representation))
    … …  
    56355722              (compile-constant (- arg1 arg2) target representation))
    56365723             (result-rep
    5637               (compile-forms-and-maybe-emit-clear-values
    5638                         arg1 'stack result-rep
    5639                         arg2 'stack result-rep)
    5640               (emit (case result-rep
    5641                       (:int    'isub)
    5642                       (:long   'lsub)
    5643                       (:float  'fsub)
    5644                       (:double 'dsub)
    5645                       (t
    5646                        (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%"
    5647                                      result-rep form)
    5648                        (assert nil))))
     5724              (with-operand-accumulation
     5725                  ((compile-operand arg1 result-rep)
     5726                   (compile-operand arg2 result-rep)
     5727                   (maybe-emit-clear-values arg1 arg2))
     5728                (emit (case result-rep
     5729                        (:int    'isub)
     5730                        (:long   'lsub)
     5731                        (:float  'fsub)
     5732                        (:double 'dsub)
     5733                        (t
     5734                         (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%"
     5735                                       result-rep form)
     5736                         (assert nil)))))
    56495737              (convert-representation result-rep representation)
    56505738              (emit-move-from-stack target representation))
    56515739             ((fixnum-type-p type2)
    5652               (compile-forms-and-maybe-emit-clear-values
    5653                     arg1 'stack nil
    5654                     arg2 'stack :int)
    5655               (emit-invokevirtual +lisp-object+
    5656                                   "subtract"
    5657                                   '(:int) +lisp-object+)
     5740              (with-operand-accumulation
     5741                  ((compile-operand arg1 nil)
     5742                   (compile-operand arg2 :int)
     5743                   (maybe-emit-clear-values arg1 arg2))
     5744                (emit-invokevirtual +lisp-object+
     5745                                    "subtract"
     5746                                    '(:int) +lisp-object+))
    56585747              (fix-boxing representation result-type)
    56595748              (emit-move-from-stack target representation))
    … …  
    58205909            (arg2 (%caddr form))
    58215910            (type1 (derive-compiler-type arg1)))
    5822        (ecase representation
    5823          (:int
    5824           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5825                                                      arg2 'stack :int)
    5826           (emit-invokevirtual +lisp-object+ "aref" '(:int) :int))
    5827          (:long
    5828           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5829                                                      arg2 'stack :int)
    5830           (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long))
    5831          (:char
    5832           (cond ((compiler-subtypep type1 'string)
    5833                  (compile-form arg1 'stack nil) ; array
    5834                  (emit-checkcast +lisp-abstract-string+)
    5835                  (compile-form arg2 'stack :int) ; index
    5836                  (maybe-emit-clear-values arg1 arg2)
    5837                  (emit-invokevirtual +lisp-abstract-string+
    5838                                      "charAt" '(:int) :char))
    5839                 (t
    5840                  (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5841                                                             arg2 'stack :int)
    5842                  (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    5843                  (emit-unbox-character))))
    5844          ((nil :float :double :boolean)
    5845           ;;###FIXME for float and double, we probably want
    5846           ;; separate java methods to retrieve the values.
    5847           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5848                                                      arg2 'stack :int)
    5849           (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    5850           (convert-representation nil representation)))
     5911       (with-operand-accumulation
     5912            ((compile-operand arg1 nil
     5913                              (when (compiler-subtypep type1 'string)
     5914                                +lisp-abstract-string+))
     5915             (compile-operand arg2 :int)
     5916             (maybe-emit-clear-values arg1 arg2))
     5917          (ecase representation
     5918            (:int
     5919             (emit-invokevirtual +lisp-object+ "aref" '(:int) :int))
     5920            (:long
     5921             (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long))
     5922            (:char
     5923             (cond ((compiler-subtypep type1 'string)
     5924                    (emit-invokevirtual +lisp-abstract-string+
     5925                                        "charAt" '(:int) :char))
     5926                   (t
     5927                    (emit-invokevirtual +lisp-object+
     5928                                        "AREF" '(:int) +lisp-object+)
     5929                    (emit-unbox-character))))
     5930            ((nil :float :double :boolean)
     5931             ;;###FIXME for float and double, we probably want
     5932             ;; separate java methods to retrieve the values.
     5933             (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
     5934             (convert-representation nil representation))))
    58515935       (emit-move-from-stack target representation)))
    58525936    (t
Note: See TracChangeset for help on using the changeset viewer.