X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=9c832e3953e4e05526205fcb8f1cb7f309c2d22b;hb=095564c28a259002c7e34fd1d861f5bbd0a959b6;hp=869f6842cd2aea287da93aeacb3f3ac667aa22ff;hpb=2f3c0044ba37b2b33ab60b283e4612aa1ba643eb;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 869f684..9c832e3 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1620,6 +1620,13 @@ #'%unary-truncate-derive-type-aux #'%unary-truncate)) +(defoptimizer (%unary-ftruncate derive-type) ((number)) + (let ((divisor (specifier-type '(integer 1 1)))) + (one-arg-derive-type number + #'(lambda (n) + (ftruncate-derive-type-quot-aux n divisor nil)) + #'%unary-ftruncate))) + ;;; Define optimizers for FLOOR and CEILING. (macrolet ((def (name q-name r-name) @@ -2129,14 +2136,18 @@ (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) + (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 ((or (null x-len) (null y-len)) + (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 (specifier-type `(unsigned-byte* ,(min x-len y-len))))) ;; X is positive, but Y might be negative. @@ -2211,7 +2222,7 @@ (max x-len y-len) '*)))) ((or (and (not x-pos) (not y-neg)) - (and (not y-neg) (not y-pos))) + (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) @@ -2233,7 +2244,6 @@ (deffrob logior) (deffrob logxor)) -;;; FIXME: could actually do stuff with SAME-LEAF (defoptimizer (logeqv derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) (lognot-derive-type-aux @@ -2249,7 +2259,6 @@ (lognot-derive-type-aux (logior-derive-type-aux x y same-leaf))) #'lognor)) -;;; FIXME: use SAME-LEAF instead of ignoring it. (defoptimizer (logandc1 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) (if same-leaf @@ -2312,7 +2321,29 @@ (specifier-type `(integer ,lo-res ,hi-res)))))) (defoptimizer (code-char derive-type) ((code)) - (specifier-type 'base-char)) + (let ((type (lvar-type code))) + ;; FIXME: unions of integral ranges? It ought to be easier to do + ;; this, given that CHARACTER-SET is basically an integral range + ;; type. -- CSR, 2004-10-04 + (when (numeric-type-p type) + (let* ((lo (numeric-type-low type)) + (hi (numeric-type-high type)) + (type (specifier-type `(character-set ((,lo . ,hi)))))) + (cond + ;; KLUDGE: when running on the host, we lose a slight amount + ;; of precision so that we don't have to "unparse" types + ;; that formally we can't, such as (CHARACTER-SET ((0 + ;; . 0))). -- CSR, 2004-10-06 + #+sb-xc-host + ((csubtypep type (specifier-type 'standard-char)) type) + #+sb-xc-host + ((csubtypep type (specifier-type 'base-char)) + (specifier-type 'base-char)) + #+sb-xc-host + ((csubtypep type (specifier-type 'extended-char)) + (specifier-type 'extended-char)) + (t #+sb-xc-host (specifier-type 'character) + #-sb-xc-host type)))))) (defoptimizer (values derive-type) ((&rest values)) (make-values-type :required (mapcar #'lvar-type values))) @@ -2658,7 +2689,7 @@ (let* ((y (lvar-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) + (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (if (minusp y) `(- (ash x ,len)) @@ -2673,7 +2704,7 @@ (let* ((y (lvar-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) + (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (let ((shift (- len)) (mask (1- y-abs)) @@ -2699,7 +2730,7 @@ (let* ((y (lvar-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) + (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (let ((mask (1- y-abs))) (if (minusp y) @@ -2714,7 +2745,7 @@ (let* ((y (lvar-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) + (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (let* ((shift (- len)) (mask (1- y-abs))) @@ -2736,7 +2767,7 @@ (let* ((y (lvar-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) + (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (let ((mask (1- y-abs))) `(if (minusp x) @@ -2916,21 +2947,31 @@ (or (zerop sum) (when (eql sum #x20) (let ((sum (+ ac bc))) - (and (> sum 161) (< sum 213))))))) + (or (and (> sum 161) (< sum 213)) + (and (> sum 415) (< sum 461)) + (and (> sum 463) (< sum 477)))))))) (deftransform char-upcase ((x) (base-char)) "open code" '(let ((n-code (char-code x))) - (if (and (> n-code #o140) ; Octal 141 is #\a. - (< n-code #o173)) ; Octal 172 is #\z. + (if (or (and (> n-code #o140) ; Octal 141 is #\a. + (< n-code #o173)) ; Octal 172 is #\z. + (and (> n-code #o337) + (< n-code #o367)) + (and (> n-code #o367) + (< n-code #o377))) (code-char (logxor #x20 n-code)) x))) (deftransform char-downcase ((x) (base-char)) "open code" '(let ((n-code (char-code x))) - (if (and (> n-code 64) ; 65 is #\A. - (< n-code 91)) ; 90 is #\Z. + (if (or (and (> n-code 64) ; 65 is #\A. + (< n-code 91)) ; 90 is #\Z. + (and (> n-code 191) + (< n-code 215)) + (and (> n-code 215) + (< n-code 223))) (code-char (logxor #x20 n-code)) x))) @@ -2953,21 +2994,18 @@ ;;; then the result is definitely false. (deftransform simple-equality-transform ((x y) * * :defun-only t) - (cond ((same-leaf-ref-p x y) - t) - ((not (types-equal-or-intersect (lvar-type x) - (lvar-type y))) + (cond + ((same-leaf-ref-p x y) t) + ((not (types-equal-or-intersect (lvar-type x) (lvar-type y))) nil) - (t - (give-up-ir1-transform)))) + (t (give-up-ir1-transform)))) (macrolet ((def (x) `(%deftransform ',x '(function * *) #'simple-equality-transform))) (def eq) - (def char=) - (def equal)) + (def char=)) -;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also +;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also ;;; try to convert to a type-specific predicate or EQ: ;;; -- If both args are characters, convert to CHAR=. This is better than ;;; just converting to EQ, since CHAR= may have special compilation @@ -2986,8 +3024,8 @@ (y-type (lvar-type y)) (char-type (specifier-type 'character)) (number-type (specifier-type 'number))) - (cond ((same-leaf-ref-p x y) - t) + (cond + ((same-leaf-ref-p x y) t) ((not (types-equal-or-intersect x-type y-type)) nil) ((and (csubtypep x-type char-type) @@ -3004,6 +3042,25 @@ (t (give-up-ir1-transform))))) +;;; similarly to the EQL transform above, we attempt to constant-fold +;;; or convert to a simpler predicate: mostly we have to be careful +;;; with strings. +(deftransform equal ((x y) * *) + "convert to simpler equality predicate" + (let ((x-type (lvar-type x)) + (y-type (lvar-type y)) + (string-type (specifier-type 'string))) + (cond + ((same-leaf-ref-p x y) t) + ((and (csubtypep x-type string-type) + (csubtypep y-type string-type)) + '(string= x y)) + ((and (or (not (types-equal-or-intersect x-type string-type)) + (not (types-equal-or-intersect y-type string-type))) + (not (types-equal-or-intersect x-type y-type))) + nil) + (t (give-up-ir1-transform))))) + ;;; Convert to EQL if both args are rational and complexp is specified ;;; and the same for both. (deftransform = ((x y) * *)