X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=7421fd7455456c4f62bf1fd4d1d8c1407e76cb18;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=37c3a73e627a212f83f5b3b5add71561e37fbcf0;hpb=4413876742e64de8a5925c98d1925ba9e5f75d8d;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 37c3a73..7421fd7 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -123,10 +123,15 @@ (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)))) +(define-source-transform list* (arg &rest others) + (cond ((not others) arg) + ((not (cdr others)) `(cons ,arg ,(car others))) + (t (values nil t)))) + +(defoptimizer (list* derive-type) ((arg &rest args)) + (if args + (specifier-type 'cons) + (lvar-type arg))) ;;; Translate RPLACx to LET and SETF. (define-source-transform rplaca (x y) @@ -337,6 +342,37 @@ nil (set-bound y (consp x))))))) +(defun safe-double-coercion-p (x) + (or (typep x 'double-float) + (<= most-negative-double-float x most-positive-double-float))) + +(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)))) + ;;; 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. @@ -350,21 +386,19 @@ (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)))) + ((typep ,x 'double-float) + (when (safe-double-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'double-float) + (when (safe-double-coercion-p ,x) + (,op ,x ,y))) + ((typep ,x 'single-float) + (when (safe-single-coercion-p ,y) + (,op ,x ,y))) + ((typep ,y 'single-float) + (when (safe-single-coercion-p ,x) + (,op ,x ,y))) + (t (,op ,x ,y)))) (defmacro bound-binop (op x y) `(and ,x ,y @@ -1062,7 +1096,7 @@ (t ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0))) ;; (float x -0.0) => (or (member -0.0) (float x (0.0))) - (list (make-member-type :members (list (float -0.0 hi-val))) + (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))) (make-numeric-type :class (numeric-type-class type) :format (numeric-type-format type) :complexp :real @@ -2582,6 +2616,27 @@ (hi-res (if hi (isqrt hi) '*))) (specifier-type `(integer ,lo-res ,hi-res)))))) +(defoptimizer (char-code derive-type) ((char)) + (let ((type (type-intersection (lvar-type char) (specifier-type 'character)))) + (cond ((member-type-p type) + (specifier-type + `(member + ,@(loop for member in (member-type-members type) + when (characterp member) + collect (char-code member))))) + ((sb!kernel::character-set-type-p type) + (specifier-type + `(or + ,@(loop for (low . high) + in (character-set-type-pairs type) + collect `(integer ,low ,high))))) + ((csubtypep type (specifier-type 'base-char)) + (specifier-type + `(mod ,base-char-code-limit))) + (t + (specifier-type + `(mod ,char-code-limit)))))) + (defoptimizer (code-char derive-type) ((code)) (let ((type (lvar-type code))) ;; FIXME: unions of integral ranges? It ought to be easier to do @@ -3197,41 +3252,32 @@ (values (type= (numeric-contagion x y) (numeric-contagion y y))))))) +(def!type exact-number () + '(or rational (complex rational))) + ;;; Fold (+ x 0). ;;; -;;; If y is not constant, not zerop, or is contagious, or a positive -;;; float +0.0 then give up. -(deftransform + ((x y) (t (constant-arg t)) *) +;;; Only safely applicable for exact numbers. For floating-point +;;; x, one would have to first show that neither x or y are signed +;;; 0s, and that x isn't an SNaN. +(deftransform + ((x y) (exact-number (constant-arg (eql 0))) *) "fold zero arg" - (let ((val (lvar-value y))) - (unless (and (zerop val) - (not (and (floatp val) (plusp (float-sign val)))) - (not-more-contagious y x)) - (give-up-ir1-transform))) 'x) ;;; Fold (- x 0). -;;; -;;; If y is not constant, not zerop, or is contagious, or a negative -;;; float -0.0 then give up. -(deftransform - ((x y) (t (constant-arg t)) *) +(deftransform - ((x y) (exact-number (constant-arg (eql 0))) *) "fold zero arg" - (let ((val (lvar-value y))) - (unless (and (zerop val) - (not (and (floatp val) (minusp (float-sign val)))) - (not-more-contagious y x)) - (give-up-ir1-transform))) 'x) ;;; Fold (OP x +/-1) -(macrolet ((def (name result minus-result) - `(deftransform ,name ((x y) (t (constant-arg real)) *) - "fold identity operations" - (let ((val (lvar-value y))) - (unless (and (= (abs val) 1) - (not-more-contagious y x)) - (give-up-ir1-transform)) - (if (minusp val) ',minus-result ',result))))) +;;; +;;; %NEGATE might not always signal correctly. +(macrolet + ((def (name result minus-result) + `(deftransform ,name ((x y) + (exact-number (constant-arg (member 1 -1)))) + "fold identity operations" + (if (minusp (lvar-value y)) ',minus-result ',result)))) (def * x (%negate x)) (def / x (%negate x)) (def expt x (/ 1 x))) @@ -3268,6 +3314,15 @@ ((= val -1/2) '(/ (sqrt x))) (t (give-up-ir1-transform))))) +(deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *) + "recode as an ODDP check" + (let ((val (lvar-value x))) + (if (eql -1 val) + '(- 1 (* 2 (logand 1 y))) + `(if (oddp y) + ,val + ,(abs val))))) + ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these ;;; transformations? ;;; Perhaps we should have to prove that the denominator is nonzero before @@ -3358,10 +3413,6 @@ (def eq) (def char=)) -;;; True if EQL comparisons involving type can be simplified to EQ. -(defun eq-comparable-type-p (type) - (csubtypep type (specifier-type '(or fixnum (not number))))) - ;;; 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 @@ -3439,7 +3490,13 @@ (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))))) + (csubtypep y-type (specifier-type '(complex float)))) + #!+complex-float-vops + (and (csubtypep x-type (specifier-type '(or single-float (complex single-float)))) + (csubtypep y-type (specifier-type '(or single-float (complex single-float))))) + #!+complex-float-vops + (and (csubtypep x-type (specifier-type '(or double-float (complex double-float)))) + (csubtypep y-type (specifier-type '(or double-float (complex double-float)))))) ;; They are both floats. Leave as = so that -0.0 is ;; handled correctly. (give-up-ir1-transform)) @@ -3786,7 +3843,7 @@ ;;; 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)) + :policy (>= speed space)) (unless (constant-lvar-p control) (give-up-ir1-transform "The control string is not a constant.")) (let ((arg-names (make-gensym-list (length args)))) @@ -3794,15 +3851,13 @@ (declare (ignore control)) (format dest (formatter ,(lvar-value control)) ,@arg-names)))) -(deftransform format ((stream control &rest args) (stream function &rest t) * - :policy (> speed space)) +(deftransform format ((stream control &rest args) (stream function &rest t)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (stream control ,@arg-names) (funcall control stream ,@arg-names) nil))) -(deftransform format ((tee control &rest args) ((member t) function &rest t) * - :policy (> speed space)) +(deftransform format ((tee control &rest args) ((member t) function &rest t)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (tee control ,@arg-names) (declare (ignore tee)) @@ -3956,7 +4011,7 @@ (eq (first (second good-cons-type)) 'member)) `(,(second (second good-cons-type)) ,@(unconsify-type (caddr good-cons-type)))))) - (coerceable-p (c-type) + (coerceable-p (part) ;; Can the value be coerced to the given type? Coerce is ;; complicated, so we don't handle every possible case ;; here---just the most common and easiest cases: @@ -3978,13 +4033,14 @@ ;; the requested type, because (by assumption) COMPLEX ;; (and other difficult types like (COMPLEX INTEGER) ;; aren't specialized types. - (let ((coerced-type c-type)) - (or (and (subtypep coerced-type 'float) - (csubtypep value-type (specifier-type 'real))) - (and (subtypep coerced-type - '(or (complex single-float) - (complex double-float))) - (csubtypep value-type (specifier-type 'number)))))) + (let ((coerced-type (careful-specifier-type part))) + (when coerced-type + (or (and (csubtypep coerced-type (specifier-type 'float)) + (csubtypep value-type (specifier-type 'real))) + (and (csubtypep coerced-type + (specifier-type `(or (complex single-float) + (complex double-float)))) + (csubtypep value-type (specifier-type 'number))))))) (process-types (type) ;; FIXME: This needs some work because we should be able ;; to derive the resulting type better than just the @@ -4044,19 +4100,16 @@ (specifier-type (consify element-type))) (t (error "can't understand type ~S~%" element-type)))))) - (cond ((array-type-p array-type) - (get-element-type array-type)) - ((union-type-p array-type) - (apply #'type-union - (mapcar #'get-element-type (union-type-types array-type)))) - (t - *universal-type*))))) + (labels ((recurse (type) + (cond ((array-type-p type) + (get-element-type type)) + ((union-type-p type) + (apply #'type-union + (mapcar #'recurse (union-type-types type)))) + (t + *universal-type*)))) + (recurse array-type))))) -;;; Like CMU CL, we use HEAPSORT. However, other than that, this code -;;; isn't really related to the CMU CL code, since instead of trying -;;; to generalize the CMU CL code to allow START and END values, this -;;; code has been written from scratch following Chapter 7 of -;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. (define-source-transform sb!impl::sort-vector (vector start end predicate key) ;; Like CMU CL, we use HEAPSORT. However, other than that, this code ;; isn't really related to the CMU CL code, since instead of trying @@ -4108,7 +4161,7 @@ (start-1 (1- ,',start)) (current-heap-size (- ,',end ,',start)) (keyfun ,keyfun)) - (declare (type (integer -1 #.(1- most-positive-fixnum)) + (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum)) start-1)) (declare (type index current-heap-size)) (declare (type function keyfun))