`(,',fun ,x 1)))))
(frob truncate)
(frob round)
- #!+sb-propagate-float-type
+ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(frob floor)
- #!+sb-propagate-float-type
+ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(frob ceiling))
(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
;;;; numeric-type has everything we want to know. Reason 2 wins for
;;;; now.
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
;;; The basic interval type. It can handle open and closed intervals.
:high high))
(numeric-contagion x y))))
-#!+(or sb-propagate-float-type sb-propagate-fun-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
;;; simple utility to flatten a list
) ; PROGN
\f
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defoptimizer (+ derive-type) ((x y))
(derive-integer-type
) ; PROGN
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun +-derive-type-aux (x y same-arg)
(if (and (numeric-type-real-p x)
;;; and it's hard to avoid that calculation in here.
#-(and cmu sb-xc-host)
(progn
-#!-sb-propagate-fun-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (ash derive-type) ((n shift))
;; Large resulting bounds are easy to generate but are not
;; particularly useful, so an open outer bound is returned for a
:complexp :real)))))))))
*universal-type*))
-#!+sb-propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
(flet ((ash-outer (n s)
(ash-outer n-high s-high))))))
*universal-type*)))
-#!+sb-propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
) ; PROGN
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(macrolet ((frob (fun)
`#'(lambda (type type2)
(declare (ignore type2))
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int (frob lognot))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int
(lambda (type type2)
(numeric-type-class type)
(numeric-type-format type))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (%negate derive-type) ((num))
(flet ((negate-bound (b)
(and b
:high (negate-bound (numeric-type-low type))))
#'-)))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (abs derive-type) ((num))
(let ((type (continuation-type num)))
(if (and (numeric-type-p type)
nil)))
(numeric-contagion type type))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun abs-derive-type-aux (type)
(cond ((eq (numeric-type-complexp type) :complex)
;; The absolute value of a complex number is always a
:high (coerce-numeric-bound
(interval-high abs-bnd) bound-type))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (abs derive-type) ((num))
(one-arg-derive-type num #'abs-derive-type-aux #'abs))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
divisor-low divisor-high))))
*universal-type*)))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun rem-result-type (number-type divisor-type)
;; anything about the result.
`integer)))))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun integer-rem-derive-type
(number-low number-high divisor-low divisor-high)
(if (and divisor-low divisor-high)
0
'*))))
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (random derive-type) ((bound &optional state))
(let ((type (continuation-type bound)))
(when (numeric-type-p type)
((or (consp high) (zerop high)) high)
(t `(,high))))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun random-derive-type-aux (type)
(let ((class (numeric-type-class type))
(high (numeric-type-high type))
((or (consp high) (zerop high)) high)
(t `(,high))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (random derive-type) ((bound &optional state))
(one-arg-derive-type bound #'random-derive-type-aux nil))
\f
(or (null min) (minusp min))))
(values nil t t)))
-#!-sb-propagate-fun-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defoptimizer (logand derive-type) ((x y))
) ; PROGN
-#!+sb-propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun logand-derive-type-aux (x y &optional same-leaf)
(dolist (x '(= char= + * logior logand logxor))
(%deftransform x '(function * *) #'commutative-arg-swap
- "place constant arg last."))
+ "place constant arg last"))
;;; Handle the case of a constant BOOLE-CODE.
(deftransform boole ((op x y) * * :when :both)
:defun-only t
:when :both)
(cond ((same-leaf-ref-p x y)
- 't)
- ((not (types-intersect (continuation-type x) (continuation-type y)))
- 'nil)
+ t)
+ ((not (types-equal-or-intersect (continuation-type x)
+ (continuation-type y)))
+ nil)
(t
(give-up-ir1-transform))))
(char-type (specifier-type 'character))
(number-type (specifier-type 'number)))
(cond ((same-leaf-ref-p x y)
- 't)
- ((not (types-intersect x-type y-type))
- 'nil)
+ t)
+ ((not (types-equal-or-intersect x-type y-type))
+ nil)
((and (csubtypep x-type char-type)
(csubtypep y-type char-type))
'(char= x y))
- ((or (not (types-intersect x-type number-type))
- (not (types-intersect y-type number-type)))
+ ((or (not (types-equal-or-intersect x-type number-type))
+ (not (types-equal-or-intersect y-type number-type)))
'(eq x y))
((and (not (constant-continuation-p y))
(or (constant-continuation-p x)
;;;
;;; FIXME: Why should constant argument be second? It would be nice to
;;; find out and explain.
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
- 'nil
+ nil
(let* ((x-type (numeric-type-or-lose x))
(x-lo (numeric-type-low x-type))
(x-hi (numeric-type-high x-type))
`(,inverse y x))
(t
(give-up-ir1-transform))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
- 'nil
+ nil
(let ((xi (numeric-type->interval (numeric-type-or-lose x)))
(yi (numeric-type->interval (numeric-type-or-lose y))))
(cond ((interval-< xi yi)
(deftransform > ((x y) (integer integer) * :when :both)
(ir1-transform-< y x x y '<))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deftransform < ((x y) (float float) * :when :both)
(ir1-transform-< x y x y '>))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deftransform > ((x y) (float float) * :when :both)
(ir1-transform-< y x x y '<))
\f
(last nil current)
(current (gensym) (gensym))
(vars (list current) (cons current vars))
- (result 't (if not-p
- `(if (,predicate ,current ,last)
- nil ,result)
- `(if (,predicate ,current ,last)
- ,result nil))))
+ (result t (if not-p
+ `(if (,predicate ,current ,last)
+ nil ,result)
+ `(if (,predicate ,current ,last)
+ ,result nil))))
((zerop i)
`((lambda ,vars ,result) . ,args)))))))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
- ((not (policy nil (and (>= speed space)
- (>= speed compilation-speed))))
+ ((not (policy *lexenv*
+ (and (>= speed space)
+ (>= speed compilation-speed))))
(values nil t))
(t
(let ((vars (make-gensym-list nargs)))
(do ((var vars next)
(next (cdr vars) (cdr next))
- (result 't))
+ (result t))
((null next)
`((lambda ,vars ,result) . ,args))
(let ((v1 (first var)))
;;;; N-arg arithmetic and logic functions are associated into two-arg
;;;; versions, and degenerate cases are flushed.
-;;; Left-associate First-Arg and More-Args using Function.
+;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
(declaim (ftype (function (symbol t list) list) associate-arguments))
(defun associate-arguments (function first-arg more-args)
(let ((next (rest more-args))
(declare (ignore tee))
(funcall control *standard-output* ,@arg-names)
nil)))
+
+(defoptimizer (coerce derive-type) ((value type))
+ (let ((value-type (continuation-type value))
+ (type-type (continuation-type type)))
+ (labels
+ ((good-cons-type-p (cons-type)
+ ;; Make sure the cons-type we're looking at is something
+ ;; we're prepared to handle which is basically something
+ ;; that array-element-type can return.
+ (or (and (member-type-p cons-type)
+ (null (rest (member-type-members cons-type)))
+ (null (first (member-type-members cons-type))))
+ (let ((car-type (cons-type-car-type cons-type)))
+ (and (member-type-p car-type)
+ (null (rest (member-type-members car-type)))
+ (or (symbolp (first (member-type-members car-type)))
+ (numberp (first (member-type-members car-type)))
+ (and (listp (first (member-type-members car-type)))
+ (numberp (first (first (member-type-members
+ car-type))))))
+ (good-cons-type-p (cons-type-cdr-type cons-type))))))
+ (unconsify-type (good-cons-type)
+ ;; Convert the "printed" respresentation of a cons
+ ;; specifier into a type specifier. That is, the specifier
+ ;; (cons (eql signed-byte) (cons (eql 16) null)) is
+ ;; converted to (signed-byte 16).
+ (cond ((or (null good-cons-type)
+ (eq good-cons-type 'null))
+ nil)
+ ((and (eq (first good-cons-type) 'cons)
+ (eq (first (second good-cons-type)) 'member))
+ `(,(second (second good-cons-type))
+ ,@(unconsify-type (caddr good-cons-type))))))
+ (coerceable-p (c-type)
+ ;; 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:
+ ;;
+ ;; o Any real can be coerced to a float type.
+ ;; o Any number can be coerced to a complex single/double-float.
+ ;; o An integer can be coerced to an integer.
+ (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)))
+ (and (subtypep coerced-type 'integer)
+ (csubtypep value-type (specifier-type 'integer))))))
+ (process-types (type)
+ ;; FIXME
+ ;; This needs some work because we should be able to derive
+ ;; the resulting type better than just the type arg of
+ ;; coerce. That is, if x is (integer 10 20), the (coerce x
+ ;; 'double-float) should say (double-float 10d0 20d0)
+ ;; instead of just double-float.
+ (cond ((member-type-p type)
+ (let ((members (member-type-members type)))
+ (if (every #'coerceable-p members)
+ (specifier-type `(or ,@members))
+ *universal-type*)))
+ ((and (cons-type-p type)
+ (good-cons-type-p type))
+ (let ((c-type (unconsify-type (type-specifier type))))
+ (if (coerceable-p c-type)
+ (specifier-type c-type)
+ *universal-type*)))
+ (t
+ *universal-type*))))
+ (cond ((union-type-p type-type)
+ (apply #'type-union (mapcar #'process-types
+ (union-type-types type-type))))
+ ((or (member-type-p type-type)
+ (cons-type-p type-type))
+ (process-types type-type))
+ (t
+ *universal-type*)))))
+
+(defoptimizer (array-element-type derive-type) ((array))
+ (let* ((array-type (continuation-type array)))
+ #!+sb-show
+ (format t "~& defoptimizer array-elt-derive-type - array-element-type ~~
+~A~%" array-type)
+ (labels ((consify (list)
+ (if (endp list)
+ '(eql nil)
+ `(cons (eql ,(car list)) ,(consify (rest list)))))
+ (get-element-type (a)
+ (let ((element-type (type-specifier
+ (array-type-specialized-element-type a))))
+ (cond ((symbolp element-type)
+ (make-member-type :members (list element-type)))
+ ((consp element-type)
+ (specifier-type (consify element-type)))
+ (t
+ (error "Can't grok type ~A~%" 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*)))))
\f
;;;; debuggers' little helpers
projects / sbcl.git / blobdiff