Changeset 13160


Ignore:
Timestamp:
01/20/11 12:20:29 (13 years ago)
Author:
ehuelsmann
Message:

Further transition to unsafety detection in pass2.

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

    r13159 r13160  
    11531153(defvar *pass2-unsafe-p-special-treatment-functions*
    11541154  '(
    1155      coerce-to-function
    1156      cons
    1157      sys::backq-cons
    1158      find-class
    1159      list
    1160      sys::backq-list
    1161      list*
    1162      sys::backq-list*
    1163      load-time-value
    11641155     logand
    11651156     logior
    11661157     lognot
    11671158     logxor
    1168      max
    1169      min
    1170      mod
    1171        stream-element-type
    1172        truncate
    11731159)
    11741160"The functions named in the list bound to this variable
  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13159 r13160  
    761761        (emit-move-from-stack register (variable-representation variable)))))))
    762762
     763(defun emit-register-operand (register representation)
     764  (push representation *operand-representations*)
     765  (cond (*saved-operands*
     766         (push register *saved-operands*))
     767        (t
     768         (emit-push-register register representation))))
     769
    763770(defun emit-thread-operand ()
    764   (push nil *operand-representations*)
    765   (emit-push-current-thread)
    766   (when *saved-operands*
    767     (let ((register (allocate-register nil)))
    768       (push register *saved-operands*)
    769       (emit 'astore register))))
     771  (ensure-thread-var-initialized)
     772  (emit-register-operand *thread* nil))
    770773
    771774(defun emit-load-externalized-object-operand (object)
     
    39563959(define-inlined-function p2-cons (form target representation)
    39573960  ((check-arg-count form 2))
    3958   (emit-new +lisp-cons+)
    3959   (emit 'dup)
    39603961  (let* ((args (%cdr form))
    39613962         (arg1 (%car args))
    3962          (arg2 (%cadr args)))
    3963     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    3964                                                arg2 'stack nil))
    3965   (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
    3966   (emit-move-from-stack target))
     3963         (arg2 (%cadr args))
     3964         (cons-register (when (some-nested-block #'node-opstack-unsafe-p
     3965                                                 (find-enclosed-blocks args))
     3966                          (allocate-register nil))))
     3967    (emit-new +lisp-cons+)
     3968    (if cons-register
     3969        (astore cons-register)
     3970      (emit 'dup))
     3971    (with-operand-accumulation
     3972        ((when cons-register
     3973           (emit-register-operand cons-register nil))
     3974         (compile-operand arg1 nil)
     3975         (compile-operand arg2 nil)
     3976         (maybe-emit-clear-values arg1 arg2)))
     3977    (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
     3978    (when cons-register
     3979      (emit-push-register cons-register nil))
     3980    (emit-move-from-stack target)))
    39673981
    39683982(defun compile-progn (form target representation)
     
    47124726                (fixnum-type-p type1)
    47134727                (fixnum-type-p type2))
    4714            (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4715                                                       arg2 'stack :int)
     4728           (with-operand-accumulation
     4729               ((compile-operand arg1 :int)
     4730                (compile-operand arg2 :int)
     4731                (maybe-emit-clear-values arg1 arg2)))
    47164732           (emit-invokestatic +lisp+ "mod" '(:int :int) :int)
    47174733           (emit-move-from-stack target representation))
    47184734          ((fixnum-type-p type2)
    4719            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4720                                                       arg2 'stack :int)
     4735           (with-operand-accumulation
     4736               ((compile-operand arg1 nil)
     4737                (compile-operand arg2 :int)
     4738                (maybe-emit-clear-values arg1 arg2)))
    47214739           (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+)
    47224740           (fix-boxing representation nil) ; FIXME use derived result type
    47234741           (emit-move-from-stack target representation))
    47244742          (t
    4725            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4726                                                       arg2 'stack nil)
     4743           (with-operand-accumulation
     4744               ((compile-operand arg1 nil)
     4745                (compile-operand arg2 nil)
     4746                (maybe-emit-clear-values arg1 arg2)))
    47274747           (emit-invokevirtual +lisp-object+ "MOD"
    47284748                               (lisp-object-arg-types 1) +lisp-object+)
     
    47994819      (2
    48004820       (let ((arg2 (second args)))
    4801          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4802                                                     arg2 'stack :boolean)
     4821         (with-operand-accumulation
     4822             ((compile-operand arg1 nil)
     4823              (compile-operand arg2 :boolean)
     4824              (maybe-emit-clear-values arg1 arg2)))
    48034825         (emit-invokestatic +lisp-class+ "findClass"
    48044826                            (list +lisp-object+ :boolean) +lisp-object+)
     
    55295551                         (butlast args 1)
    55305552                         args)))
    5531     (cond ((>= 4 length 1)
     5553    (cond ((and (not (some-nested-block #'node-opstack-unsafe-p
     5554                                        (find-enclosed-blocks args)))
     5555                (>= 4 length 1))
    55325556           (dolist (cons-head cons-heads)
    55335557             (emit-new +lisp-cons+)
     
    56295653              (args (%cdr form))
    56305654              (arg1 (%car args))
    5631               (arg2 (%cadr args)))
     5655              (arg2 (%cadr args))
     5656              (*register* *register*))
    56325657         (when (null target)
     5658           ;; compile for effect
    56335659           (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    56345660                                                      arg2 nil nil)
     
    56405666               (type2 (derive-compiler-type arg2)))
    56415667           (cond ((and (java-long-type-p type1) (java-long-type-p type2))
    5642                   (let ((common-rep (if (and (fixnum-type-p type1)
    5643                                              (fixnum-type-p type2))
    5644                                         :int :long))
    5645                         (LABEL1 (gensym)))
    5646                     (compile-form arg1 'stack common-rep)
     5668                  (let* ((common-rep (if (and (fixnum-type-p type1)
     5669                                              (fixnum-type-p type2))
     5670                                         :int :long))
     5671                        (LABEL1 (gensym))
     5672                        (LABEL2 (gensym))
     5673                        (arg1-register (allocate-register common-rep))
     5674                        (arg2-register (allocate-register common-rep)))
     5675                    (compile-form arg1 arg1-register common-rep)
     5676                    (compile-form arg2 'stack common-rep)
    56475677                    (emit-dup common-rep)
    5648                     (compile-form arg2 'stack common-rep)
    5649                     (emit-dup common-rep :past common-rep)
     5678                    (emit-move-from-stack arg2-register common-rep)
     5679                    (emit-push-register arg1-register common-rep)
     5680                    ;; note: we've now reversed the arguments on the stack!
    56505681                    (emit-numeric-comparison (if (eq op 'max) '<= '>=)
    56515682                                             common-rep LABEL1)
    5652                     (emit-swap common-rep common-rep)
     5683                    (emit-push-register arg1-register common-rep)
     5684                    (emit 'goto LABEL2)
    56535685                    (label LABEL1)
    5654                     (emit-move-from-stack nil common-rep)
     5686                    (emit-push-register arg2-register common-rep)
     5687                    (label LABEL2)
    56555688                    (convert-representation common-rep representation)
    56565689                    (emit-move-from-stack target representation)))
    56575690                 (t
    5658                   (compile-form arg1 'stack nil)
    5659                   (emit-dup nil)
    5660                   (compile-form arg2 'stack nil)
    5661                   (emit-dup nil :past nil)
    5662                   (emit-invokevirtual +lisp-object+
    5663                                       (if (eq op 'max)
    5664                                           "isLessThanOrEqualTo"
     5691                  (let* ((arg1-register (allocate-register nil))
     5692                         (arg2-register (allocate-register nil)))
     5693                    (compile-form arg1 arg1-register nil)
     5694                    (compile-form arg2 'stack nil)
     5695                    (emit-dup nil)
     5696                    (astore arg2-register)
     5697                    (emit-push-register arg1-register nil)
     5698                    (emit-invokevirtual +lisp-object+
     5699                                        (if (eq op 'max)
     5700                                            "isLessThanOrEqualTo"
    56655701                                          "isGreaterThanOrEqualTo")
    5666                                       (lisp-object-arg-types 1) :boolean)
    5667                   (let ((LABEL1 (gensym)))
    5668                     (emit 'ifeq LABEL1)
    5669                     (emit 'swap)
    5670                     (label LABEL1)
    5671                     (emit 'pop))
    5672                   (fix-boxing representation nil)
    5673                   (emit-move-from-stack target representation))))))
     5702                                        (lisp-object-arg-types 1) :boolean)
     5703                    (let ((LABEL1 (gensym))
     5704                          (LABEL2 (gensym)))
     5705                      (emit 'ifeq LABEL1)
     5706                      (emit-push-register arg1-register nil)
     5707                      (emit 'goto LABEL2)
     5708                      (label LABEL1)
     5709                      (emit-push-register arg2-register nil)
     5710                      (label LABEL2))
     5711                    (fix-boxing representation nil)
     5712                    (emit-move-from-stack target representation)))))))
    56745713    (t
    56755714     (p2-min/max `(,(car form) (,(car form) ,(second form) ,(third form))
     
    59495988       (compile-function-call form target representation)
    59505989       (return-from p2-truncate)))
    5951     (compile-form arg1 'stack nil)
    5952     (compile-form arg2 'stack nil)
    5953     (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+)
     5990    (with-operand-accumulation
     5991        ((compile-operand arg1 nil)
     5992         (compile-operand arg2 nil)))
     5993    (maybe-emit-clear-values arg1 arg2)
     5994    (emit-invokevirtual +lisp-object+ "truncate"
     5995                        (lisp-object-arg-types 1) +lisp-object+)
    59545996    (fix-boxing representation nil) ; FIXME use derived result type
    59555997    (emit-move-from-stack target representation)))
     
    62876329         (compile-forms-and-maybe-emit-clear-values arg target representation)))
    62886330      (2
    6289        (emit-push-current-thread)
    62906331       (let ((arg1 (%car args))
    62916332             (arg2 (%cadr args)))
    62926333         (cond ((and (eq arg1 t)
    62936334                     (eq arg2 t))
     6335                (emit-push-current-thread)
    62946336                (emit-push-t)
    62956337                (emit 'dup))
    62966338               ((and (eq arg1 nil)
    62976339                     (eq arg2 nil))
     6340                (emit-push-current-thread)
    62986341                (emit-push-nil)
    62996342                (emit 'dup))
    63006343               (t
    63016344                (with-operand-accumulation
    6302                    ((compile-operand arg1 nil)
     6345                   ((emit-thread-operand)
     6346                    (compile-operand arg1 nil)
    63036347                    (compile-operand arg2 nil)
    63046348                    (maybe-emit-clear-values arg1 arg2))))))
Note: See TracChangeset for help on using the changeset viewer.