X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=709b1d6c24e8a0260c6578c32bf4df737752ebc9;hb=e0a4fab15834525fd043e6ef5adfd74a13af1450;hp=620ab2acb54301bcf86328544d834d2792f959d8;hpb=4d9ce212ecdef5af8356873b56f88c72c4ed113d;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 620ab2a..709b1d6 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -114,6 +114,20 @@ (define-source-transform ninth (x) `(nth 8 ,x)) (define-source-transform tenth (x) `(nth 9 ,x)) +;;; LIST with one arg is an extremely common operation (at least inside +;;; SBCL itself); translate it to CONS to take advantage of common +;;; allocation routines. +(define-source-transform list (&rest args) + (case (length args) + (1 `(cons ,(first args) nil)) + (t (values nil t)))) + +;;; And similarly for LIST*. +(define-source-transform list* (&rest args) + (case (length args) + (2 `(cons ,(first args) ,(second args))) + (t (values nil t)))) + ;;; Translate RPLACx to LET and SETF. (define-source-transform rplaca (x y) (once-only ((n-x x)) @@ -129,11 +143,16 @@ (define-source-transform nth (n l) `(car (nthcdr ,n ,l))) (define-source-transform last (x) `(sb!impl::last1 ,x)) -;; (define-source-transform last (x) -;; `(let* ((x (the list ,x)) -;; (r (cdr x))) -;; (do () ((atom r) x) -;; (shiftf x r (cdr r))))) +(define-source-transform gethash (&rest args) + (case (length args) + (2 `(sb!impl::gethash2 ,@args)) + (3 `(sb!impl::gethash3 ,@args)) + (t (values nil t)))) +(define-source-transform get (&rest args) + (case (length args) + (2 `(sb!impl::get2 ,@args)) + (3 `(sb!impl::get3 ,@args)) + (t (values nil t)))) (defvar *default-nthcdr-open-code-limit* 6) (defvar *extreme-nthcdr-open-code-limit* 20) @@ -164,8 +183,8 @@ (define-source-transform 1+ (x) `(+ ,x 1)) (define-source-transform 1- (x) `(- ,x 1)) -(define-source-transform oddp (x) `(not (zerop (logand ,x 1)))) -(define-source-transform evenp (x) `(zerop (logand ,x 1))) +(define-source-transform oddp (x) `(logtest ,x 1)) +(define-source-transform evenp (x) `(not (logtest ,x 1))) ;;; Note that all the integer division functions are available for ;;; inline expansion. @@ -183,7 +202,12 @@ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (deffrob ceiling)) -(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y)))) +;;; This used to be a source transform (hence the lack of restrictions +;;; 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)))) (deftransform logbitp ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits) @@ -296,20 +320,75 @@ (if (and (floatp y) (float-infinity-p y)) nil - (set-bound (funcall f (type-bound-number x)) (consp x))))))) + (set-bound y (consp x))))))) ;;; 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 ;;; is open if either X or Y is open. ;;; ;;; FIXME: only used in this file, not needed in target runtime + +;;; ANSI contaigon specifies coercion to floating point if one of the +;;; arguments is floating point. Here we should check to be sure that +;;; the other argument is within the bounds of that floating point +;;; type. + +(defmacro safely-binop (op x y) + `(cond + ((typep ,x 'single-float) + (if (or (typep ,y 'single-float) + (<= most-negative-single-float ,y most-positive-single-float)) + (,op ,x ,y))) + ((typep ,x 'double-float) + (if (or (typep ,y 'double-float) + (<= most-negative-double-float ,y most-positive-double-float)) + (,op ,x ,y))) + ((typep ,y 'single-float) + (if (<= most-negative-single-float ,x most-positive-single-float) + (,op ,x ,y))) + ((typep ,y 'double-float) + (if (<= most-negative-double-float ,x most-positive-double-float) + (,op ,x ,y))) + (t (,op ,x ,y)))) + (defmacro bound-binop (op x y) `(and ,x ,y (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - (set-bound (,op (type-bound-number ,x) - (type-bound-number ,y)) + (set-bound (safely-binop ,op (type-bound-number ,x) + (type-bound-number ,y)) (or (consp ,x) (consp ,y)))))) +(defun coerce-for-bound (val type) + (if (consp val) + (list (coerce-for-bound (car val) type)) + (cond + ((subtypep type 'double-float) + (if (<= most-negative-double-float val most-positive-double-float) + (coerce val type))) + ((or (subtypep type 'single-float) (subtypep type 'float)) + ;; coerce to float returns a single-float + (if (<= most-negative-single-float val most-positive-single-float) + (coerce val type))) + (t (coerce val type))))) + +(defun coerce-and-truncate-floats (val type) + (when val + (if (consp val) + (list (coerce-and-truncate-floats (car val) type)) + (cond + ((subtypep type 'double-float) + (if (<= most-negative-double-float val most-positive-double-float) + (coerce val type) + (if (< val most-negative-double-float) + most-negative-double-float most-positive-double-float))) + ((or (subtypep type 'single-float) (subtypep type 'float)) + ;; coerce to float returns a single-float + (if (<= most-negative-single-float val most-positive-single-float) + (coerce val type) + (if (< val most-negative-single-float) + most-negative-single-float most-positive-single-float))) + (t (coerce val type)))))) + ;;; Convert a numeric-type object to an interval object. (defun numeric-type->interval (x) (declare (type numeric-type x)) @@ -432,15 +511,13 @@ ;;; 1] and Y = [1, 2] to determine intersection. (defun interval-intersect-p (x y &optional closed-intervals-p) (declare (type interval x y)) - (multiple-value-bind (intersect diff) - (interval-intersection/difference (if closed-intervals-p - (interval-closure x) - x) - (if closed-intervals-p - (interval-closure y) - y)) - (declare (ignore diff)) - intersect)) + (and (interval-intersection/difference (if closed-intervals-p + (interval-closure x) + x) + (if closed-intervals-p + (interval-closure y) + y)) + t)) ;;; Are the two intervals adjacent? That is, is there a number ;;; between the two intervals that is not an element of either @@ -484,27 +561,44 @@ (if (listp p) (first p) (list p))) - (test-number (p int) + (test-number (p int bound) ;; Test whether P is in the interval. - (when (interval-contains-p (type-bound-number p) - (interval-closure int)) - (let ((lo (interval-low int)) - (hi (interval-high int))) + (let ((pn (type-bound-number p))) + (when (interval-contains-p pn (interval-closure int)) ;; Check for endpoints. - (cond ((and lo (= (type-bound-number p) (type-bound-number lo))) - (not (and (consp p) (numberp lo)))) - ((and hi (= (type-bound-number p) (type-bound-number hi))) - (not (and (numberp p) (consp hi)))) - (t t))))) + (let* ((lo (interval-low int)) + (hi (interval-high int)) + (lon (type-bound-number lo)) + (hin (type-bound-number hi))) + (cond + ;; Interval may be a point. + ((and lon hin (= lon hin pn)) + (and (numberp p) (numberp lo) (numberp hi))) + ;; Point matches the low end. + ;; [P] [P,?} => TRUE [P] (P,?} => FALSE + ;; (P [P,?} => TRUE P) [P,?} => FALSE + ;; (P (P,?} => TRUE P) (P,?} => FALSE + ((and lon (= pn lon)) + (or (and (numberp p) (numberp lo)) + (and (consp p) (eq :low bound)))) + ;; [P] {?,P] => TRUE [P] {?,P) => FALSE + ;; P) {?,P] => TRUE (P {?,P] => FALSE + ;; P) {?,P) => TRUE (P {?,P) => FALSE + ((and hin (= pn hin)) + (or (and (numberp p) (numberp hi)) + (and (consp p) (eq :high bound)))) + ;; Not an endpoint, all is well. + (t + t)))))) (test-lower-bound (p int) ;; P is a lower bound of an interval. (if p - (test-number p int) + (test-number p int :low) (not (interval-bounded-p int 'below)))) (test-upper-bound (p int) ;; P is an upper bound of an interval. (if p - (test-number p int) + (test-number p int :high) (not (interval-bounded-p int 'above))))) (let ((x-lo-in-y (test-lower-bound x-lo y)) (x-hi-in-y (test-upper-bound x-hi y)) @@ -608,8 +702,9 @@ ;; Multiply by closed zero is special. The result ;; is always a closed bound. But don't replace this ;; with zero; we want the multiplication to produce - ;; the correct signed zero, if needed. - (* (type-bound-number x) (type-bound-number y))) + ;; the correct signed zero, if needed. Use SIGNUM + ;; to avoid trying to multiply huge bignums with 0.0. + (* (signum (type-bound-number x)) (signum (type-bound-number y)))) ((or (and (floatp x) (float-infinity-p x)) (and (floatp y) (float-infinity-p y))) ;; Infinity times anything is infinity @@ -737,6 +832,24 @@ (>= (type-bound-number (interval-low x)) (type-bound-number (interval-high y))))) +;;; Return T if X = Y. +(defun interval-= (x y) + (declare (type interval x y)) + (and (interval-bounded-p x 'both) + (interval-bounded-p y 'both) + (flet ((bound (v) + (if (numberp v) + v + ;; Open intervals cannot be = + (return-from interval-= nil)))) + ;; Both intervals refer to the same point + (= (bound (interval-high x)) (bound (interval-low x)) + (bound (interval-high y)) (bound (interval-low y)))))) + +;;; Return T if X /= Y +(defun interval-/= (x y) + (not (interval-intersect-p x y))) + ;;; Return an interval that is the absolute value of X. Thus, if ;;; X = [-1 10], the result is [0, 10]. (defun interval-abs (x) @@ -1202,8 +1315,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) @@ -1235,8 +1348,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) @@ -1268,8 +1381,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) @@ -1304,8 +1417,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (numeric-type-class result-type) :format (numeric-type-format result-type) @@ -1448,8 +1561,8 @@ :class class :format format :complexp :real - :low (coerce-numeric-bound (interval-low abs-bnd) bound-type) - :high (coerce-numeric-bound + :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type) + :high (coerce-and-truncate-floats (interval-high abs-bnd) bound-type)))))) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) @@ -1563,7 +1676,7 @@ (when (member rem-type '(float single-float double-float #!+long-float long-float)) (setf rem (interval-func #'(lambda (x) - (coerce x rem-type)) + (coerce-for-bound x rem-type)) rem))) (make-numeric-type :class class :format format @@ -1673,7 +1786,7 @@ ;; Make sure that the limits on the interval have ;; the right type. (setf rem (interval-func (lambda (x) - (coerce x result-type)) + (coerce-for-bound x result-type)) rem))) (make-numeric-type :class class :format format @@ -3207,15 +3320,17 @@ ;;; -- If both args are characters, convert to CHAR=. This is better than ;;; just converting to EQ, since CHAR= may have special compilation ;;; strategies for non-standard representations, etc. -;;; -- If either arg is definitely a fixnum we punt and let the backend -;;; deal with it. +;;; -- If either arg is definitely a fixnum, we check to see if X is +;;; constant and if so, put X second. Doing this results in better +;;; code from the backend, since the backend assumes that any constant +;;; argument comes second. ;;; -- If either arg is definitely not a number or a fixnum, then we ;;; can compare with EQ. ;;; -- Otherwise, we try to put the arg we know more about second. If X ;;; is constant then we put it second. If X is a subtype of Y, we put ;;; it second. These rules make it easier for the back end to match ;;; these interesting cases. -(deftransform eql ((x y) * *) +(deftransform eql ((x y) * * :node node) "convert to simpler equality predicate" (let ((x-type (lvar-type x)) (y-type (lvar-type y)) @@ -3232,7 +3347,7 @@ (csubtypep y-type char-type)) '(char= x y)) ((or (fixnum-type-p x-type) (fixnum-type-p y-type)) - (give-up-ir1-transform)) + (commutative-arg-swap node)) ((or (simple-type-p x-type) (simple-type-p y-type)) '(eq x y)) ((and (not (constant-lvar-p y)) @@ -3272,41 +3387,48 @@ ;;; Convert to EQL if both args are rational and complexp is specified ;;; and the same for both. -(deftransform = ((x y) * *) +(deftransform = ((x y) (number number) *) "open code" (let ((x-type (lvar-type x)) (y-type (lvar-type y))) - (if (and (csubtypep x-type (specifier-type 'number)) - (csubtypep y-type (specifier-type 'number))) - (cond ((or (and (csubtypep x-type (specifier-type 'float)) - (csubtypep y-type (specifier-type 'float))) - (and (csubtypep x-type (specifier-type '(complex float))) - (csubtypep y-type (specifier-type '(complex float))))) - ;; They are both floats. Leave as = so that -0.0 is - ;; handled correctly. - (give-up-ir1-transform)) - ((or (and (csubtypep x-type (specifier-type 'rational)) - (csubtypep y-type (specifier-type 'rational))) - (and (csubtypep x-type - (specifier-type '(complex rational))) - (csubtypep y-type - (specifier-type '(complex rational))))) - ;; They are both rationals and complexp is the same. - ;; Convert to EQL. - '(eql x y)) - (t - (give-up-ir1-transform - "The operands might not be the same type."))) - (give-up-ir1-transform - "The operands might not be the same type.")))) - -;;; If LVAR's type is a numeric type, then return the type, otherwise -;;; GIVE-UP-IR1-TRANSFORM. -(defun numeric-type-or-lose (lvar) - (declare (type lvar lvar)) - (let ((res (lvar-type lvar))) - (unless (numeric-type-p res) (give-up-ir1-transform)) - res)) + (cond ((or (and (csubtypep x-type (specifier-type 'float)) + (csubtypep y-type (specifier-type 'float))) + (and (csubtypep x-type (specifier-type '(complex float))) + (csubtypep y-type (specifier-type '(complex float))))) + ;; They are both floats. Leave as = so that -0.0 is + ;; handled correctly. + (give-up-ir1-transform)) + ((or (and (csubtypep x-type (specifier-type 'rational)) + (csubtypep y-type (specifier-type 'rational))) + (and (csubtypep x-type + (specifier-type '(complex rational))) + (csubtypep y-type + (specifier-type '(complex rational))))) + ;; They are both rationals and complexp is the same. + ;; Convert to EQL. + '(eql x y)) + (t + (give-up-ir1-transform + "The operands might not be the same type."))))) + +(defun maybe-float-lvar-p (lvar) + (neq *empty-type* (type-intersection (specifier-type 'float) + (lvar-type lvar)))) + +(flet ((maybe-invert (node op inverted x y) + ;; Don't invert if either argument can be a float (NaNs) + (cond + ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y)) + (delay-ir1-transform node :constraint) + `(or (,op x y) (= x y))) + (t + `(if (,inverted x y) nil t))))) + (deftransform >= ((x y) (number number) * :node node) + "invert or open code" + (maybe-invert node '> '< x y)) + (deftransform <= ((x y) (number number) * :node node) + "invert or open code" + (maybe-invert node '< '> x y))) ;;; See whether we can statically determine (< X Y) using type ;;; information. If X's high bound is < Y's low, then X < Y. @@ -3314,7 +3436,14 @@ ;;; NIL). If not, at least make sure any constant arg is second. (macrolet ((def (name inverse reflexive-p surely-true surely-false) `(deftransform ,name ((x y)) - (if (same-leaf-ref-p x y) + "optimize using intervals" + (if (and (same-leaf-ref-p x y) + ;; For non-reflexive functions we don't need + ;; to worry about NaNs: (non-ref-op NaN NaN) => false, + ;; but with reflexive ones we don't know... + ,@(when reflexive-p + '((and (not (maybe-float-lvar-p x)) + (not (maybe-float-lvar-p y)))))) ,reflexive-p (let ((ix (or (type-approximate-interval (lvar-type x)) (give-up-ir1-transform))) @@ -3329,6 +3458,8 @@ `(,',inverse y x)) (t (give-up-ir1-transform)))))))) + (def = = t (interval-= ix iy) (interval-/= ix iy)) + (def /= /= nil (interval-/= ix iy) (interval-= ix iy)) (def < > nil (interval-< ix iy) (interval->= ix iy)) (def > < nil (interval-< iy ix) (interval->= iy ix)) (def <= >= t (interval->= iy ix) (interval-< iy ix)) @@ -3367,15 +3498,16 @@ ;;; negated test as appropriate. If it is a degenerate one-arg call, ;;; then we transform to code that returns true. Otherwise, we bind ;;; all the arguments and expand into a bunch of IFs. -(declaim (ftype (function (symbol list boolean t) *) multi-compare)) -(defun multi-compare (predicate args not-p type) +(defun multi-compare (predicate args not-p type &optional force-two-arg-p) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) ((= nargs 1) `(progn (the ,type ,@args) t)) ((= nargs 2) (if not-p `(if (,predicate ,(first args) ,(second args)) nil t) - (values nil t))) + (if force-two-arg-p + `(,predicate ,(first args) ,(second args)) + (values nil t)))) (t (do* ((i (1- nargs) (1- i)) (last nil current) @@ -3393,8 +3525,13 @@ (define-source-transform = (&rest args) (multi-compare '= args nil 'number)) (define-source-transform < (&rest args) (multi-compare '< args nil 'real)) (define-source-transform > (&rest args) (multi-compare '> args nil 'real)) -(define-source-transform <= (&rest args) (multi-compare '> args t 'real)) -(define-source-transform >= (&rest args) (multi-compare '< args t '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 +;;; 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)) +(define-source-transform >= (&rest args) (multi-compare '>= args nil 'real)) (define-source-transform char= (&rest args) (multi-compare 'char= args nil 'character)) @@ -3408,15 +3545,15 @@ 'character)) (define-source-transform char-equal (&rest args) - (multi-compare 'char-equal args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t)) (define-source-transform char-lessp (&rest args) - (multi-compare 'char-lessp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t)) (define-source-transform char-greaterp (&rest args) - (multi-compare 'char-greaterp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t)) (define-source-transform char-not-greaterp (&rest args) - (multi-compare 'char-greaterp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t)) (define-source-transform char-not-lessp (&rest args) - (multi-compare 'char-lessp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t)) ;;; This function does source transformation of N-arg inequality ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3 @@ -3599,6 +3736,10 @@ (when (stringp x) (check-format-args x args 'format))))) +;;; We disable this transform in the cross-compiler to save memory in +;;; the target image; most of the uses of FORMAT in the compiler are for +;;; error messages, and those don't need to be particularly fast. +#+sb-xc (deftransform format ((dest control &rest args) (t simple-string &rest t) * :policy (> speed space)) (unless (constant-lvar-p control) @@ -3623,6 +3764,12 @@ (funcall control *standard-output* ,@arg-names) nil))) +(deftransform pathname ((pathspec) (pathname) *) + 'pathspec) + +(deftransform pathname ((pathspec) (string) *) + '(values (parse-namestring pathspec))) + (macrolet ((def (name) `(defoptimizer (,name optimizer) ((control &rest args)) @@ -3635,7 +3782,6 @@ #+sb-xc-host ; Only we should be using these (progn (def style-warn) - (def compiler-abort) (def compiler-error) (def compiler-warn) (def compiler-style-warn) @@ -3970,3 +4116,16 @@ (give-up-ir1-transform "not a real transform")) (defun /report-lvar (x message) (declare (ignore x message)))) + + +;;;; Transforms for internal compiler utilities + +;;; If QUALITY-NAME is constant and a valid name, don't bother +;;; checking that it's still valid at run-time. +(deftransform policy-quality ((policy quality-name) + (t symbol)) + (unless (and (constant-lvar-p quality-name) + (policy-quality-name-p (lvar-value quality-name))) + (give-up-ir1-transform)) + '(%policy-quality policy quality-name)) +