Changeset 15518


Ignore:
Timestamp:
Nov 29, 2012, 7:30:31 PM (7 years ago)
Author:
gb
Message:

In X862-TYPECHECKED-FORM, don't typecheck constants that're of the
proper type.

See ticket:638.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/x862.lisp

    r15495 r15518  
    96239623(defun x862-typechecked-form (seg vreg xfer typespec form)
    96249624  (with-x86-local-vinsn-macros (seg vreg xfer)
    9625     (let* ((op
    9626             (cond ((eq typespec 'fixnum) (%nx1-operator require-fixnum))
    9627                   ((eq typespec 'integer) (%nx1-operator require-integer))
    9628                   ((memq typespec '(base-char character))
    9629                    (%nx1-operator require-character))
    9630                   ((eq typespec 'symbol) (%nx1-operator require-symbol))
    9631                   ((eq typespec 'list) (%nx1-operator require-list))
    9632                   ((eq typespec 'real) (%nx1-operator require-real))
    9633                   ((memq typespec '(simple-base-string simple-string))
    9634                    (%nx1-operator require-simple-string))
    9635                   ((eq typespec 'number) (%nx1-operator require-number))
    9636                   ((eq typespec 'simple-vector) (%nx1-operator require-simple-vector))
    9637                   (t
    9638                    (let* ((ctype (specifier-type typespec)))
    9639                      (cond ((type= ctype (load-time-value (specifier-type '(signed-byte 8))))
    9640                             (%nx1-operator require-s8))
    9641                            ((type= ctype (load-time-value (specifier-type '(unsigned-byte 8))))
    9642                             (%nx1-operator require-u8))
    9643                            ((type= ctype (load-time-value (specifier-type '(signed-byte 16))))
    9644                             (%nx1-operator require-s16))
    9645                            ((type= ctype (load-time-value (specifier-type '(unsigned-byte 16))))
    9646                             (%nx1-operator require-u16))
    9647                            ((type= ctype (load-time-value (specifier-type '(signed-byte 32))))                           
    9648                             (%nx1-operator require-s32))
    9649                            ((type= ctype (load-time-value (specifier-type '(unsigned-byte 32))))
    9650                             (%nx1-operator require-u32))
    9651                            ((type= ctype (load-time-value (specifier-type '(signed-byte 64))))
    9652                             (%nx1-operator require-s64))
    9653                            ((type= ctype (load-time-value (specifier-type '(unsigned-byte 64))))
    9654                             (%nx1-operator require-u64))))))))
    9655       (if op
    9656         (x862-use-operator op seg vreg xfer form)
    9657         (if (or (eq typespec t)
    9658                 (eq typespec '*))
    9659           (x862-form seg vreg xfer form)
    9660           (with-note (form seg)
    9661             (let* ((ok (backend-get-next-label)))
    9662               (if (and (symbolp typespec) (non-nil-symbolp (type-predicate typespec)))
    9663                 ;; Do this so can compile the lisp with typechecking even though typep
    9664                 ;; doesn't get defined til fairly late.
    9665                 (progn
    9666                   (x862-one-targeted-reg-form seg form ($ *x862-arg-z*))
    9667                   (x862-store-immediate seg (type-predicate typespec) ($ *x862-fname*))
    9668                   (x862-set-nargs seg 1)
    9669                   (x862-vpush-register seg ($ *x862-arg-z*)))
    9670                 (progn
    9671                   (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
    9672                   (x862-store-immediate seg typespec ($ *x862-arg-z*))
    9673                   (x862-store-immediate seg 'typep ($ *x862-fname*))
    9674                   (x862-set-nargs seg 2)
    9675                   (x862-vpush-register seg ($ *x862-arg-y*))))
    9676               (! call-known-symbol ($ *x862-arg-z*))
    9677               (! compare-to-nil ($ *x862-arg-z*))
    9678               (x862-vpop-register seg ($ *x862-arg-y*))
    9679               (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
    9680               (target-arch-case
    9681                (:x8632
    9682                 (let* ((*x862-vstack* *x862-vstack*)
    9683                        (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
    9684                   (! reserve-outgoing-frame)
    9685                   (incf *x862-vstack* (* 2 *x862-target-node-size*))
    9686                   (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*))
    9687                   (x862-store-immediate seg typespec ($ *x862-arg-z*))
    9688                   (x862-set-nargs seg 3)
    9689                   (! ksignalerr)))
    9690                (:x8664
    9691                 (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*))
    9692                 (x862-store-immediate seg typespec ($ *x862-arg-z*))
    9693                 (x862-set-nargs seg 3)
    9694                 (! ksignalerr)))
    9695               (@ ok)
    9696               (<- ($ *x862-arg-y*))
    9697               (^))))))))
     9625    (multiple-value-bind (val win)
     9626        (acode-constant-p form)
     9627      (if (and win (ignore-errors (typep val typespec)))
     9628        (x862-form seg vreg xfer form)
     9629        (let* ((op
     9630                (cond ((eq typespec 'fixnum) (%nx1-operator require-fixnum))
     9631                      ((eq typespec 'integer) (%nx1-operator require-integer))
     9632                      ((memq typespec '(base-char character))
     9633                       (%nx1-operator require-character))
     9634                      ((eq typespec 'symbol) (%nx1-operator require-symbol))
     9635                      ((eq typespec 'list) (%nx1-operator require-list))
     9636                      ((eq typespec 'real) (%nx1-operator require-real))
     9637                      ((memq typespec '(simple-base-string simple-string))
     9638                       (%nx1-operator require-simple-string))
     9639                      ((eq typespec 'number) (%nx1-operator require-number))
     9640                      ((eq typespec 'simple-vector) (%nx1-operator require-simple-vector))
     9641                      (t
     9642                       (let* ((ctype (specifier-type typespec)))
     9643                         (cond ((type= ctype (load-time-value (specifier-type '(signed-byte 8))))
     9644                                (%nx1-operator require-s8))
     9645                               ((type= ctype (load-time-value (specifier-type '(unsigned-byte 8))))
     9646                                (%nx1-operator require-u8))
     9647                               ((type= ctype (load-time-value (specifier-type '(signed-byte 16))))
     9648                                (%nx1-operator require-s16))
     9649                               ((type= ctype (load-time-value (specifier-type '(unsigned-byte 16))))
     9650                                (%nx1-operator require-u16))
     9651                               ((type= ctype (load-time-value (specifier-type '(signed-byte 32))))                           
     9652                                (%nx1-operator require-s32))
     9653                               ((type= ctype (load-time-value (specifier-type '(unsigned-byte 32))))
     9654                                (%nx1-operator require-u32))
     9655                               ((type= ctype (load-time-value (specifier-type '(signed-byte 64))))
     9656                                (%nx1-operator require-s64))
     9657                               ((type= ctype (load-time-value (specifier-type '(unsigned-byte 64))))
     9658                                (%nx1-operator require-u64))))))))
     9659          (if op
     9660            (x862-use-operator op seg vreg xfer form)
     9661            (if (or (eq typespec t)
     9662                    (eq typespec '*))
     9663              (x862-form seg vreg xfer form)
     9664              (with-note (form seg)
     9665                (let* ((ok (backend-get-next-label)))
     9666                  (if (and (symbolp typespec) (non-nil-symbolp (type-predicate typespec)))
     9667                    ;; Do this so can compile the lisp with typechecking even though typep
     9668                    ;; doesn't get defined til fairly late.
     9669                    (progn
     9670                      (x862-one-targeted-reg-form seg form ($ *x862-arg-z*))
     9671                      (x862-store-immediate seg (type-predicate typespec) ($ *x862-fname*))
     9672                      (x862-set-nargs seg 1)
     9673                      (x862-vpush-register seg ($ *x862-arg-z*)))
     9674                    (progn
     9675                      (x862-one-targeted-reg-form seg form ($ *x862-arg-y*))
     9676                      (x862-store-immediate seg typespec ($ *x862-arg-z*))
     9677                      (x862-store-immediate seg 'typep ($ *x862-fname*))
     9678                      (x862-set-nargs seg 2)
     9679                      (x862-vpush-register seg ($ *x862-arg-y*))))
     9680                  (! call-known-symbol ($ *x862-arg-z*))
     9681                  (! compare-to-nil ($ *x862-arg-z*))
     9682                  (x862-vpop-register seg ($ *x862-arg-y*))
     9683                  (! cbranch-false (aref *backend-labels* ok) x86::x86-e-bits)
     9684                  (target-arch-case
     9685                   (:x8632
     9686                    (let* ((*x862-vstack* *x862-vstack*)
     9687                           (*x862-top-vstack-lcell* *x862-top-vstack-lcell*))
     9688                      (! reserve-outgoing-frame)
     9689                      (incf *x862-vstack* (* 2 *x862-target-node-size*))
     9690                      (! vpush-fixnum (ash $XWRONGTYPE *x862-target-fixnum-shift*))
     9691                      (x862-store-immediate seg typespec ($ *x862-arg-z*))
     9692                      (x862-set-nargs seg 3)
     9693                      (! ksignalerr)))
     9694                   (:x8664
     9695                    (x862-lri seg ($ x8664::arg_x) (ash $XWRONGTYPE *x862-target-fixnum-shift*))
     9696                    (x862-store-immediate seg typespec ($ *x862-arg-z*))
     9697                    (x862-set-nargs seg 3)
     9698                    (! ksignalerr)))
     9699                  (@ ok)
     9700                  (<- ($ *x862-arg-y*))
     9701                  (^))))))))))
    96989702         
    96999703         
Note: See TracChangeset for help on using the changeset viewer.