X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=9d5fb90465f96238b20436bd4332da59eccbcd5c;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=30c0c617fbcd2220e23b145abb25ae77768402ce;hpb=f610d5d0f80db2f4e55c8385fc3ca45d92ed04ec;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 30c0c61..9d5fb90 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -145,7 +145,7 @@ (define-source-transform last (x) `(sb!impl::last1 ,x)) (define-source-transform gethash (&rest args) (case (length args) - (2 `(sb!impl::gethash2 ,@args)) + (2 `(sb!impl::gethash3 ,@args nil)) (3 `(sb!impl::gethash3 ,@args)) (t (values nil t)))) (define-source-transform get (&rest args) @@ -702,8 +702,9 @@ ;; Multiply by closed zero is special. The result ;; is always a closed bound. But don't replace this ;; with zero; we want the multiplication to produce - ;; the correct signed zero, if needed. - (* (type-bound-number x) (type-bound-number y))) + ;; the correct signed zero, if needed. Use SIGNUM + ;; to avoid trying to multiply huge bignums with 0.0. + (* (signum (type-bound-number x)) (signum (type-bound-number y)))) ((or (and (floatp x) (float-infinity-p x)) (and (floatp y) (float-infinity-p y))) ;; Infinity times anything is infinity @@ -924,11 +925,13 @@ (if (member-type-p arg) ;; Run down the list of members and convert to a list of ;; member types. - (dolist (member (member-type-members arg)) - (push (if (numberp member) - (make-member-type :members (list member)) - *empty-type*) - new-args)) + (mapc-member-type-members + (lambda (member) + (push (if (numberp member) + (make-member-type :members (list member)) + *empty-type*) + new-args)) + arg) (push arg new-args))) (unless (member *empty-type* new-args) new-args))))) @@ -1087,25 +1090,23 @@ ;;; XXX This would be far simpler if the type-union methods could handle ;;; member/number unions. (defun make-canonical-union-type (type-list) - (let ((members '()) + (let ((xset (alloc-xset)) + (fp-zeroes '()) (misc-types '())) (dolist (type type-list) - (if (member-type-p type) - (setf members (union members (member-type-members type))) - (push type misc-types))) - #!+long-float - (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) - (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (if members - (apply #'type-union (make-member-type :members members) misc-types) - (apply #'type-union misc-types)))) + (cond ((member-type-p type) + (mapc-member-type-members + (lambda (member) + (if (fp-zero-p member) + (unless (member member fp-zeroes) + (pushnew member fp-zeroes)) + (add-to-xset member xset))) + type)) + (t + (push type misc-types)))) + (if (and (xset-empty-p xset) (not fp-zeroes)) + (apply #'type-union misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -3410,20 +3411,24 @@ (give-up-ir1-transform "The operands might not be the same type."))))) -(labels ((maybe-float-lvar-p (lvar) - (neq *empty-type* (type-intersection (specifier-type 'float) - (lvar-type lvar)))) - (maybe-invert (op inverted x y) - ;; Don't invert if either argument can be a float (NaNs) - (if (or (maybe-float-lvar-p x) (maybe-float-lvar-p y)) - `(or (,op x y) (= x y)) - `(if (,inverted x y) nil t)))) - (deftransform >= ((x y) (number number) *) +(defun maybe-float-lvar-p (lvar) + (neq *empty-type* (type-intersection (specifier-type 'float) + (lvar-type lvar)))) + +(flet ((maybe-invert (node op inverted x y) + ;; Don't invert if either argument can be a float (NaNs) + (cond + ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y)) + (delay-ir1-transform node :constraint) + `(or (,op x y) (= x y))) + (t + `(if (,inverted x y) nil t))))) + (deftransform >= ((x y) (number number) * :node node) "invert or open code" - (maybe-invert '> '< x y)) - (deftransform <= ((x y) (number number) *) + (maybe-invert node '> '< x y)) + (deftransform <= ((x y) (number number) * :node node) "invert or open code" - (maybe-invert '< '> x y))) + (maybe-invert node '< '> x y))) ;;; See whether we can statically determine (< X Y) using type ;;; information. If X's high bound is < Y's low, then X < Y. @@ -3432,7 +3437,13 @@ (macrolet ((def (name inverse reflexive-p surely-true surely-false) `(deftransform ,name ((x y)) "optimize using intervals" - (if (same-leaf-ref-p x y) + (if (and (same-leaf-ref-p x y) + ;; For non-reflexive functions we don't need + ;; to worry about NaNs: (non-ref-op NaN NaN) => false, + ;; but with reflexive ones we don't know... + ,@(when reflexive-p + '((and (not (maybe-float-lvar-p x)) + (not (maybe-float-lvar-p y)))))) ,reflexive-p (let ((ix (or (type-approximate-interval (lvar-type x)) (give-up-ir1-transform))) @@ -3487,15 +3498,16 @@ ;;; negated test as appropriate. If it is a degenerate one-arg call, ;;; then we transform to code that returns true. Otherwise, we bind ;;; all the arguments and expand into a bunch of IFs. -(declaim (ftype (function (symbol list boolean t) *) multi-compare)) -(defun multi-compare (predicate args not-p type) +(defun multi-compare (predicate args not-p type &optional force-two-arg-p) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) ((= nargs 1) `(progn (the ,type ,@args) t)) ((= nargs 2) (if not-p `(if (,predicate ,(first args) ,(second args)) nil t) - (values nil t))) + (if force-two-arg-p + `(,predicate ,(first args) ,(second args)) + (values nil t)))) (t (do* ((i (1- nargs) (1- i)) (last nil current) @@ -3533,15 +3545,15 @@ 'character)) (define-source-transform char-equal (&rest args) - (multi-compare 'char-equal args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t)) (define-source-transform char-lessp (&rest args) - (multi-compare 'char-lessp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t)) (define-source-transform char-greaterp (&rest args) - (multi-compare 'char-greaterp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t)) (define-source-transform char-not-greaterp (&rest args) - (multi-compare 'char-greaterp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t)) (define-source-transform char-not-lessp (&rest args) - (multi-compare 'char-lessp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t)) ;;; This function does source transformation of N-arg inequality ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3 @@ -3876,17 +3888,16 @@ ;; we're prepared to handle which is basically something ;; that array-element-type can return. (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) + (eql 1 (member-type-size cons-type)) (null (first (member-type-members cons-type)))) (let ((car-type (cons-type-car-type cons-type))) (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members - car-type))) - (numberp (first (first (member-type-members - car-type)))))) + (eql 1 (member-type-members car-type)) + (let ((elt (first (member-type-members car-type)))) + (or (symbolp elt) + (numberp elt) + (and (listp elt) + (numberp (first elt))))) (good-cons-type-p (cons-type-cdr-type cons-type)))))) (unconsify-type (good-cons-type) ;; Convert the "printed" respresentation of a cons @@ -3937,10 +3948,15 @@ ;; (DOUBLE-FLOAT 10d0 20d0) instead of just ;; double-float. (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) + (block punt + (let (members) + (mapc-member-type-members + (lambda (member) + (if (coerceable-p member) + (push member members) + (return-from punt *universal-type*))) + type) + (specifier-type `(or ,@members))))) ((and (cons-type-p type) (good-cons-type-p type)) (let ((c-type (unconsify-type (type-specifier type)))) @@ -4115,7 +4131,5 @@ (unless (and (constant-lvar-p quality-name) (policy-quality-name-p (lvar-value quality-name))) (give-up-ir1-transform)) - `(let* ((acons (assoc quality-name policy)) - (result (or (cdr acons) 1))) - result)) + '(%policy-quality policy quality-name))