X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=e13c30e019e7799ab08cf50a3f42b4620e683ba5;hb=1daa58cfa315fe86634069c941cf54ec8f95623c;hp=16accff9e535c3f8e03fccaf71884d8e1c3d8ae6;hpb=b198954cf7fd7750bfbba91b94b660f2ad891101;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 16accff..e13c30e 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,9 +415,10 @@ (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 (handler-case @@ -359,7 +430,7 @@ (if (and (floatp y) (float-infinity-p y)) nil - (set-bound y (consp x))))) + (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. @@ -464,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) @@ -480,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) @@ -529,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) @@ -781,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) @@ -891,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 @@ -969,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)) @@ -2326,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)) @@ -2337,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. @@ -2384,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)) @@ -2976,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 @@ -3041,42 +2920,121 @@ (setf (node-reoptimize node) t) (setf (block-reoptimize (node-block node)) t) (reoptimize-component (node-component node) :maybe)) + (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) - (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))))) - (cut-lvar (lvar &aux did-something) + "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." + (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))) + (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)) + (values t did-something)))))))) + (cut-lvar (lvar &aux did-something must-insert) + "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. + + (*) 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))) + (multiple-value-bind (handled any-change) + (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))))))) + (when must-insert + (setf did-something (or (insert-lvar-cut lvar) did-something))) did-something)) (cut-lvar lvar)))) @@ -3104,38 +3062,85 @@ (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))) + (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 @@ -3144,11 +3149,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")) @@ -3406,14 +3411,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)) @@ -3424,6 +3432,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) *) @@ -3433,6 +3509,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. @@ -3559,6 +3654,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 @@ -3657,10 +3770,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) @@ -3844,7 +3957,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)) @@ -4021,57 +4134,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 ;;;; @@ -4517,3 +4738,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)))))