X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=50d4d3c2b671498e0a19215fcb7b9e8ccf012edb;hb=dbe82b489260b2ef76e916d0aeaee8b3850f5f52;hp=49616d4dd9e1cc16079f34b4f0e85b0d47494b71;hpb=dc9fb9111cb1b645aaede0d3ec019c0f78200be0;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 49616d4..50d4d3c 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1096,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 @@ -1127,21 +1127,26 @@ (t type-list))) -;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably -;;; belong in the kernel's type logic, invoked always, instead of in -;;; the compiler, invoked only during some type optimizations. (In -;;; fact, as of 0.pre8.100 or so they probably are, under -;;; MAKE-MEMBER-TYPE, so probably this code can be deleted) - ;;; Take a list of types and return a canonical type specifier, ;;; combining any MEMBER types together. If both positive and negative ;;; MEMBER types are present they are converted to a float type. ;;; XXX This would be far simpler if the type-union methods could handle ;;; member/number unions. -(defun make-canonical-union-type (type-list) +;;; +;;; If we're about to generate an overly complex union of numeric types, start +;;; collapse the ranges together. +;;; +;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and +;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic, +;;; invoked always, instead of in the compiler, invoked only during some type +;;; optimizations. +(defvar *derived-numeric-union-complexity-limit* 6) + +(defun make-derived-union-type (type-list) (let ((xset (alloc-xset)) (fp-zeroes '()) - (misc-types '())) + (misc-types '()) + (numeric-type *empty-type*)) (dolist (type type-list) (cond ((member-type-p type) (mapc-member-type-members @@ -1151,11 +1156,19 @@ (pushnew member fp-zeroes)) (add-to-xset member xset))) type)) + ((numeric-type-p type) + (let ((*approximate-numeric-unions* + (when (and (union-type-p numeric-type) + (nthcdr *derived-numeric-union-complexity-limit* + (union-type-types numeric-type))) + t))) + (setf numeric-type (type-union type numeric-type)))) (t (push type misc-types)))) (if (and (xset-empty-p xset) (not fp-zeroes)) - (apply #'type-union misc-types) - (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types)))) + (apply #'type-union numeric-type misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) + numeric-type misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -1220,7 +1233,7 @@ (setf results (append results result)) (push result results)))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes @@ -1293,7 +1306,7 @@ (setf results (append results result)) (push result results)))))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) @@ -1789,6 +1802,16 @@ #'%unary-truncate-derive-type-aux #'%unary-truncate)) +(defoptimizer (%unary-truncate/single-float derive-type) ((number)) + (one-arg-derive-type number + #'%unary-truncate-derive-type-aux + #'%unary-truncate)) + +(defoptimizer (%unary-truncate/double-float derive-type) ((number)) + (one-arg-derive-type number + #'%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 @@ -1796,6 +1819,28 @@ (ftruncate-derive-type-quot-aux n divisor nil)) #'%unary-ftruncate))) +(defoptimizer (%unary-round derive-type) ((number)) + (one-arg-derive-type number + (lambda (n) + (block nil + (unless (numeric-type-real-p n) + (return *empty-type*)) + (let* ((interval (numeric-type->interval n)) + (low (interval-low interval)) + (high (interval-high interval))) + (when (consp low) + (setf low (car low))) + (when (consp high) + (setf high (car high))) + (specifier-type + `(integer ,(if low + (round low) + '*) + ,(if high + (round high) + '*)))))) + #'%unary-round)) + ;;; Define optimizers for FLOOR and CEILING. (macrolet ((def (name q-name r-name) @@ -3252,41 +3297,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))) @@ -3323,6 +3359,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 @@ -3490,7 +3535,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)) @@ -3918,7 +3969,7 @@ :format-arguments (list nargs 'cerror y x (max max1 max2)))))))))))))) -(defoptimizer (coerce derive-type) ((value type)) +(defoptimizer (coerce derive-type) ((value type) node) (cond ((constant-lvar-p type) ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2), @@ -3963,7 +4014,17 @@ (type-union result-typeoid (type-intersection (lvar-type value) (specifier-type 'rational)))))) - (t result-typeoid)))) + ((and (policy node (zerop safety)) + (csubtypep result-typeoid (specifier-type '(array * (*))))) + ;; At zero safety the deftransform for COERCE can elide dimension + ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we + ;; need to simplify the type to drop the dimension information. + (let ((vtype (simplify-vector-type result-typeoid))) + (if vtype + (specifier-type vtype) + result-typeoid))) + (t + result-typeoid)))) (t ;; OK, the result-type argument isn't constant. However, there ;; are common uses where we can still do better than just @@ -4155,7 +4216,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))