Changeset 8408


Ignore:
Timestamp:
01/28/05 03:38:58 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

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

    r8406 r8408  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.374 2005-01-27 13:10:50 piso Exp $
     4;;; $Id: jvm.lisp,v 1.375 2005-01-28 03:38:58 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    150150  closure-register
    151151  class-file ; class-file object
     152  (single-valued-p t)
    152153  )
    153154
     
    240241(defun arg-is-fixnum-p (arg)
    241242  (or (fixnump arg)
    242       (unboxed-fixnum-variable arg)))
     243      (unboxed-fixnum-variable arg)
     244;;       (and (consp arg)
     245;;            (eq (car arg) 'THE)
     246;;            (subtypep (cadr arg) 'FIXNUM))
     247      ))
    243248
    244249;; True for local functions defined with FLET or LABELS.
     
    752757                             (return-from p1 (p1 (expand-inline form expansion)))))
    753758                         (let ((local-function (find-local-function op)))
    754                            (when local-function
    755                              (dformat t "p1 local function ~S~%" op)
    756                              (unless (eq (local-function-compiland local-function)
    757                                          *current-compiland*)
    758                                (let ((variable (local-function-variable local-function)))
    759                                  (when variable
    760                                    (unless (eq (variable-compiland variable) *current-compiland*)
    761                                      (dformat t "p1 ~S used non-locally~%" (variable-name variable))
    762                                      (setf (variable-used-non-locally-p variable) t)))))))
    763                          (list* op (mapcar #'p1 (cdr form)))
    764                          )))
     759                           (cond (local-function
     760                                  (dformat t "p1 local function ~S~%" op)
     761
     762                                  ;; FIXME
     763                                  (dformat t "local function assumed not single-valued~%")
     764                                  (setf (compiland-single-valued-p *current-compiland*) nil)
     765
     766                                  (unless (eq (local-function-compiland local-function)
     767                                              *current-compiland*)
     768                                    (let ((variable (local-function-variable local-function)))
     769                                      (when variable
     770                                        (unless (eq (variable-compiland variable) *current-compiland*)
     771                                          (dformat t "p1 ~S used non-locally~%" (variable-name variable))
     772                                          (setf (variable-used-non-locally-p variable) t))))))
     773                                 (t
     774                                  ;; Not a local function call.
     775                                  (unless (single-valued-p op)
     776                                    (%format t "not single-valued op = ~S~%" op)
     777                                    (setf (compiland-single-valued-p *current-compiland*) nil)))))
     778                         (list* op (mapcar #'p1 (cdr form))))))
    765779                 ((and (consp op) (eq (car op) 'LAMBDA))
    766780                  (p1 (list* 'FUNCALL form)))
     
    11641178        ((eq (first form) 'RETURN-FROM)
    11651179         (single-valued-p (third form)))
     1180        ((eq (first form) 'THE)
     1181         (dformat t "single-valued-p THE ~S~%" form)
     1182         (single-valued-p (third form)))
     1183        ((eq (first form) (compiland-name *current-compiland*))
     1184         (dformat t "single-valued-p recursive call ~S~%" (first form))
     1185         (compiland-single-valued-p *current-compiland*))
    11661186        (t
    11671187         (sys:single-valued-p (car form)))))
     
    12581278             96 ; IADD
    12591279             97 ; LADD
     1280             100 ; ISUB
    12601281             101 ; LSUB
    12611282             116 ; INEG
     
    22612282  (setf (gethash operator unary-operators) translation))
    22622283
    2263 (define-unary-operator '1+              "incr")
    2264 (define-unary-operator '1-              "decr")
     2284;; (define-unary-operator '1+              "incr")
     2285;; (define-unary-operator '1-              "decr")
    22652286(define-unary-operator 'ABS             "ABS")
    22662287(define-unary-operator 'ATOM            "ATOM")
     
    22992320(define-unary-operator 'ZEROP           "ZEROP")
    23002321
    2301 (defun compile-function-call-1 (fun args target representation)
     2322(defun compile-function-call-1 (op args target representation)
    23022323  (let ((arg (first args)))
    2303     (when (eq fun '1+)
    2304       (return-from compile-function-call-1 (compile-plus (list '+ 1 arg)
    2305                                                          :target target
    2306                                                          :representation representation)))
    2307     (let ((s (gethash fun unary-operators)))
     2324    (when (eq op '1+)
     2325      (return-from compile-function-call-1 (p2-plus (list '+ arg 1)
     2326                                                    :target target
     2327                                                    :representation representation)))
     2328    (when (eq op '1-)
     2329      (return-from compile-function-call-1 (p2-minus (list '- arg 1)
     2330                                                     :target target
     2331                                                     :representation representation)))
     2332    (let ((s (gethash op unary-operators)))
    23082333      (cond (s
    23092334             (compile-form arg :target :stack)
     
    23112336             (emit-invoke-method s target representation)
    23122337             t)
    2313             ((eq fun 'LIST)
     2338            ((eq op 'LIST)
    23142339             (emit 'new +lisp-cons-class+)
    23152340             (emit 'dup)
     
    25652590              (t
    25662591               (emit 'sipush numargs)
    2567                (emit 'anewarray "org/armedbear/lisp/LispObject")
     2592               (emit 'anewarray +lisp-object-class+)
    25682593               (let ((i 0))
    25692594                 (dolist (arg args)
     
    25942619
    25952620(defun compile-function-call (form target representation)
     2621  (dformat t "compile-function-call ~S representation = ~S~%" (car form) representation)
    25962622  (let ((op (car form))
    25972623        (args (cdr form)))
     
    35593585    (emit-move-from-stack target)))
    35603586
    3561 (defun contains-return (form)
    3562   (if (atom form)
    3563       (if (node-p form)
    3564           (contains-return (node-form form))
    3565           nil)
    3566       (case (car form)
    3567         (QUOTE
    3568          nil)
    3569         (RETURN-FROM
    3570          t)
    3571         (t
    3572          (dolist (subform form)
    3573            (when (contains-return subform)
    3574              (return t)))))))
     3587;; (defun contains-return (form)
     3588;;   (if (atom form)
     3589;;       (if (node-p form)
     3590;;           (contains-return (node-form form))
     3591;;           nil)
     3592;;       (case (car form)
     3593;;         (QUOTE
     3594;;          nil)
     3595;;         (RETURN-FROM
     3596;;          t)
     3597;;         (t
     3598;;          (dolist (subform form)
     3599;;            (when (contains-return subform)
     3600;;              (return t)))))))
    35753601
    35763602(defun compile-block (form &key (target *val*) representation)
     
    37163742               (unless must-clear-values
    37173743                 (unless (single-valued-p form)
    3718 ;;                    (dformat t "compile-progn-body not single-valued: ~S~%" form)
    37193744                   (setf must-clear-values t)))))))))
    37203745
     
    41334158    (emit-move-from-stack target representation)))
    41344159
    4135 (defun compile-plus (form &key (target *val*) representation)
     4160(defun p2-plus (form &key (target *val*) representation)
    41364161  (case (length form)
    41374162    (3
     
    41464171                                :representation representation))
    41474172             ((and var1 var2)
    4148               (dformat t "compile-plus case 1~%")
     4173              (dformat t "p2-plus case 1~%")
    41494174              (dformat t "target = ~S representation = ~S~%" target representation)
    41504175              (aver (variable-register var1))
     
    41644189                (emit-move-from-stack target representation)))
    41654190             ((and var1 (fixnump arg2))
    4166               (dformat t "compile-plus case 2~%")
     4191              (dformat t "p2-plus case 2~%")
    41674192              (aver (variable-register var1))
    41684193              (cond ((eq representation :unboxed-fixnum)
     
    41794204              (emit-move-from-stack target representation))
    41804205             ((and (fixnump arg1) var2)
    4181               (dformat t "compile-plus case 3~%")
     4206              (dformat t "p2-plus case 3~%")
    41824207              (aver (variable-register var2))
    41834208              (cond ((eq representation :unboxed-fixnum)
     
    41944219              (emit-move-from-stack target representation))
    41954220             ((eql arg1 1)
    4196               (dformat t "compile-plus case 4~%")
     4221              (dformat t "p2-plus case 4~%")
    41974222              (compile-form arg2 :target :stack)
    41984223              (maybe-emit-clear-values arg2)
    41994224              (emit-invoke-method "incr" target representation))
    42004225             ((eql arg2 1)
    4201               (dformat t "compile-plus case 5~%")
     4226              (dformat t "p2-plus case 5~%")
    42024227              (compile-form arg1 :target :stack)
    42034228              (maybe-emit-clear-values arg1)
    42044229              (emit-invoke-method "incr" target representation))
    42054230             ((arg-is-fixnum-p arg1)
    4206               (dformat t "compile-plus case 6~%")
     4231              (dformat t "p2-plus case 6~%")
    42074232              (emit-push-int arg1)
    42084233              (compile-form arg2 :target :stack)
     
    42144239              (emit-move-from-stack target representation))
    42154240             ((arg-is-fixnum-p arg2)
    4216               (dformat t "compile-plus case 7~%")
     4241              (dformat t "p2-plus case 7~%")
    42174242              (compile-form arg1 :target :stack)
    42184243              (maybe-emit-clear-values arg1)
     
    42224247                (emit-unbox-fixnum))
    42234248              (emit-move-from-stack target representation))
     4249             ((and (consp arg1)
     4250                   (eq (car arg1) 'THE)
     4251                   (subtypep (cadr arg1) 'FIXNUM)
     4252                   (consp arg2)
     4253                   (eq (car arg2) 'THE)
     4254                   (subtypep (cadr arg2) 'FIXNUM))
     4255              (dformat t "p2-plus case 7b representation = ~S~%" representation)
     4256              (let ((must-clear-values nil))
     4257                (compile-form arg1 :target :stack :representation :unboxed-fixnum)
     4258                (unless (single-valued-p arg1)
     4259                  (dformat t "not single-valued: ~S~%" arg1)
     4260                  (setf must-clear-values t))
     4261                (unless (eq representation :unboxed-fixnum)
     4262                  (emit 'i2l))
     4263                (compile-form arg2 :target :stack :representation :unboxed-fixnum)
     4264                (setf must-clear-values (or must-clear-values
     4265                                            (not (single-valued-p arg2))))
     4266                (cond ((eq representation :unboxed-fixnum)
     4267                       (emit 'iadd))
     4268                      (t
     4269                       (emit 'i2l)
     4270                       (emit 'ladd)
     4271                       (emit-box-long)))
     4272                (when must-clear-values
     4273                  (dformat t "p2-plus case 7b calling emit-clear-values~%")
     4274                  (emit-clear-values))
     4275                (emit-move-from-stack target representation)))
    42244276             (t
    4225               (dformat t "compile-plus case 8~%")
     4277              (dformat t "p2-plus case 8 ~S~%" form)
    42264278              (compile-binary-operation "add" args target representation)))))
    42274279    (4
    4228      (dformat t "compile-plus case 9~%")
     4280     (dformat t "p2-plus case 9~%")
    42294281     ;; (+ a b c) => (+ (+ a b) c)
    42304282     (let ((new-form `(+ (+ ,(second form) ,(third form)) ,(fourth form))))
    42314283       (dformat t "form = ~S~%" form)
    42324284       (dformat t "new-form = ~S~%" new-form)
    4233        (compile-plus new-form :target target :representation representation)))
     4285       (p2-plus new-form :target target :representation representation)))
    42344286    (t
    4235      (dformat t "compile-plus case 10~%")
     4287     (dformat t "p2-plus case 10~%")
    42364288     (compile-function-call form target representation))))
    42374289
    4238 (defun compile-minus (form &key (target *val*) representation)
     4290(defun p2-minus (form &key (target *val*) representation)
    42394291  (case (length form)
    42404292    (3
     
    42494301                                :representation representation))
    42504302             ((and var1 var2)
    4251               (dformat t "compile-minus case 1~%")
     4303              (dformat t "p2-minus case 1~%")
    42524304              (aver (variable-register var1))
    42534305              (aver (variable-register var2))
     
    42674319                (emit-move-from-stack target representation)))
    42684320             ((and var1 (fixnump arg2))
    4269               (dformat t "compile-minus case 2~%")
     4321              (dformat t "p2-minus case 2 ~S ~S~%" form representation)
    42704322              (aver (variable-register var1))
    4271               (cond
    4272                ((eq representation :unboxed-fixnum)
    4273                 (emit-push-int var1)
    4274                 (emit-push-int arg2)
    4275                 (emit 'isub))
    4276                (t
    4277                 (emit-push-int var1)
    4278                 (emit 'i2l)
    4279                 (emit-push-int arg2)
    4280                 (emit 'i2l)
    4281                 (emit 'lsub)
    4282                 (emit-box-long)))
     4323              (cond ((eq representation :unboxed-fixnum)
     4324                     (dformat t "p2-minus case 2 ISUB~%")
     4325                     (emit-push-int var1)
     4326                     (emit-push-int arg2)
     4327                     (emit 'isub))
     4328                    (t
     4329                     (dformat t "p2-minus case 2 LSUB~%")
     4330                     (emit-push-int var1)
     4331                     (emit 'i2l)
     4332                     (emit-push-int arg2)
     4333                     (emit 'i2l)
     4334                     (emit 'lsub)
     4335                     (emit-box-long)))
    42834336              (emit-move-from-stack target representation))
    42844337             ((and (fixnump arg1) var2)
    4285               (dformat t "compile-minus case 3~%")
     4338              (dformat t "p2-minus case 3~%")
    42864339              (aver (variable-register var2))
    42874340              (cond ((eq representation :unboxed-fixnum)
     
    42984351              (emit-move-from-stack target representation))
    42994352             ((eql arg2 1)
    4300               (dformat t "compile-minus case 5~%")
     4353              (dformat t "p2-minus case 5~%")
    43014354              (compile-form arg1 :target :stack)
    43024355              (maybe-emit-clear-values arg2)
    43034356              (emit-invoke-method "decr" target representation))
    43044357             ((arg-is-fixnum-p arg2)
    4305               (dformat t "compile-minus case 7~%")
     4358              (dformat t "p2-minus case 7~%")
    43064359              (compile-form arg1 :target :stack)
    43074360              (maybe-emit-clear-values arg1)
     
    43124365              (emit-move-from-stack target representation))
    43134366             (t
    4314               (dformat t "compile-minus case 8~%")
     4367              (dformat t "p2-minus case 8~%")
    43154368              (compile-binary-operation "subtract" args target representation)))))
    43164369    (4
    4317      (dformat t "compile-minus case 9~%")
     4370     (dformat t "p2-minus case 9~%")
    43184371     ;; (- a b c) => (- (- a b) c)
    43194372     (let ((new-form `(- (- ,(second form) ,(third form)) ,(fourth form))))
    43204373       (dformat t "form = ~S~%" form)
    43214374       (dformat t "new-form = ~S~%" new-form)
    4322        (compile-minus new-form :target target :representation representation)))
     4375       (p2-minus new-form :target target :representation representation)))
    43234376    (t
    4324      (dformat t "compile-minus case 10~%")
     4377     (dformat t "p2-minus case 10~%")
    43254378     (compile-function-call form target representation))))
    43264379
     
    45424595
    45434596(defun p2-the (form &key (target *val*) representation)
    4544   (compile-form (third form) :target target :representation representation))
     4597;;   (compile-form (third form) :target target :representation representation)
     4598  (cond ((subtypep (second form) 'FIXNUM)
     4599         (unless (eq representation :unboxed-fixnum)
     4600           (emit 'new +lisp-fixnum-class+)
     4601           (emit 'dup))
     4602         (compile-form (third form) :target :stack :representation :unboxed-fixnum)
     4603         (unless (eq representation :unboxed-fixnum)
     4604           (emit-invokespecial-init +lisp-fixnum-class+ '("I")))
     4605         (emit-move-from-stack target representation))
     4606        (t
     4607         (compile-form (third form) :target target :representation representation))))
    45454608
    45464609(defun compile-catch (form &key (target *val*) representation)
     
    54815544(install-p2-handler '=              'p2-numeric-comparison)
    54825545(install-p2-handler '/=             'p2-numeric-comparison)
    5483 (install-p2-handler '+              'compile-plus)
    5484 (install-p2-handler '-              'compile-minus)
     5546(install-p2-handler '+              'p2-plus)
     5547(install-p2-handler '-              'p2-minus)
    54855548(install-p2-handler 'ash            'p2-ash)
    54865549(install-p2-handler 'eql            'p2-eql)
Note: See TracChangeset for help on using the changeset viewer.