X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=96761d908cdf29821924ad517c9877d46754172f;hb=5251267b300cb967cbf547e838037a616064bd58;hp=339db89670970b8df21ce70d1c6f0cbfcfbd7d28;hpb=0b3ec4b1d978b887db175b7b3bada8e727683e15;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 339db89..96761d9 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3067,9 +3067,10 @@ :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)))) @@ -3096,14 +3097,14 @@ (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) @@ -3161,7 +3162,7 @@ #!-sb-propagate-float-type (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)) @@ -3180,7 +3181,7 @@ #!+sb-propagate-float-type (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) @@ -3236,11 +3237,11 @@ (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))))))) @@ -3278,14 +3279,15 @@ ((= 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))) @@ -3433,6 +3435,112 @@ (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))) + #!+sb-show (format t "~&coerce-derive-type value-type ~A type-type ~A~%" + value-type 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*))))) ;;;; debuggers' little helpers