X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=cc6b36d9124b2859bc4208cd08cfffb0f3393743;hb=f962bad9a3dcfa165fe359e60be48c636a1622ec;hp=1379d9f800877d05e1fe366075c99ef05105e14c;hpb=7ab4cdd5eaf3dce3cc596b348bfc98aaa27469d5;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 1379d9f..cc6b36d 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,78 @@ (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) + (cond ((not args) + (specifier-type 'null)) + (t + (let ((cons-type (specifier-type 'cons)) + (null-type (specifier-type 'null)) + (list-type (specifier-type 'list)) + (last (lvar-type (car (last args))))) + (or + ;; Check that all but the last arguments are lists first + (loop for (arg next) on args + while next + do + (let ((lvar-type (lvar-type arg))) + (unless (or (csubtypep list-type lvar-type) + (csubtypep lvar-type list-type) + ;; Check for NIL specifically, because + ;; SYMBOL or ATOM won't satisfie the above + (csubtypep null-type lvar-type)) + (assert-lvar-type arg list-type + (lexenv-policy *lexenv*)) + (return *empty-type*)))) + (loop with all-nil = t + for (arg next) on args + for lvar-type = (lvar-type arg) + while next + do + (cond + ;; Cons in the middle guarantees the result will be a cons + ((csubtypep lvar-type cons-type) + (return cons-type)) + ;; If all but the last are NIL the type of the last arg + ;; can be used + ((csubtypep lvar-type null-type)) + (all-nil + (setf all-nil nil))) + finally + (return + (cond (all-nil + last) + ((csubtypep last cons-type) + cons-type) + ((csubtypep last list-type) + list-type) + ;; If the last is SEQUENCE (or similar) it'll + ;; be either that sequence or a cons, which is a + ;; sequence + ((csubtypep list-type last) + last))))))))) + +(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 +234,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 +313,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 +430,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 +457,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 +550,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 +576,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 +628,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 +880,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 +959,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 +990,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 +1072,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 +2428,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 +2439,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 +2486,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 +2779,88 @@ (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) (sb!vm:signed-word (integer * 0))) + "Convert ASH of signed word to %ASH/RIGHT" + (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) (word (integer * 0))) + "Convert ASH of word to %ASH/RIGHT" + (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 @@ -3033,37 +2926,80 @@ (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)) - (unless (eql modular-fun :good) - (setq did-something 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)))) - (when did-something - (reoptimize-node node name)) - did-something))))) + (when (block-delete-p (node-block node)) + (return-from cut-node)) + (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)))) + (unless (= constant-value new-value) + (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) + t))) + (lambda-var + (binding* ((dest (lvar-dest lvar) :exit-if-null) + (nil (combination-p dest) :exit-if-null) + (name (lvar-fun-name (combination-fun dest)))) + ;; we're about to insert an m-s-f/logand between a ref to + ;; a variable and another m-s-f/logand. No point in doing + ;; that; the parent m-s-f/logand was already cut to width + ;; anyway. + (unless (or (cond (signedp + (and (eql name 'mask-signed-field) + (eql lvar (second + (combination-args + dest))))) + (t + (eql name 'logand))) + (csubtypep (lvar-type lvar) type)) + (filter-lvar lvar + (if signedp + `(mask-signed-field ,width 'dummy) + `(logand 'dummy ,(ldb (byte width 0) -1)))) + (setf (block-reoptimize (node-block node)) t) + (reoptimize-component (node-component node) :maybe) + 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))) + (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)) + (unless (eql modular-fun :good) + (setq did-something 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)))) + (when did-something + (reoptimize-node node name)) + did-something))))))) (cut-lvar (lvar &aux did-something) (do-uses (node lvar) (when (cut-node node) @@ -3108,9 +3044,23 @@ (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. + ;; + ;; 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) @@ -3121,10 +3071,11 @@ (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) + (best-modular-version (1+ width) t) (when w - ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T). - (cut-to-width x kind width t) + ;; 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. )))))))) @@ -3135,11 +3086,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")) @@ -3186,6 +3137,15 @@ `(- (ash x ,len)) `(ash x ,len)))) +;;; These must come before the ones below, so that they are tried +;;; first. Since %FLOOR and %CEILING are inlined, this allows +;;; the general case to be handled by TRUNCATE transforms. +(deftransform floor ((x y)) + `(%floor x y)) + +(deftransform ceiling ((x y)) + `(%ceiling x y)) + ;;; If arg is a constant power of two, turn FLOOR into a shift and ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a ;;; remainder. @@ -3271,17 +3231,25 @@ ;;; Y must neither be zero nor a power of two. The quotient is rounded ;;; towards zero. ;;; The algorithm is taken from the paper "Division by Invariant -;;; Integers using Multiplication", 1994 by Torbjörn Granlund and Peter -;;; L. Montgomery, Figures 4.2 and 6.2, modified to exclude the case of -;;; division by powers of two. +;;; 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) @@ -3290,8 +3258,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 @@ -3309,24 +3278,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 @@ -3337,39 +3314,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 @@ -3405,6 +3366,60 @@ (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 x ',(,folded y (lvar-value z)))))))) + (def logand) + (def logior) + (def logxor) + (def logtest :folded logand) + (def + :type rational) + (def * :type rational)) + +(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) *) @@ -3414,6 +3429,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. @@ -3540,6 +3574,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 @@ -3638,10 +3690,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) @@ -3825,7 +3877,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)) @@ -4002,57 +4054,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 ;;;; @@ -4498,3 +4658,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)))))