(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)
;; 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
(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.
(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)))
;;; 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)
'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
(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))
projects / sbcl.git / blobdiff