(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)
(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
-(define-source-transform last (x) `(sb!impl::last1 ,x))
+(deftransform last ((list &optional n) (t &optional t))
+ (let ((c (constant-lvar-p n)))
+ (cond ((or (not n)
+ (and c (eql 1 (lvar-value n))))
+ '(%last1 list))
+ ((and c (eql 0 (lvar-value n)))
+ '(%last0 list))
+ (t
+ (let ((type (lvar-type n)))
+ (cond ((csubtypep type (specifier-type 'fixnum))
+ '(%lastn/fixnum list n))
+ ((csubtypep type (specifier-type 'bignum))
+ '(%lastn/bignum list n))
+ (t
+ (give-up-ir1-transform "second argument type too vague"))))))))
+
(define-source-transform gethash (&rest args)
(case (length args)
(2 `(sb!impl::gethash3 ,@args nil))
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 <int> <single>)
+ ;; and
+ ;; (some-op (coerce <int> 'single-float) <single>)
+ ;;
+ ;; or other equivalent transformed forms. The problem with this is that
+ ;; on some platforms like x86 (+ <int> <single>) is on the machine level
+ ;; equivalent of
+ ;;
+ ;; (coerce (+ (coerce <int> 'double-float)
+ ;; (coerce <single> 'double-float))
+ ;; 'single-float)
+ ;;
+ ;; so if the result of (coerce <int> '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.
(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
(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
#'%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
(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)
(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
(ecase signedp
((nil) (let ((mask (1- (ash 1 width))))
`(integer ,mask ,mask)))
- (t `(signed-byte ,width))))))
+ ((t) `(signed-byte ,width))))))
(lambda (call)
(let ((res (funcall fun call)))
(when res
(ecase signedp
((nil) (let ((mask (1- (ash 1 width))))
`(integer ,mask ,mask)))
- (t `(signed-byte ,width))))))
+ ((t) `(signed-byte ,width))))))
(if (eq signedp nil)
(logand-derive-type-aux res mask-type)))))
'(eql 0)
`(,(ecase signedp
((nil) 'unsigned-byte)
- (t 'signed-byte))
+ ((t) 'signed-byte))
,width)))))
(labels ((reoptimize-node (node name)
(setf (node-derived-type node)
(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)))
((= 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
(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
(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))
;;; 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))))
(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))
(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:
;; 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
(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
(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))
projects / sbcl.git / blobdiff