(in-package "SB!C")
-;;; Convert into an IF so that IF optimizations will eliminate redundant
-;;; negations.
-(define-source-transform not (x) `(if ,x nil t))
-(define-source-transform null (x) `(if ,x nil t))
-
-;;; ENDP is just NULL with a LIST assertion. The assertion will be
-;;; optimized away when SAFETY optimization is low; hopefully that
-;;; is consistent with ANSI's "should return an error".
-(define-source-transform endp (x) `(null (the list ,x)))
-
;;; We turn IDENTITY into PROG1 so that it is obvious that it just
;;; returns the first value of its argument. Ditto for VALUES with one
;;; arg.
(define-source-transform identity (x) `(prog1 ,x))
(define-source-transform values (x) `(prog1 ,x))
-
;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type.
(defoptimizer (constantly derive-type) ((value))
(specifier-type
;;; Make source transforms to turn CxR forms into combinations of CAR
;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
;;; defined.
+;;; Don't transform CAD*R, they are treated specially for &more args
+;;; optimizations
+
(/show0 "about to set CxR source transforms")
(loop for i of-type index from 2 upto 4 do
;; Iterate over BUF = all names CxR where x = an I-element
(declare (type index k))
(setf (aref buf (1+ k))
(if (logbitp k j) #\A #\D)))
- (setf (info :function :source-transform (intern buf))
- #'source-transform-cxr))))
+ (unless (member buf '("CADR" "CADDR" "CADDDR")
+ :test #'equal)
+ (setf (info :function :source-transform (intern buf))
+ #'source-transform-cxr)))))
(/show0 "done setting CxR source transforms")
;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
;;; whatever is right for them is right for us. FIFTH..TENTH turn into
;;; Nth, which can be expanded into a CAR/CDR later on if policy
;;; favors it.
-(define-source-transform first (x) `(car ,x))
(define-source-transform rest (x) `(cdr ,x))
+(define-source-transform first (x) `(car ,x))
(define-source-transform second (x) `(cadr ,x))
(define-source-transform third (x) `(caddr ,x))
(define-source-transform fourth (x) `(cadddr ,x))
(1 `(cons ,(first args) nil))
(t (values nil t))))
+(defoptimizer (list derive-type) ((&rest args) node)
+ (if args
+ (specifier-type 'cons)
+ (specifier-type 'null)))
+
;;; And similarly for LIST*.
(define-source-transform list* (arg &rest others)
(cond ((not others) arg)
(specifier-type 'cons)
(lvar-type arg)))
+;;;
+
+(define-source-transform nconc (&rest args)
+ (case (length args)
+ (0 ())
+ (1 (car args))
+ (t (values nil t))))
+
+;;; (append nil nil nil fixnum) => fixnum
+;;; (append x x cons x x) => cons
+;;; (append x x x x list) => list
+;;; (append x x x x sequence) => sequence
+;;; (append fixnum x ...) => nil
+(defun derive-append-type (args)
+ (when (null args)
+ (return-from derive-append-type (specifier-type 'null)))
+ (let* ((cons-type (specifier-type 'cons))
+ (null-type (specifier-type 'null))
+ (list-type (specifier-type 'list))
+ (last (lvar-type (car (last args)))))
+ ;; Derive the actual return type, assuming that all but the last
+ ;; arguments are LISTs (otherwise, APPEND/NCONC doesn't return).
+ (loop with all-nil = t ; all but the last args are NIL?
+ with some-cons = nil ; some args are conses?
+ for (arg next) on args
+ for lvar-type = (type-approx-intersection2 (lvar-type arg)
+ list-type)
+ while next
+ do (multiple-value-bind (typep definitely)
+ (ctypep nil lvar-type)
+ (cond ((type= lvar-type *empty-type*)
+ ;; type mismatch! insert an inline check that'll cause
+ ;; compile-time warnings.
+ (assert-lvar-type arg list-type
+ (lexenv-policy *lexenv*)))
+ (some-cons) ; we know result's a cons -- nothing to do
+ ((and (not typep) definitely) ; can't be NIL
+ (setf some-cons t)) ; must be a CONS
+ (all-nil
+ (setf all-nil (csubtypep lvar-type null-type)))))
+ finally
+ ;; if some of the previous arguments are CONSes so is the result;
+ ;; if all the previous values are NIL, we're a fancy identity;
+ ;; otherwise, could be either
+ (return (cond (some-cons cons-type)
+ (all-nil last)
+ (t (type-union last cons-type)))))))
+
+(defoptimizer (append derive-type) ((&rest args))
+ (derive-append-type args))
+
+(defoptimizer (sb!impl::append2 derive-type) ((&rest args))
+ (derive-append-type args))
+
+(defoptimizer (nconc derive-type) ((&rest args))
+ (derive-append-type args))
+
;;; Translate RPLACx to LET and SETF.
(define-source-transform rplaca (x y)
(once-only ((n-x x))
(setf (cdr ,n-x) ,y)
,n-x)))
-(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
-
(deftransform last ((list &optional n) (t &optional t))
(let ((c (constant-lvar-p n)))
(cond ((or (not n)
(t (values nil t))))
(define-source-transform get (&rest args)
(case (length args)
- (2 `(sb!impl::get2 ,@args))
+ (2 `(sb!impl::get3 ,@args nil))
(3 `(sb!impl::get3 ,@args))
(t (values nil t))))
;;; on the argument types), but we make it a regular transform so that
;;; the VM has a chance to see the bare LOGTEST and potentiall choose
;;; to implement it differently. --njf, 06-02-2006
-(deftransform logtest ((x y) * *)
- `(not (zerop (logand x y))))
+;;;
+;;; Other transforms may be useful even with direct LOGTEST VOPs; let
+;;; them fire (including the type-directed constant folding below), but
+;;; disable the inlining rewrite in such cases. -- PK, 2013-05-20
+(deftransform logtest ((x y) * * :node node)
+ (let ((type (two-arg-derive-type x y
+ #'logand-derive-type-aux
+ #'logand)))
+ (multiple-value-bind (typep definitely)
+ (ctypep 0 type)
+ (cond ((and (not typep) definitely)
+ t)
+ ((type= type (specifier-type '(eql 0)))
+ nil)
+ ((neq :default (combination-implementation-style node))
+ (give-up-ir1-transform))
+ (t
+ `(not (zerop (logand x y))))))))
(deftransform logbitp
((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
(defun set-bound (x open-p)
(if (and x open-p) (list x) x))
-;;; Apply the function F to a bound X. If X is an open bound, then
-;;; the result will be open. IF X is NIL, the result is NIL.
-(defun bound-func (f x)
+;;; Apply the function F to a bound X. If X is an open bound and the
+;;; function is declared strictly monotonic, then the result will be
+;;; open. IF X is NIL, the result is NIL.
+(defun bound-func (f x strict)
(declare (type function f))
(and x
- (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
- ;; With these traps masked, we might get things like infinity
- ;; or negative infinity returned. Check for this and return
- ;; NIL to indicate unbounded.
- (let ((y (funcall f (type-bound-number x))))
- (if (and (floatp y)
- (float-infinity-p y))
- nil
- (set-bound y (consp x)))))))
+ (handler-case
+ (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
+ ;; With these traps masked, we might get things like infinity
+ ;; or negative infinity returned. Check for this and return
+ ;; NIL to indicate unbounded.
+ (let ((y (funcall f (type-bound-number x))))
+ (if (and (floatp y)
+ (float-infinity-p y))
+ nil
+ (set-bound y (and strict (consp x))))))
+ ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g.
+ ;; in the course of converting a bignum to a float. Default to
+ ;; NIL in that case.
+ (simple-type-error ()))))
(defun safe-double-coercion-p (x)
(or (typep x 'double-float)
(defun safe-single-coercion-p (x)
(or (typep x 'single-float)
- ;; Fix for bug 420, and related issues: during type derivation we often
- ;; end up deriving types for both
- ;;
- ;; (some-op <int> <single>)
- ;; and
- ;; (some-op (coerce <int> 'single-float) <single>)
- ;;
- ;; or other equivalent transformed forms. The problem with this is that
- ;; on some platforms like x86 (+ <int> <single>) is on the machine level
- ;; equivalent of
- ;;
- ;; (coerce (+ (coerce <int> 'double-float)
- ;; (coerce <single> 'double-float))
- ;; 'single-float)
- ;;
- ;; so if the result of (coerce <int> 'single-float) is not exact, the
- ;; derived types for the transformed forms will have an empty
- ;; intersection -- which in turn means that the compiler will conclude
- ;; that the call never returns, and all hell breaks lose when it *does*
- ;; return at runtime. (This affects not just +, but other operators are
- ;; well.)
- (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
- (integer (,most-positive-exactly-single-float-fixnum) *))))
- (<= most-negative-single-float x most-positive-single-float))))
+ (and
+ ;; Fix for bug 420, and related issues: during type derivation we often
+ ;; end up deriving types for both
+ ;;
+ ;; (some-op <int> <single>)
+ ;; and
+ ;; (some-op (coerce <int> 'single-float) <single>)
+ ;;
+ ;; or other equivalent transformed forms. The problem with this
+ ;; is that on x86 (+ <int> <single>) is on the machine level
+ ;; equivalent of
+ ;;
+ ;; (coerce (+ (coerce <int> 'double-float)
+ ;; (coerce <single> 'double-float))
+ ;; 'single-float)
+ ;;
+ ;; so if the result of (coerce <int> 'single-float) is not exact, the
+ ;; derived types for the transformed forms will have an empty
+ ;; intersection -- which in turn means that the compiler will conclude
+ ;; that the call never returns, and all hell breaks lose when it *does*
+ ;; return at runtime. (This affects not just +, but other operators are
+ ;; well.)
+ ;;
+ ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P
+ ;;
+ ;; FIXME: If we ever add SSE-support for x86, this conditional needs to
+ ;; change.
+ #!+x86
+ (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
+ (integer (,most-positive-exactly-single-float-fixnum) *))))
+ (<= most-negative-single-float x most-positive-single-float))))
;;; Apply a binary operator OP to two bounds X and Y. The result is
;;; NIL if either is NIL. Otherwise bound is computed and the result
`(and (not (fp-zero-p ,xb))
(not (fp-zero-p ,yb))))))))))))
+(defun coercion-loses-precision-p (val type)
+ (typecase val
+ (single-float)
+ (double-float (subtypep type 'single-float))
+ (rational (subtypep type 'float))
+ (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type))))
+
(defun coerce-for-bound (val type)
(if (consp val)
- (list (coerce-for-bound (car val) type))
+ (let ((xbound (coerce-for-bound (car val) type)))
+ (if (coercion-loses-precision-p (car val) type)
+ xbound
+ (list xbound)))
(cond
((subtypep type 'double-float)
(if (<= most-negative-double-float val most-positive-double-float)
(defun coerce-and-truncate-floats (val type)
(when val
(if (consp val)
- (list (coerce-and-truncate-floats (car val) type))
+ (let ((xbound (coerce-for-bound (car val) type)))
+ (if (coercion-loses-precision-p (car val) type)
+ xbound
+ (list xbound)))
(cond
((subtypep type 'double-float)
(if (<= most-negative-double-float val most-positive-double-float)
:high (copy-interval-limit (interval-high x))))
;;; Given a point P contained in the interval X, split X into two
-;;; interval at the point P. If CLOSE-LOWER is T, then the left
+;;; intervals at the point P. If CLOSE-LOWER is T, then the left
;;; interval contains P. If CLOSE-UPPER is T, the right interval
;;; contains P. You can specify both to be T or NIL.
(defun interval-split (p x &optional close-lower close-upper)
;;; the negative of an interval
(defun interval-neg (x)
(declare (type interval x))
- (make-interval :low (bound-func #'- (interval-high x))
- :high (bound-func #'- (interval-low x))))
+ (make-interval :low (bound-func #'- (interval-high x) t)
+ :high (bound-func #'- (interval-low x) t)))
;;; Add two intervals.
(defun interval-add (x y)
((zerop (type-bound-number y))
;; Divide by zero means result is infinity
nil)
- ((and (numberp x) (zerop x))
- ;; Zero divided by anything is zero.
- x)
(t
(bound-binop / x y)))))
(let ((top-range (interval-range-info top))
;;; Apply the function F to the interval X. If X = [a, b], then the
;;; result is [f(a), f(b)]. It is up to the user to make sure the
-;;; result makes sense. It will if F is monotonic increasing (or
-;;; non-decreasing).
-(defun interval-func (f x)
+;;; result makes sense. It will if F is monotonic increasing (or, if
+;;; the interval is closed, non-decreasing).
+;;;
+;;; (Actually most uses of INTERVAL-FUNC are coercions to float types,
+;;; which are not monotonic increasing, so default to calling
+;;; BOUND-FUNC with a non-strict argument).
+(defun interval-func (f x &optional increasing)
(declare (type function f)
(type interval x))
- (let ((lo (bound-func f (interval-low x)))
- (hi (bound-func f (interval-high x))))
+ (let ((lo (bound-func f (interval-low x) increasing))
+ (hi (bound-func f (interval-high x) increasing)))
(make-interval :low lo :high hi)))
;;; Return T if X < Y. That is every number in the interval X is
;;; Compute the square of an interval.
(defun interval-sqr (x)
(declare (type interval x))
- (interval-func (lambda (x) (* x x))
- (interval-abs x)))
+ (interval-func (lambda (x) (* x x)) (interval-abs x)))
\f
;;;; numeric DERIVE-TYPE methods
;;; a utility for defining derive-type methods of integer operations. If
;;; the types of both X and Y are integer types, then we compute a new
-;;; integer type with bounds determined Fun when applied to X and Y.
+;;; integer type with bounds determined by FUN when applied to X and Y.
;;; Otherwise, we use NUMERIC-CONTAGION.
(defun derive-integer-type-aux (x y fun)
(declare (type function fun))
(if (and divisor-low divisor-high)
;; We know the range of the divisor, and the remainder must be
;; smaller than the divisor. We can tell the sign of the
- ;; remainer if we know the sign of the number.
+ ;; remainder if we know the sign of the number.
(let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
`(integer ,(if (or (null number-low)
(minusp number-low))
divisor-max
0)))
;; The divisor is potentially either very positive or very
- ;; negative. Therefore, the remainer is unbounded, but we might
+ ;; negative. Therefore, the remainder is unbounded, but we might
;; be able to tell something about the sign from the number.
`(integer ,(if (and number-low (not (minusp number-low)))
;; The number we are dividing is positive.
(defoptimizer (random derive-type) ((bound &optional state))
(one-arg-derive-type bound #'random-derive-type-aux nil))
\f
-;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends
-
-;;; Return the maximum number of bits an integer of the supplied type
-;;; can take up, or NIL if it is unbounded. The second (third) value
-;;; is T if the integer can be positive (negative) and NIL if not.
-;;; Zero counts as positive.
-(defun integer-type-length (type)
- (if (numeric-type-p type)
- (let ((min (numeric-type-low type))
- (max (numeric-type-high type)))
- (values (and min max (max (integer-length min) (integer-length max)))
- (or (null max) (not (minusp max)))
- (or (null min) (minusp min))))
- (values nil t t)))
-
-;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
-;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
-;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
-;;; versions in CMUCL, from which these functions copy liberally.
-
-(defun logand-derive-unsigned-low-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
- until (zerop m) do
- (unless (zerop (logand m (lognot a) (lognot c)))
- (let ((temp (logandc2 (logior a m) (1- m))))
- (when (<= temp b)
- (setf a temp)
- (loop-finish))
- (setf temp (logandc2 (logior c m) (1- m)))
- (when (<= temp d)
- (setf c temp)
- (loop-finish))))
- finally (return (logand a c)))))
-
-(defun logand-derive-unsigned-high-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
- until (zerop m) do
- (cond
- ((not (zerop (logand b (lognot d) m)))
- (let ((temp (logior (logandc2 b m) (1- m))))
- (when (>= temp a)
- (setf b temp)
- (loop-finish))))
- ((not (zerop (logand (lognot b) d m)))
- (let ((temp (logior (logandc2 d m) (1- m))))
- (when (>= temp c)
- (setf d temp)
- (loop-finish)))))
- finally (return (logand b d)))))
-
-(defun logand-derive-type-aux (x y &optional same-leaf)
- (when same-leaf
- (return-from logand-derive-type-aux x))
- (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
- (declare (ignore x-pos))
- (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
- (declare (ignore y-pos))
- (if (not x-neg)
- ;; X must be positive.
- (if (not y-neg)
- ;; They must both be positive.
- (cond ((and (null x-len) (null y-len))
- (specifier-type 'unsigned-byte))
- ((null x-len)
- (specifier-type `(unsigned-byte* ,y-len)))
- ((null y-len)
- (specifier-type `(unsigned-byte* ,x-len)))
- (t
- (let ((low (logand-derive-unsigned-low-bound x y))
- (high (logand-derive-unsigned-high-bound x y)))
- (specifier-type `(integer ,low ,high)))))
- ;; X is positive, but Y might be negative.
- (cond ((null x-len)
- (specifier-type 'unsigned-byte))
- (t
- (specifier-type `(unsigned-byte* ,x-len)))))
- ;; X might be negative.
- (if (not y-neg)
- ;; Y must be positive.
- (cond ((null y-len)
- (specifier-type 'unsigned-byte))
- (t (specifier-type `(unsigned-byte* ,y-len))))
- ;; Either might be negative.
- (if (and x-len y-len)
- ;; The result is bounded.
- (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
- ;; We can't tell squat about the result.
- (specifier-type 'integer)))))))
-
-(defun logior-derive-unsigned-low-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
- until (zerop m) do
- (cond
- ((not (zerop (logandc2 (logand c m) a)))
- (let ((temp (logand (logior a m) (1+ (lognot m)))))
- (when (<= temp b)
- (setf a temp)
- (loop-finish))))
- ((not (zerop (logandc2 (logand a m) c)))
- (let ((temp (logand (logior c m) (1+ (lognot m)))))
- (when (<= temp d)
- (setf c temp)
- (loop-finish)))))
- finally (return (logior a c)))))
-
-(defun logior-derive-unsigned-high-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
- until (zerop m) do
- (unless (zerop (logand b d m))
- (let ((temp (logior (- b m) (1- m))))
- (when (>= temp a)
- (setf b temp)
- (loop-finish))
- (setf temp (logior (- d m) (1- m)))
- (when (>= temp c)
- (setf d temp)
- (loop-finish))))
- finally (return (logior b d)))))
-
-(defun logior-derive-type-aux (x y &optional same-leaf)
- (when same-leaf
- (return-from logior-derive-type-aux x))
- (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
- (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
- (cond
- ((and (not x-neg) (not y-neg))
- ;; Both are positive.
- (if (and x-len y-len)
- (let ((low (logior-derive-unsigned-low-bound x y))
- (high (logior-derive-unsigned-high-bound x y)))
- (specifier-type `(integer ,low ,high)))
- (specifier-type `(unsigned-byte* *))))
- ((not x-pos)
- ;; X must be negative.
- (if (not y-pos)
- ;; Both are negative. The result is going to be negative
- ;; and be the same length or shorter than the smaller.
- (if (and x-len y-len)
- ;; It's bounded.
- (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
- ;; It's unbounded.
- (specifier-type '(integer * -1)))
- ;; X is negative, but we don't know about Y. The result
- ;; will be negative, but no more negative than X.
- (specifier-type
- `(integer ,(or (numeric-type-low x) '*)
- -1))))
- (t
- ;; X might be either positive or negative.
- (if (not y-pos)
- ;; But Y is negative. The result will be negative.
- (specifier-type
- `(integer ,(or (numeric-type-low y) '*)
- -1))
- ;; We don't know squat about either. It won't get any bigger.
- (if (and x-len y-len)
- ;; Bounded.
- (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
- ;; Unbounded.
- (specifier-type 'integer))))))))
-
-(defun logxor-derive-unsigned-low-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
- until (zerop m) do
- (cond
- ((not (zerop (logandc2 (logand c m) a)))
- (let ((temp (logand (logior a m)
- (1+ (lognot m)))))
- (when (<= temp b)
- (setf a temp))))
- ((not (zerop (logandc2 (logand a m) c)))
- (let ((temp (logand (logior c m)
- (1+ (lognot m)))))
- (when (<= temp d)
- (setf c temp)))))
- finally (return (logxor a c)))))
-
-(defun logxor-derive-unsigned-high-bound (x y)
- (let ((a (numeric-type-low x))
- (b (numeric-type-high x))
- (c (numeric-type-low y))
- (d (numeric-type-high y)))
- (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
- until (zerop m) do
- (unless (zerop (logand b d m))
- (let ((temp (logior (- b m) (1- m))))
- (cond
- ((>= temp a) (setf b temp))
- (t (let ((temp (logior (- d m) (1- m))))
- (when (>= temp c)
- (setf d temp)))))))
- finally (return (logxor b d)))))
-
-(defun logxor-derive-type-aux (x y &optional same-leaf)
- (when same-leaf
- (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
- (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
- (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
- (cond
- ((and (not x-neg) (not y-neg))
- ;; Both are positive
- (if (and x-len y-len)
- (let ((low (logxor-derive-unsigned-low-bound x y))
- (high (logxor-derive-unsigned-high-bound x y)))
- (specifier-type `(integer ,low ,high)))
- (specifier-type '(unsigned-byte* *))))
- ((and (not x-pos) (not y-pos))
- ;; Both are negative. The result will be positive, and as long
- ;; as the longer.
- (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
- (max x-len y-len)
- '*))))
- ((or (and (not x-pos) (not y-neg))
- (and (not y-pos) (not x-neg)))
- ;; Either X is negative and Y is positive or vice-versa. The
- ;; result will be negative.
- (specifier-type `(integer ,(if (and x-len y-len)
- (ash -1 (max x-len y-len))
- '*)
- -1)))
- ;; We can't tell what the sign of the result is going to be.
- ;; All we know is that we don't create new bits.
- ((and x-len y-len)
- (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
- (t
- (specifier-type 'integer))))))
-
-(macrolet ((deffrob (logfun)
- (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
- `(defoptimizer (,logfun derive-type) ((x y))
- (two-arg-derive-type x y #',fun-aux #',logfun)))))
- (deffrob logand)
- (deffrob logior)
- (deffrob logxor))
-
-(defoptimizer (logeqv derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (lognot-derive-type-aux
- (logxor-derive-type-aux x y same-leaf)))
- #'logeqv))
-(defoptimizer (lognand derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (lognot-derive-type-aux
- (logand-derive-type-aux x y same-leaf)))
- #'lognand))
-(defoptimizer (lognor derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (lognot-derive-type-aux
- (logior-derive-type-aux x y same-leaf)))
- #'lognor))
-(defoptimizer (logandc1 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql 0))
- (logand-derive-type-aux
- (lognot-derive-type-aux x) y nil)))
- #'logandc1))
-(defoptimizer (logandc2 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql 0))
- (logand-derive-type-aux
- x (lognot-derive-type-aux y) nil)))
- #'logandc2))
-(defoptimizer (logorc1 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql -1))
- (logior-derive-type-aux
- (lognot-derive-type-aux x) y nil)))
- #'logorc1))
-(defoptimizer (logorc2 derive-type) ((x y))
- (two-arg-derive-type x y (lambda (x y same-leaf)
- (if same-leaf
- (specifier-type '(eql -1))
- (logior-derive-type-aux
- x (lognot-derive-type-aux y) nil)))
- #'logorc2))
-\f
;;;; miscellaneous derive-type methods
(defoptimizer (integer-length derive-type) ((x))
`(mod ,base-char-code-limit)))
(t
(specifier-type
- `(mod ,char-code-limit))))))
+ `(mod ,sb!xc:char-code-limit))))))
(defoptimizer (code-char derive-type) ((code))
(let ((type (lvar-type code)))
(specifier-type `(signed-byte ,size-high))
*universal-type*))
*universal-type*)))
+\f
+;;; Rightward ASH
+#!+ash-right-vops
+(progn
+ (defun %ash/right (integer amount)
+ (ash integer (- amount)))
+
+ (deftransform ash ((integer amount))
+ "Convert ASH of signed word to %ASH/RIGHT"
+ (unless (and (csubtypep (lvar-type integer) ; do that ourselves to avoid
+ (specifier-type 'sb!vm:signed-word)) ; optimization
+ (csubtypep (lvar-type amount) ; notes.
+ (specifier-type '(integer * 0))))
+ (give-up-ir1-transform))
+ (when (constant-lvar-p amount)
+ (give-up-ir1-transform))
+ (let ((use (lvar-uses amount)))
+ (cond ((and (combination-p use)
+ (eql '%negate (lvar-fun-name (combination-fun use))))
+ (splice-fun-args amount '%negate 1)
+ `(lambda (integer amount)
+ (declare (type unsigned-byte amount))
+ (%ash/right integer (if (>= amount ,sb!vm:n-word-bits)
+ ,(1- sb!vm:n-word-bits)
+ amount))))
+ (t
+ `(%ash/right integer (if (<= amount ,(- sb!vm:n-word-bits))
+ ,(1- sb!vm:n-word-bits)
+ (- amount)))))))
+
+ (deftransform ash ((integer amount))
+ "Convert ASH of word to %ASH/RIGHT"
+ (unless (and (csubtypep (lvar-type integer)
+ (specifier-type 'sb!vm:word))
+ (csubtypep (lvar-type amount)
+ (specifier-type '(integer * 0))))
+ (give-up-ir1-transform))
+ (when (constant-lvar-p amount)
+ (give-up-ir1-transform))
+ (let ((use (lvar-uses amount)))
+ (cond ((and (combination-p use)
+ (eql '%negate (lvar-fun-name (combination-fun use))))
+ (splice-fun-args amount '%negate 1)
+ `(lambda (integer amount)
+ (declare (type unsigned-byte amount))
+ (if (>= amount ,sb!vm:n-word-bits)
+ 0
+ (%ash/right integer amount))))
+ (t
+ `(if (<= amount ,(- sb!vm:n-word-bits))
+ 0
+ (%ash/right integer (- amount)))))))
+
+ (deftransform %ash/right ((integer amount) (integer (constant-arg unsigned-byte)))
+ "Convert %ASH/RIGHT by constant back to ASH"
+ `(ash integer ,(- (lvar-value amount))))
+
+ (deftransform %ash/right ((integer amount) * * :node node)
+ "strength reduce large variable right shift"
+ (let ((return-type (single-value-type (node-derived-type node))))
+ (cond ((type= return-type (specifier-type '(eql 0)))
+ 0)
+ ((type= return-type (specifier-type '(eql -1)))
+ -1)
+ ((csubtypep return-type (specifier-type '(member -1 0)))
+ `(ash integer ,(- sb!vm:n-word-bits)))
+ (t
+ (give-up-ir1-transform)))))
+ (defun %ash/right-derive-type-aux (n-type shift same-arg)
+ (declare (ignore same-arg))
+ (or (and (or (csubtypep n-type (specifier-type 'sb!vm:signed-word))
+ (csubtypep n-type (specifier-type 'word)))
+ (csubtypep shift (specifier-type `(mod ,sb!vm:n-word-bits)))
+ (let ((n-low (numeric-type-low n-type))
+ (n-high (numeric-type-high n-type))
+ (s-low (numeric-type-low shift))
+ (s-high (numeric-type-high shift)))
+ (make-numeric-type :class 'integer :complexp :real
+ :low (when n-low
+ (if (minusp n-low)
+ (ash n-low (- s-low))
+ (ash n-low (- s-high))))
+ :high (when n-high
+ (if (minusp n-high)
+ (ash n-high (- s-high))
+ (ash n-high (- s-low)))))))
+ *universal-type*))
+
+ (defoptimizer (%ash/right derive-type) ((n shift))
+ (two-arg-derive-type n shift #'%ash/right-derive-type-aux #'%ash/right))
+ )
\f
;;; Modular functions
(setf (node-reoptimize node) t)
(setf (block-reoptimize (node-block node)) t)
(reoptimize-component (node-component node) :maybe))
- (cut-node (node &aux did-something)
- (when (and (not (block-delete-p (node-block node)))
- (combination-p node)
- (eq (basic-combination-kind node) :known))
- (let* ((fun-ref (lvar-use (combination-fun node)))
- (fun-name (leaf-source-name (ref-leaf fun-ref)))
- (modular-fun (find-modular-version fun-name kind signedp width)))
- (when (and modular-fun
- (not (and (eq fun-name 'logand)
- (csubtypep
- (single-value-type (node-derived-type node))
- type))))
- (binding* ((name (etypecase modular-fun
- ((eql :good) fun-name)
- (modular-fun-info
- (modular-fun-info-name modular-fun))
- (function
- (funcall modular-fun node width)))
- :exit-if-null))
+ (insert-lvar-cut (lvar)
+ "Insert a LOGAND/MASK-SIGNED-FIELD to cut the value of LVAR
+ to the required bit width. Returns T if any change was made.
+
+ When the destination of LVAR will definitely cut LVAR's value
+ to width (i.e. it's a logand or mask-signed-field with constant
+ other argument), do nothing. Otherwise, splice LOGAND/M-S-F in."
+ (binding* ((dest (lvar-dest lvar) :exit-if-null)
+ (nil (combination-p dest) :exit-if-null)
+ (name (lvar-fun-name (combination-fun dest) t))
+ (args (combination-args dest)))
+ (case name
+ (logand
+ (when (= 2 (length args))
+ (let ((other (if (eql (first args) lvar)
+ (second args)
+ (first args))))
+ (when (and (constant-lvar-p other)
+ (ctypep (lvar-value other) type)
+ (not signedp))
+ (return-from insert-lvar-cut)))))
+ (mask-signed-field
+ (when (and signedp
+ (eql lvar (second args))
+ (constant-lvar-p (first args))
+ (<= (lvar-value (first args)) width))
+ (return-from insert-lvar-cut)))))
+ (filter-lvar lvar
+ (if signedp
+ `(mask-signed-field ,width 'dummy)
+ `(logand 'dummy ,(ldb (byte width 0) -1))))
+ (do-uses (node lvar)
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe))
+ t)
+ (cut-node (node)
+ "Try to cut a node to width. The primary return value is
+ whether we managed to cut (cleverly), and the second whether
+ anything was changed. The third return value tells whether
+ the cut value might be wider than expected."
+ (when (block-delete-p (node-block node))
+ (return-from cut-node (values t nil)))
+ (typecase node
+ (ref
+ (typecase (ref-leaf node)
+ (constant
+ (let* ((constant-value (constant-value (ref-leaf node)))
+ (new-value
+ (cond ((not (integerp constant-value))
+ (return-from cut-node (values t nil)))
+ (signedp
+ (mask-signed-field width constant-value))
+ (t
+ (ldb (byte width 0) constant-value)))))
+ (cond ((= constant-value new-value)
+ (values t nil)) ; we knew what to do and did nothing
+ (t
+ (change-ref-leaf node (make-constant new-value)
+ :recklessly t)
+ (let ((lvar (node-lvar node)))
+ (setf (lvar-%derived-type lvar)
+ (and (lvar-has-single-use-p lvar)
+ (make-values-type :required (list (ctype-of new-value))))))
+ (setf (block-reoptimize (node-block node)) t)
+ (reoptimize-component (node-component node) :maybe)
+ (values t t)))))))
+ (combination
+ (when (eq (basic-combination-kind node) :known)
+ (let* ((fun-ref (lvar-use (combination-fun node)))
+ (fun-name (lvar-fun-name (combination-fun node)))
+ (modular-fun (find-modular-version fun-name kind
+ signedp width)))
+ (cond ((not modular-fun)
+ ;; don't know what to do here
+ (values nil nil))
+ ((let ((dtype (single-value-type
+ (node-derived-type node))))
+ (and
+ (case fun-name
+ (logand
+ (csubtypep dtype
+ (specifier-type 'unsigned-byte)))
+ (logior
+ (csubtypep dtype
+ (specifier-type '(integer * 0))))
+ (mask-signed-field
+ t)
+ (t nil))
+ (csubtypep dtype type)))
+ ;; nothing to do
+ (values t nil))
+ (t
+ (binding* ((name (etypecase modular-fun
+ ((eql :good) fun-name)
+ (modular-fun-info
+ (modular-fun-info-name modular-fun))
+ (function
+ (funcall modular-fun node width)))
+ :exit-if-null)
+ (did-something nil)
+ (over-wide nil))
(unless (eql modular-fun :good)
- (setq did-something t)
+ (setq did-something t
+ over-wide t)
(change-ref-leaf
fun-ref
(find-free-fun name "in a strange place"))
(setf (combination-kind node) :full))
(unless (functionp modular-fun)
(dolist (arg (basic-combination-args node))
- (when (cut-lvar arg)
- (setq did-something t))))
+ (multiple-value-bind (change wide)
+ (cut-lvar arg)
+ (setf did-something (or did-something change)
+ over-wide (or over-wide wide)))))
(when did-something
(reoptimize-node node name))
- did-something)))))
- (cut-lvar (lvar &aux did-something)
+ (values t did-something over-wide)))))))))
+ (cut-lvar (lvar &key head
+ &aux did-something must-insert over-wide)
+ "Cut all the LVAR's use nodes. If any of them wasn't handled
+ and its type is too wide for the operation we wish to perform
+ insert an explicit bit-width narrowing operation (LOGAND or
+ MASK-SIGNED-FIELD) between the LVAR (*) and its destination.
+ The narrowing operation might not be inserted if the LVAR's
+ destination is already such an operation, to avoid endless
+ recursion.
+
+ If we're at the head, forcibly insert a cut operation if the
+ result might be too wide.
+
+ (*) We can't easily do that for each node, and doing so might
+ result in code bloat, anyway. (I'm also not sure it would be
+ correct for complicated C/D FG)"
(do-uses (node lvar)
- (when (cut-node node)
- (setq did-something t)))
- did-something))
- (cut-lvar lvar))))
+ (multiple-value-bind (handled any-change wide)
+ (cut-node node)
+ (setf did-something (or did-something any-change)
+ must-insert (or must-insert
+ (not (or handled
+ (csubtypep (single-value-type
+ (node-derived-type node))
+ type))))
+ over-wide (or over-wide wide))))
+ (when (or must-insert
+ (and head over-wide))
+ (setf did-something (or (insert-lvar-cut lvar) did-something)
+ ;; we're just the right width after an explicit cut.
+ over-wide nil))
+ (values did-something over-wide)))
+ (cut-lvar lvar :head t))))
(defun best-modular-version (width signedp)
;; 1. exact width-matched :untagged
;; 3. >/>= width-matched :untagged
(let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
(uswidths (modular-class-widths *untagged-signed-modular-class*))
- (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+ (uwidths (if (and uuwidths uswidths)
+ (merge 'list (copy-list uuwidths) (copy-list uswidths)
+ #'< :key #'car)
+ (or uuwidths uswidths)))
(twidths (modular-class-widths *tagged-modular-class*)))
(let ((exact (find (cons width signedp) uwidths :test #'equal)))
(when exact
(return-from best-modular-version
(values (car ugt) :untagged (cdr ugt))))))))
+(defun integer-type-numeric-bounds (type)
+ (typecase type
+ (numeric-type (values (numeric-type-low type)
+ (numeric-type-high type)))
+ (union-type
+ (let ((low nil)
+ (high nil))
+ (dolist (type (union-type-types type) (values low high))
+ (unless (and (numeric-type-p type)
+ (eql (numeric-type-class type) 'integer))
+ (return (values nil nil)))
+ (let ((this-low (numeric-type-low type))
+ (this-high (numeric-type-high type)))
+ (unless (and this-low this-high)
+ (return (values nil nil)))
+ (setf low (min this-low (or low this-low))
+ high (max this-high (or high this-high)))))))))
+
(defoptimizer (logand optimizer) ((x y) node)
(let ((result-type (single-value-type (node-derived-type node))))
- (when (numeric-type-p result-type)
- (let ((low (numeric-type-low result-type))
- (high (numeric-type-high result-type)))
- (when (and (numberp low)
- (numberp high)
- (>= low 0))
- (let ((width (integer-length high)))
- (multiple-value-bind (w kind signedp)
- (best-modular-version width nil)
- (when w
- ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
- (cut-to-width x kind width signedp)
- (cut-to-width y kind width signedp)
- nil ; After fixing above, replace with T.
- ))))))))
+ (multiple-value-bind (low high)
+ (integer-type-numeric-bounds result-type)
+ (when (and (numberp low)
+ (numberp high)
+ (>= low 0))
+ (let ((width (integer-length high)))
+ (multiple-value-bind (w kind signedp)
+ (best-modular-version width nil)
+ (when w
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
+ ;;
+ ;; FIXME: I think the FIXME (which is from APD) above
+ ;; implies that CUT-TO-WIDTH should do /everything/
+ ;; that's required, including reoptimizing things
+ ;; itself that it knows are necessary. At the moment,
+ ;; CUT-TO-WIDTH sets up some new calls with
+ ;; combination-type :FULL, which later get noticed as
+ ;; known functions and properly converted.
+ ;;
+ ;; We cut to W not WIDTH if SIGNEDP is true, because
+ ;; signed constant replacement needs to know which bit
+ ;; in the field is the signed bit.
+ (let ((xact (cut-to-width x kind (if signedp w width) signedp))
+ (yact (cut-to-width y kind (if signedp w width) signedp)))
+ (declare (ignore xact yact))
+ nil) ; After fixing above, replace with T, meaning
+ ; "don't reoptimize this (LOGAND) node any more".
+ )))))))
(defoptimizer (mask-signed-field optimizer) ((width x) node)
(let ((result-type (single-value-type (node-derived-type node))))
- (when (numeric-type-p result-type)
- (let ((low (numeric-type-low result-type))
- (high (numeric-type-high result-type)))
- (when (and (numberp low) (numberp high))
- (let ((width (max (integer-length high) (integer-length low))))
- (multiple-value-bind (w kind)
- (best-modular-version width t)
- (when w
- ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T).
- (cut-to-width x kind width t)
- nil ; After fixing above, replace with T.
- ))))))))
+ (multiple-value-bind (low high)
+ (integer-type-numeric-bounds result-type)
+ (when (and (numberp low) (numberp high))
+ (let ((width (max (integer-length high) (integer-length low))))
+ (multiple-value-bind (w kind)
+ (best-modular-version (1+ width) t)
+ (when w
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T).
+ ;; [ see comment above in LOGAND optimizer ]
+ (cut-to-width x kind w t)
+ nil ; After fixing above, replace with T.
+ )))))))
+
+(defoptimizer (logior optimizer) ((x y) node)
+ (let ((result-type (single-value-type (node-derived-type node))))
+ (multiple-value-bind (low high)
+ (integer-type-numeric-bounds result-type)
+ (when (and (numberp low)
+ (numberp high)
+ (<= high 0))
+ (let ((width (integer-length low)))
+ (multiple-value-bind (w kind)
+ (best-modular-version (1+ width) t)
+ (when w
+ ;; FIXME: see comment in LOGAND optimizer
+ (let ((xact (cut-to-width x kind w t))
+ (yact (cut-to-width y kind w t)))
+ (declare (ignore xact yact))
+ nil) ; After fixing above, replace with T
+ )))))))
\f
;;; miscellanous numeric transforms
(if (and (constant-lvar-p x)
(not (constant-lvar-p y)))
`(,(lvar-fun-name (basic-combination-fun node))
- y
+ (truly-the ,(lvar-type y) y)
,(lvar-value x))
(give-up-ir1-transform)))
-(dolist (x '(= char= + * logior logand logxor))
+(dolist (x '(= char= two-arg-char-equal + * logior logand logxor logtest))
(%deftransform x '(function * *) #'commutative-arg-swap
"place constant arg last"))
(multiple-value-setq (m shift2)
(choose-multiplier (/ y (ash 1 shift1))
(- precision shift1))))
- (if (>= m n)
- (flet ((word (x)
- `(truly-the word ,x)))
- `(let* ((num x)
- (t1 (%multiply num ,(- m n))))
- (ash ,(word `(+ t1 (ash ,(word `(- num t1))
- -1)))
- ,(- 1 shift2))))
- `(ash (%multiply (logandc2 x ,(1- (ash 1 shift1))) ,m)
- ,(- (+ shift1 shift2))))))))
+ (cond ((>= m n)
+ (flet ((word (x)
+ `(truly-the word ,x)))
+ `(let* ((num x)
+ (t1 (%multiply-high num ,(- m n))))
+ (ash ,(word `(+ t1 (ash ,(word `(- num t1))
+ -1)))
+ ,(- 1 shift2)))))
+ ((and (zerop shift1) (zerop shift2))
+ (let ((max (truncate max-x y)))
+ ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
+ ;; VOP.
+ `(truly-the (integer 0 ,max)
+ (%multiply-high x ,m))))
+ (t
+ `(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m)
+ ,(- (+ shift1 shift2)))))))))
;;; If the divisor is constant and both args are positive and fit in a
;;; machine word, replace the division by a multiplication and possibly
(def logxor -1 (lognot x))
(def logxor 0 x))
+(defun least-zero-bit (x)
+ (and (/= x -1)
+ (1- (integer-length (logxor x (1+ x))))))
+
(deftransform logand ((x y) (* (constant-arg t)) *)
"fold identity operation"
- (let ((y (lvar-value y)))
- (unless (and (plusp y)
- (= y (1- (ash 1 (integer-length y)))))
- (give-up-ir1-transform))
- (unless (csubtypep (lvar-type x)
- (specifier-type `(integer 0 ,y)))
+ (let* ((y (lvar-value y))
+ (width (or (least-zero-bit y) '*)))
+ (unless (and (neq width 0) ; (logand x 0) handled elsewhere
+ (csubtypep (lvar-type x)
+ (specifier-type `(unsigned-byte ,width))))
(give-up-ir1-transform))
'x))
(give-up-ir1-transform))
'x))
+(deftransform logior ((x y) (* (constant-arg t)) *)
+ "fold identity operation"
+ (let* ((y (lvar-value y))
+ (width (or (least-zero-bit (lognot y))
+ (give-up-ir1-transform)))) ; (logior x 0) handled elsewhere
+ (unless (csubtypep (lvar-type x)
+ (specifier-type `(integer ,(- (ash 1 width)) -1)))
+ (give-up-ir1-transform))
+ 'x))
+
+;;; Pick off easy association opportunities for constant folding.
+;;; More complicated stuff that also depends on commutativity
+;;; (e.g. (f (f x k1) (f y k2)) => (f (f x y) (f k1 k2))) should
+;;; probably be handled with a more general tree-rewriting pass.
+(macrolet ((def (operator &key (type 'integer) (folded operator))
+ `(deftransform ,operator ((x z) (,type (constant-arg ,type)))
+ ,(format nil "associate ~A/~A of constants"
+ operator folded)
+ (binding* ((node (if (lvar-has-single-use-p x)
+ (lvar-use x)
+ (give-up-ir1-transform)))
+ (nil (or (and (combination-p node)
+ (eq (lvar-fun-name
+ (combination-fun node))
+ ',folded))
+ (give-up-ir1-transform)))
+ (y (second (combination-args node)))
+ (nil (or (constant-lvar-p y)
+ (give-up-ir1-transform)))
+ (y (lvar-value y)))
+ (unless (typep y ',type)
+ (give-up-ir1-transform))
+ (splice-fun-args x ',folded 2)
+ `(lambda (x y z)
+ (declare (ignore y z))
+ ;; (operator (folded x y) z)
+ ;; == (operator x (folded z y))
+ (,',operator x ',(,folded (lvar-value z) y)))))))
+ (def logand)
+ (def logior)
+ (def logxor)
+ (def logtest :folded logand)
+ (def + :type rational)
+ (def + :type rational :folded -)
+ (def * :type rational)
+ (def * :type rational :folded /))
+
+(deftransform mask-signed-field ((width x) ((constant-arg unsigned-byte) *))
+ "Fold mask-signed-field/mask-signed-field of constant width"
+ (binding* ((node (if (lvar-has-single-use-p x)
+ (lvar-use x)
+ (give-up-ir1-transform)))
+ (nil (or (combination-p node)
+ (give-up-ir1-transform)))
+ (nil (or (eq (lvar-fun-name (combination-fun node))
+ 'mask-signed-field)
+ (give-up-ir1-transform)))
+ (x-width (first (combination-args node)))
+ (nil (or (constant-lvar-p x-width)
+ (give-up-ir1-transform)))
+ (x-width (lvar-value x-width)))
+ (unless (typep x-width 'unsigned-byte)
+ (give-up-ir1-transform))
+ (splice-fun-args x 'mask-signed-field 2)
+ `(lambda (width x-width x)
+ (declare (ignore width x-width))
+ (mask-signed-field ,(min (lvar-value width) x-width) x))))
+
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
"convert (* x 0) to 0"
0)
+(deftransform %negate ((x) (rational))
+ "Eliminate %negate/%negate of rationals"
+ (splice-fun-args x '%negate 1)
+ '(the rational x))
+
+(deftransform %negate ((x) (number))
+ "Combine %negate/*"
+ (let ((use (lvar-uses x))
+ arg)
+ (unless (and (combination-p use)
+ (eql '* (lvar-fun-name (combination-fun use)))
+ (constant-lvar-p (setf arg (second (combination-args use))))
+ (numberp (setf arg (lvar-value arg))))
+ (give-up-ir1-transform))
+ (splice-fun-args x '* 2)
+ `(lambda (x y)
+ (declare (ignore y))
+ (* x ,(- arg)))))
+
;;; Return T if in an arithmetic op including lvars X and Y, the
;;; result type is not affected by the type of X. That is, Y is at
;;; least as contagious as X.
(def round)
(def floor)
(def ceiling))
+
+(macrolet ((def (name &optional float)
+ (let ((x (if float '(float x) 'x)))
+ `(deftransform ,name ((x y) (integer (constant-arg (member 1 -1)))
+ *)
+ "fold division by 1"
+ `(values ,(if (minusp (lvar-value y))
+ '(%negate ,x)
+ ',x) 0)))))
+ (def truncate)
+ (def round)
+ (def floor)
+ (def ceiling)
+ (def ftruncate t)
+ (def fround t)
+ (def ffloor t)
+ (def fceiling t))
+
\f
;;;; character operations
-(deftransform char-equal ((a b) (base-char base-char))
+(deftransform two-arg-char-equal ((a b) (base-char base-char) *
+ :policy (> speed space))
"open code"
'(let* ((ac (char-code a))
(bc (char-code b))
(and (> sum 415) (< sum 461))
(and (> sum 463) (< sum 477))))))))
+(deftransform two-arg-char-equal ((a b) (* (constant-arg character)) *
+ :node node)
+ (let ((char (lvar-value b)))
+ (if (both-case-p char)
+ (let ((reverse (if (upper-case-p char)
+ (char-downcase char)
+ (char-upcase char))))
+ (if (policy node (> speed space))
+ `(or (char= a ,char)
+ (char= a ,reverse))
+ `(char-equal-constant a ,char ,reverse)))
+ '(char= a b))))
+
(deftransform char-upcase ((x) (base-char))
"open code"
'(let ((n-code (char-code x)))
((and (csubtypep x-type char-type)
(csubtypep y-type char-type))
'(char= x y))
- ((or (fixnum-type-p x-type) (fixnum-type-p y-type))
- (commutative-arg-swap node))
((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
- '(eq x y))
+ (if (and (constant-lvar-p x) (not (constant-lvar-p y)))
+ '(eq y x)
+ '(eq x y)))
((and (not (constant-lvar-p y))
(or (constant-lvar-p x)
(and (csubtypep x-type y-type)
"convert to simpler equality predicate"
(let ((x-type (lvar-type x))
(y-type (lvar-type y))
- (string-type (specifier-type 'string))
- (bit-vector-type (specifier-type 'bit-vector)))
- (cond
- ((same-leaf-ref-p x y) t)
- ((and (csubtypep x-type string-type)
- (csubtypep y-type string-type))
- '(string= x y))
- ((and (csubtypep x-type bit-vector-type)
- (csubtypep y-type bit-vector-type))
- '(bit-vector-= x y))
- ;; if at least one is not a string, and at least one is not a
- ;; bit-vector, then we can reason from types.
- ((and (not (and (types-equal-or-intersect x-type string-type)
- (types-equal-or-intersect y-type string-type)))
- (not (and (types-equal-or-intersect x-type bit-vector-type)
- (types-equal-or-intersect y-type bit-vector-type)))
- (not (types-equal-or-intersect x-type y-type)))
- nil)
- (t (give-up-ir1-transform)))))
+ (combination-type (specifier-type '(or bit-vector string
+ cons pathname))))
+ (flet ((both-csubtypep (type)
+ (let ((ctype (specifier-type type)))
+ (and (csubtypep x-type ctype)
+ (csubtypep y-type ctype)))))
+ (cond
+ ((same-leaf-ref-p x y) t)
+ ((both-csubtypep 'string)
+ '(string= x y))
+ ((both-csubtypep 'bit-vector)
+ '(bit-vector-= x y))
+ ((both-csubtypep 'pathname)
+ '(pathname= x y))
+ ((or (not (types-equal-or-intersect x-type combination-type))
+ (not (types-equal-or-intersect y-type combination-type)))
+ (if (types-equal-or-intersect x-type y-type)
+ '(eql x y)
+ ;; Can't simply check for type intersection if both types are combination-type
+ ;; since array specialization would mean types don't intersect, even when EQUAL
+ ;; doesn't care for specialization.
+ ;; Previously checking for intersection in the outer COND resulted in
+ ;;
+ ;; (equal (the (cons (or simple-bit-vector
+ ;; simple-base-string))
+ ;; x)
+ ;; (the (cons (or (and bit-vector (not simple-array))
+ ;; (simple-array character (*))))
+ ;; y))
+ ;; being incorrectly folded to NIL
+ nil))
+ (t (give-up-ir1-transform))))))
+
+(deftransform equalp ((x y) * *)
+ "convert to simpler equality predicate"
+ (let ((x-type (lvar-type x))
+ (y-type (lvar-type y))
+ (combination-type (specifier-type '(or number array
+ character
+ cons pathname
+ instance hash-table))))
+ (flet ((both-csubtypep (type)
+ (let ((ctype (specifier-type type)))
+ (and (csubtypep x-type ctype)
+ (csubtypep y-type ctype)))))
+ (cond
+ ((same-leaf-ref-p x y) t)
+ ((both-csubtypep 'string)
+ '(string-equal x y))
+ ((both-csubtypep 'bit-vector)
+ '(bit-vector-= x y))
+ ((both-csubtypep 'pathname)
+ '(pathname= x y))
+ ((both-csubtypep 'character)
+ '(char-equal x y))
+ ((both-csubtypep 'number)
+ '(= x y))
+ ((both-csubtypep 'hash-table)
+ '(hash-table-equalp x y))
+ ((or (not (types-equal-or-intersect x-type combination-type))
+ (not (types-equal-or-intersect y-type combination-type)))
+ ;; See the comment about specialized types in the EQUAL transform above
+ (if (types-equal-or-intersect y-type x-type)
+ '(eq x y)
+ nil))
+ (t (give-up-ir1-transform))))))
;;; Convert to EQL if both args are rational and complexp is specified
;;; and the same for both.
(define-source-transform > (&rest args) (multi-compare '> args nil 'real))
;;; We cannot do the inversion for >= and <= here, since both
;;; (< NaN X) and (> NaN X)
-;;; are false, and we don't have type-inforation available yet. The
+;;; are false, and we don't have type-information available yet. The
;;; deftransforms for two-argument versions of >= and <= takes care of
;;; the inversion to > and < when possible.
(define-source-transform <= (&rest args) (multi-compare '<= args nil 'real))
'character))
(define-source-transform char-equal (&rest args)
- (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t))
+ (multi-compare 'two-arg-char-equal args nil 'character t))
(define-source-transform char-lessp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t))
+ (multi-compare 'two-arg-char-lessp args nil 'character t))
(define-source-transform char-greaterp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t))
+ (multi-compare 'two-arg-char-greaterp args nil 'character t))
(define-source-transform char-not-greaterp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t))
+ (multi-compare 'two-arg-char-greaterp args t 'character t))
(define-source-transform char-not-lessp (&rest args)
- (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t))
+ (multi-compare '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
`(values (the real ,arg0))
`(let ((minrest (min ,@rest)))
(if (<= ,arg0 minrest) ,arg0 minrest)))))
+
+;;; Simplify some cross-type comparisons
+(macrolet ((def (comparator round)
+ `(progn
+ (deftransform ,comparator
+ ((x y) (rational (constant-arg float)))
+ "open-code RATIONAL to FLOAT comparison"
+ (let ((y (lvar-value y)))
+ #-sb-xc-host
+ (when (or (float-nan-p y)
+ (float-infinity-p y))
+ (give-up-ir1-transform))
+ (setf y (rational y))
+ `(,',comparator
+ x ,(if (csubtypep (lvar-type x)
+ (specifier-type 'integer))
+ (,round y)
+ y))))
+ (deftransform ,comparator
+ ((x y) (integer (constant-arg ratio)))
+ "open-code INTEGER to RATIO comparison"
+ `(,',comparator x ,(,round (lvar-value y)))))))
+ (def < ceiling)
+ (def > floor))
+
+(deftransform = ((x y) (rational (constant-arg float)))
+ "open-code RATIONAL to FLOAT comparison"
+ (let ((y (lvar-value y)))
+ #-sb-xc-host
+ (when (or (float-nan-p y)
+ (float-infinity-p y))
+ (give-up-ir1-transform))
+ (setf y (rational y))
+ (if (and (csubtypep (lvar-type x)
+ (specifier-type 'integer))
+ (ratiop y))
+ nil
+ `(= x ,y))))
+
+(deftransform = ((x y) (integer (constant-arg ratio)))
+ "constant-fold INTEGER to RATIO comparison"
+ nil)
\f
;;;; converting N-arg arithmetic functions
;;;;
,@(mapcar (lambda (x) `(values ,x)) (butlast args))
(values-list ,(car (last args))))))
-;;; When &REST argument are at play, we also have extra context and count
-;;; arguments -- convert to %VALUES-LIST-OR-CONTEXT when possible, so that the
-;;; deftransform can decide what to do after everything has been converted.
-(define-source-transform values-list (list)
- (if (symbolp list)
- (let* ((var (lexenv-find list vars))
- (info (when (lambda-var-p var)
- (lambda-var-arg-info var))))
- (if (and info
+;;;; transforming references to &REST argument
+
+;;; We add magical &MORE arguments to all functions with &REST. If ARG names
+;;; the &REST argument, this returns the lambda-vars for the context and
+;;; count.
+(defun possible-rest-arg-context (arg)
+ (when (symbolp arg)
+ (let* ((var (lexenv-find arg vars))
+ (info (when (lambda-var-p var)
+ (lambda-var-arg-info var))))
+ (when (and info
(eq :rest (arg-info-kind info))
(consp (arg-info-default info)))
- (destructuring-bind (context count &optional used) (arg-info-default info)
- (declare (ignore used))
- `(%values-list-or-context ,list ,context ,count))
- (values nil t)))
- (values nil t)))
-
-(deftransform %values-list-or-context ((list context count) * * :node node)
- (let* ((use (lvar-use list))
+ (values-list (arg-info-default info))))))
+
+(defun mark-more-context-used (rest-var)
+ (let ((info (lambda-var-arg-info rest-var)))
+ (aver (eq :rest (arg-info-kind info)))
+ (destructuring-bind (context count &optional used) (arg-info-default info)
+ (unless used
+ (setf (arg-info-default info) (list context count t))))))
+
+(defun mark-more-context-invalid (rest-var)
+ (let ((info (lambda-var-arg-info rest-var)))
+ (aver (eq :rest (arg-info-kind info)))
+ (setf (arg-info-default info) t)))
+
+;;; This determines of we the REF to a &REST variable is headed towards
+;;; parts unknown, or if we can really use the context.
+(defun rest-var-more-context-ok (lvar)
+ (let* ((use (lvar-use lvar))
(var (when (ref-p use) (ref-leaf use)))
(home (when (lambda-var-p var) (lambda-var-home var)))
- (info (when (lambda-var-p var) (lambda-var-arg-info var))))
+ (info (when (lambda-var-p var) (lambda-var-arg-info var)))
+ (restp (when info (eq :rest (arg-info-kind info)))))
(flet ((ref-good-for-more-context-p (ref)
(let ((dest (principal-lvar-end (node-lvar ref))))
(and (combination-p dest)
- ;; Uses outside VALUES-LIST will require a &REST list anyways,
- ;; to it's no use saving effort here -- plus they might modify
- ;; the list destructively.
- (eq '%values-list-or-context (lvar-fun-name (combination-fun dest)))
+ ;; If the destination is to anything but these, we're going to
+ ;; actually need the rest list -- and since other operations
+ ;; might modify the list destructively, the using the context
+ ;; isn't good anywhere else either.
+ (lvar-fun-is (combination-fun dest)
+ '(%rest-values %rest-ref %rest-length
+ %rest-null %rest-true))
;; If the home lambda is different and isn't DX, it might
;; escape -- in which case using the more context isn't safe.
(let ((clambda (node-home-lambda dest)))
(or (eq home clambda)
(leaf-dynamic-extent clambda)))))))
- (let ((context-ok
- (and info
- (consp (arg-info-default info))
- (not (lambda-var-specvar var))
- (not (lambda-var-sets var))
- (every #'ref-good-for-more-context-p (lambda-var-refs var))
- (policy node (= 3 rest-conversion)))))
- (cond (context-ok
- (destructuring-bind (context count &optional used) (arg-info-default info)
- (declare (ignore used))
- (setf (arg-info-default info) (list context count t)))
- `(%more-arg-values context 0 count))
- (t
- (when info
- (setf (arg-info-default info) t))
- `(values-list list)))))))
-
+ (let ((ok (and restp
+ (consp (arg-info-default info))
+ (not (lambda-var-specvar var))
+ (not (lambda-var-sets var))
+ (every #'ref-good-for-more-context-p (lambda-var-refs var)))))
+ (if ok
+ (mark-more-context-used var)
+ (when restp
+ (mark-more-context-invalid var)))
+ ok))))
+
+;;; VALUES-LIST -> %REST-VALUES
+(define-source-transform values-list (list)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-values ,list ,context ,count)
+ (values nil t))))
+
+;;; NTH -> %REST-REF
+(define-source-transform nth (n list)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-ref ,n ,list ,context ,count)
+ `(car (nthcdr ,n ,list)))))
+
+(define-source-transform elt (seq n)
+ (if (policy *lexenv* (= safety 3))
+ (values nil t)
+ (multiple-value-bind (context count) (possible-rest-arg-context seq)
+ (if context
+ `(%rest-ref ,n ,seq ,context ,count)
+ (values nil t)))))
+
+;;; CAxR -> %REST-REF
+(defun source-transform-car (list nth)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-ref ,nth ,list ,context ,count)
+ (values nil t))))
+
+(define-source-transform car (list)
+ (source-transform-car list 0))
+
+(define-source-transform cadr (list)
+ (or (source-transform-car list 1)
+ `(car (cdr ,list))))
+
+(define-source-transform caddr (list)
+ (or (source-transform-car list 2)
+ `(car (cdr (cdr ,list)))))
+
+(define-source-transform cadddr (list)
+ (or (source-transform-car list 3)
+ `(car (cdr (cdr (cdr ,list))))))
+
+;;; LENGTH -> %REST-LENGTH
+(defun source-transform-length (list)
+ (multiple-value-bind (context count) (possible-rest-arg-context list)
+ (if context
+ `(%rest-length ,list ,context ,count)
+ (values nil t))))
+(define-source-transform length (list) (source-transform-length list))
+(define-source-transform list-length (list) (source-transform-length list))
+
+;;; ENDP, NULL and NOT -> %REST-NULL
+;;;
+;;; Outside &REST convert into an IF so that IF optimizations will eliminate
+;;; redundant negations.
+(defun source-transform-null (x op)
+ (multiple-value-bind (context count) (possible-rest-arg-context x)
+ (cond (context
+ `(%rest-null ',op ,x ,context ,count))
+ ((eq 'endp op)
+ `(if (the list ,x) nil t))
+ (t
+ `(if ,x nil t)))))
+(define-source-transform not (x) (source-transform-null x 'not))
+(define-source-transform null (x) (source-transform-null x 'null))
+(define-source-transform endp (x) (source-transform-null x 'endp))
+
+(deftransform %rest-values ((list context count))
+ (if (rest-var-more-context-ok list)
+ `(%more-arg-values context 0 count)
+ `(values-list list)))
+
+(deftransform %rest-ref ((n list context count))
+ (cond ((rest-var-more-context-ok list)
+ `(and (< (the index n) count)
+ (%more-arg context n)))
+ ((and (constant-lvar-p n) (zerop (lvar-value n)))
+ `(car list))
+ (t
+ `(nth n list))))
+
+(deftransform %rest-length ((list context count))
+ (if (rest-var-more-context-ok list)
+ 'count
+ `(length list)))
+
+(deftransform %rest-null ((op list context count))
+ (aver (constant-lvar-p op))
+ (if (rest-var-more-context-ok list)
+ `(eql 0 count)
+ `(,(lvar-value op) list)))
+
+(deftransform %rest-true ((list context count))
+ (if (rest-var-more-context-ok list)
+ `(not (eql 0 count))
+ `list))
\f
;;;; transforming FORMAT
;;;;
(policy-quality-name-p (lvar-value quality-name)))
(give-up-ir1-transform))
'(%policy-quality policy quality-name))
+\f
+(deftransform encode-universal-time
+ ((second minute hour date month year &optional time-zone)
+ ((constant-arg (mod 60)) (constant-arg (mod 60))
+ (constant-arg (mod 24))
+ (constant-arg (integer 1 31))
+ (constant-arg (integer 1 12))
+ (constant-arg (integer 1899))
+ (constant-arg (rational -24 24))))
+ (let ((second (lvar-value second))
+ (minute (lvar-value minute))
+ (hour (lvar-value hour))
+ (date (lvar-value date))
+ (month (lvar-value month))
+ (year (lvar-value year))
+ (time-zone (lvar-value time-zone)))
+ (if (zerop (rem time-zone 1/3600))
+ (encode-universal-time second minute hour date month year time-zone)
+ (give-up-ir1-transform))))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((integer 0 #.(expt 10 8))))
+ `(sb!unix:nanosleep seconds 0))
+
+#!-(and win32 (not sb-thread))
+(deftransform sleep ((seconds) ((constant-arg (real 0))))
+ (let ((seconds-value (lvar-value seconds)))
+ (multiple-value-bind (seconds nano)
+ (sb!impl::split-seconds-for-sleep seconds-value)
+ (if (> seconds (expt 10 8))
+ (give-up-ir1-transform)
+ `(sb!unix:nanosleep ,seconds ,nano)))))
projects / sbcl.git / blobdiff