X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=b66f0f44e9373d3c2d5ef1b42753af6d92e86daa;hb=d01d509257052e694365b76be5ab597fa06764ec;hp=0426eef672f0be7030d7f4fa4ca0d1d2ad2bb9b3;hpb=6d67d71e21d95c26119b8c7cea1bc64811892767;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 0426eef..b66f0f4 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -13,23 +13,12 @@ (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 @@ -99,6 +88,9 @@ ;;; 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 @@ -112,16 +104,18 @@ (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)) @@ -140,6 +134,11 @@ (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) @@ -151,6 +150,63 @@ (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)) @@ -163,8 +219,6 @@ (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) @@ -244,8 +298,24 @@ ;;; 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) @@ -345,20 +415,26 @@ (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) @@ -366,30 +442,37 @@ (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 ) - ;; and - ;; (some-op (coerce 'single-float) ) - ;; - ;; or other equivalent transformed forms. The problem with this is that - ;; on some platforms like x86 (+ ) is on the machine level - ;; equivalent of - ;; - ;; (coerce (+ (coerce 'double-float) - ;; (coerce 'double-float)) - ;; 'single-float) - ;; - ;; so if the result of (coerce '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 ) + ;; and + ;; (some-op (coerce 'single-float) ) + ;; + ;; or other equivalent transformed forms. The problem with this + ;; is that on x86 (+ ) is on the machine level + ;; equivalent of + ;; + ;; (coerce (+ (coerce 'double-float) + ;; (coerce 'double-float)) + ;; 'single-float) + ;; + ;; so if the result of (coerce '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 @@ -452,9 +535,19 @@ `(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) @@ -468,7 +561,10 @@ (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) @@ -517,7 +613,7 @@ :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) @@ -769,8 +865,8 @@ ;;; 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) @@ -848,9 +944,6 @@ ((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)) @@ -882,13 +975,17 @@ ;;; 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 @@ -960,14 +1057,13 @@ ;;; 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))) ;;;; 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)) @@ -2317,7 +2413,7 @@ (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)) @@ -2328,7 +2424,7 @@ 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. @@ -2375,305 +2471,6 @@ (defoptimizer (random derive-type) ((bound &optional state)) (one-arg-derive-type bound #'random-derive-type-aux nil)) -;;;; 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)) - ;;;; miscellaneous derive-type methods (defoptimizer (integer-length derive-type) ((x)) @@ -2967,7 +2764,98 @@ (specifier-type `(signed-byte ,size-high)) *universal-type*)) *universal-type*))) + +;;; 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)) + ) ;;; Modular functions @@ -3032,44 +2920,150 @@ (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 &aux did-something over-wide) + "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 (if signedp + (mask-signed-field width constant-value) + (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)) (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 @@ -3077,7 +3071,10 @@ ;; 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 @@ -3095,38 +3092,87 @@ (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 + ))))))) ;;; miscellanous numeric transforms @@ -3135,11 +3181,11 @@ (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= + * logior logand logxor logtest)) (%deftransform x '(function * *) #'commutative-arg-swap "place constant arg last")) @@ -3283,14 +3329,22 @@ ;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and ;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the ;;; case of division by powers of two. +;;; The algorithm includes an adaptive precision argument. Use it, since +;;; we often have sub-word value ranges. Careful, in this case, we need +;;; p s.t 2^p > n, not the ceiling of the binary log. +;;; Also, for some reason, the paper prefers shifting to masking. Mask +;;; instead. Masking is equivalent to shifting right, then left again; +;;; all the intermediate values are still words, so we just have to shift +;;; right a bit more to compensate, at the end. +;;; ;;; The following two examples show an average case and the worst case ;;; with respect to the complexity of the generated expression, under ;;; a word size of 64 bits: ;;; -;;; (UNSIGNED-DIV-TRANSFORMER 10) -> -;;; (ASH (%MULTIPLY (ASH X 0) 14757395258967641293) -3) +;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) -> +;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3) ;;; -;;; (UNSIGNED-DIV-TRANSFORMER 7) -> +;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) -> ;;; (LET* ((NUM X) ;;; (T1 (%MULTIPLY NUM 2635249153387078803))) ;;; (ASH (LDB (BYTE 64 0) @@ -3299,8 +3353,9 @@ ;;; -1))) ;;; -2)) ;;; -(defun gen-unsigned-div-by-constant-expr (y) - (declare (type (integer 3 #.most-positive-word) y)) +(defun gen-unsigned-div-by-constant-expr (y max-x) + (declare (type (integer 3 #.most-positive-word) y) + (type word max-x)) (aver (not (zerop (logand y (1- y))))) (labels ((ld (x) ;; the floor of the binary logarithm of (positive) X @@ -3318,24 +3373,32 @@ (> shift 0))) (values m-high shift))))) (let ((n (expt 2 sb!vm:n-word-bits)) + (precision (integer-length max-x)) (shift1 0)) (multiple-value-bind (m shift2) - (choose-multiplier y sb!vm:n-word-bits) + (choose-multiplier y precision) (when (and (>= m n) (evenp y)) (setq shift1 (ld (logand y (- y)))) (multiple-value-setq (m shift2) (choose-multiplier (/ y (ash 1 shift1)) - (- sb!vm:n-word-bits shift1)))) - (if (>= m n) - (flet ((word-mod (x) - `(ldb (byte #.sb!vm:n-word-bits 0) ,x))) - `(let* ((num x) - (t1 (%multiply num ,(- m n)))) - (ash ,(word-mod `(+ t1 (ash ,(word-mod `(- num t1)) - -1))) - ,(- 1 shift2)))) - `(ash (%multiply (ash x ,(- shift1)) ,m) - ,(- shift2))))))) + (- precision shift1)))) + (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 @@ -3346,39 +3409,23 @@ ;;; the same value, emit much simpler code to handle that. (This case ;;; may be rare but it's easy to detect and the compiler doesn't find ;;; this optimization on its own.) -(deftransform truncate ((x y) ((unsigned-byte #.sb!vm:n-word-bits) - (constant-arg - (unsigned-byte #.sb!vm:n-word-bits))) +(deftransform truncate ((x y) (word (constant-arg word)) * :policy (and (> speed compilation-speed) (> speed space))) "convert integer division to multiplication" - (let ((y (lvar-value y))) + (let* ((y (lvar-value y)) + (x-type (lvar-type x)) + (max-x (or (and (numeric-type-p x-type) + (numeric-type-high x-type)) + most-positive-word))) ;; Division by zero, one or powers of two is handled elsewhere. (when (zerop (logand y (1- y))) (give-up-ir1-transform)) - ;; The compiler can't derive the result types to maximal tightness - ;; from the transformed expression, so we calculate them here and - ;; add the corresponding specifiers explicitly through TRULY-THE. - ;; This duplicates parts of the TRUNCATE DERIVE-TYPE optimizer but - ;; using that here would be too cumbersome. - (let* ((x-type (lvar-type x)) - (x-low (or (and (numeric-type-p x-type) - (numeric-type-low x-type)) - 0)) - (x-high (or (and (numeric-type-p x-type) - (numeric-type-high x-type)) - (1- (expt 2 #.sb!vm:n-word-bits)))) - (quot-low (truncate x-low y)) - (quot-high (truncate x-high y))) - (if (= quot-low quot-high) - `(values ,quot-low - (- x ,(* quot-low y))) - `(let* ((quot ,(gen-unsigned-div-by-constant-expr y)) - (rem (ldb (byte #.sb!vm:n-word-bits 0) - (- x (* quot ,y))))) - (values (truly-the (integer ,quot-low ,quot-high) quot) - (truly-the (integer 0 ,(1- y)) rem))))))) + `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x)) + (rem (ldb (byte #.sb!vm:n-word-bits 0) + (- x (* quot ,y))))) + (values quot rem)))) ;;;; arithmetic and logical identity operation elimination @@ -3396,14 +3443,17 @@ (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)) @@ -3414,6 +3464,74 @@ (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) *) @@ -3423,6 +3541,25 @@ "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. @@ -3549,6 +3686,24 @@ (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)) + ;;;; character operations @@ -3647,10 +3802,10 @@ ((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) @@ -3666,25 +3821,72 @@ "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. @@ -3834,7 +4036,7 @@ (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)) @@ -3852,15 +4054,15 @@ '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 @@ -3909,6 +4111,48 @@ `(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) ;;;; converting N-arg arithmetic functions ;;;; @@ -4011,57 +4255,165 @@ ,@(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)) ;;;; transforming FORMAT ;;;; @@ -4507,3 +4859,35 @@ (policy-quality-name-p (lvar-value quality-name))) (give-up-ir1-transform)) '(%policy-quality policy quality-name)) + +(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)))))