X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=3c000d5bbebbd799d834c42ab6339026806629ab;hb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;hp=eb23711f04cf412a26df8bb8753fb820df17486a;hpb=ba649fc0ec1d25dae4bf97d22611d78d42a7d187;p=sbcl.git diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index eb23711..3c000d5 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -57,9 +57,11 @@ ;;; constant. At worst, it will convert to %TYPEP, which will prevent ;;; spurious attempts at transformation (and possible repeated ;;; warnings.) -(deftransform typep ((object type) * * :node node) +(deftransform typep ((object type &optional env) * * :node node) (unless (constant-lvar-p type) (give-up-ir1-transform "can't open-code test of non-constant type")) + (unless (and (constant-lvar-p env) (null (lvar-value env))) + (give-up-ir1-transform "environment argument present and not null")) (multiple-value-bind (expansion fail-p) (source-transform-typep 'object (lvar-value type)) (if fail-p @@ -79,7 +81,14 @@ ((eq type *empty-type*) nil) (t - (give-up-ir1-transform))))) + (let ((intersect (type-intersection2 type otype))) + (unless intersect + (give-up-ir1-transform)) + (multiple-value-bind (constantp value) + (type-singleton-p intersect) + (if constantp + `(eql object ',value) + (give-up-ir1-transform)))))))) ;;; Flush %TYPEP tests whose result is known at compile time. (deftransform %typep ((object type)) @@ -238,7 +247,8 @@ `(%typep ,object ',spec)) (t (ecase (first spec) - (satisfies `(if (funcall #',(second spec) ,object) t nil)) + (satisfies + `(if (funcall (global-function ,(second spec)) ,object) t nil)) ((not and) (once-only ((n-obj object)) `(,(first spec) ,@(mapcar (lambda (x) @@ -405,14 +415,24 @@ ;; not safe to assume here that it will eventually ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.) (not (unknown-type-p (array-type-element-type type))) - (eq (array-type-complexp stype) (array-type-complexp type))) - (once-only ((n-obj obj)) - (multiple-value-bind (tests headerp) - (test-array-dimensions n-obj type stype) - `(and (,pred ,n-obj) - ,@tests - ,@(test-array-element-type n-obj type stype headerp)))) - `(%typep ,obj ',(type-specifier type))))) + (or (eq (array-type-complexp stype) (array-type-complexp type)) + (and (eql (array-type-complexp stype) :maybe) + (eql (array-type-complexp type) t)))) + (once-only ((n-obj obj)) + (multiple-value-bind (tests headerp) + (test-array-dimensions n-obj type stype) + `(and (,pred ,n-obj) + ,@(when (and (eql (array-type-complexp stype) :maybe) + (eql (array-type-complexp type) t)) + ;; KLUDGE: this is a bit lame; if we get here, + ;; we already know that N-OBJ is an array, but + ;; (NOT SIMPLE-ARRAY) doesn't know that. On the + ;; other hand, this should get compiled down to + ;; two widetag tests, so it's only a bit lame. + `((typep ,n-obj '(not simple-array)))) + ,@tests + ,@(test-array-element-type n-obj type stype headerp)))) + `(%typep ,obj ',(type-specifier type))))) ;;; Transform a type test against some instance type. The type test is ;;; flushed if the result is known at compile time. If not properly @@ -541,6 +561,9 @@ (or (when (not ctype) (compiler-warn "illegal type specifier for TYPEP: ~S" type) (return-from source-transform-typep (values nil t))) + (multiple-value-bind (constantp value) (type-singleton-p ctype) + (and constantp + `(eql ,object ',value))) (let ((pred (cdr (assoc ctype *backend-type-predicates* :test #'type=)))) (when pred `(,pred ,object))) @@ -573,14 +596,15 @@ (t nil)) `(%typep ,object ',type)))) -(define-source-transform typep (object spec) +(define-source-transform typep (object spec &optional env) ;; KLUDGE: It looks bad to only do this on explicitly quoted forms, ;; since that would overlook other kinds of constants. But it turns ;; out that the DEFTRANSFORM for TYPEP detects any constant ;; lvar, transforms it into a quoted form, and gives this ;; source transform another chance, so it all works out OK, in a ;; weird roundabout way. -- WHN 2001-03-18 - (if (and (consp spec) + (if (and (not env) + (consp spec) (eq (car spec) 'quote) (or (not *allow-instrumenting*) (policy *lexenv* (= store-coverage-data 0)))) @@ -599,6 +623,30 @@ (constant-fold-call node) t)))) +;;; Drops dimension information from vector types. +(defun simplify-vector-type (type) + (aver (csubtypep type (specifier-type '(array * (*))))) + (let* ((array-type + (if (csubtypep type (specifier-type 'simple-array)) + 'simple-array + 'array)) + (complexp + (not + (or (eq 'simple-array array-type) + (neq *empty-type* + (type-intersection type (specifier-type 'simple-array))))))) + (dolist (etype + #+sb-xc-host '(t bit character) + #-sb-xc-host sb!kernel::*specialized-array-element-types* + #+sb-xc-host (values nil nil nil) + #-sb-xc-host (values `(,array-type * (*)) t complexp)) + (when etype + (let ((simplified (specifier-type `(,array-type ,etype (*))))) + (when (csubtypep type simplified) + (return (values (type-specifier simplified) + etype + complexp)))))))) + (deftransform coerce ((x type) (* *) * :node node) (unless (constant-lvar-p type) (give-up-ir1-transform)) @@ -606,60 +654,55 @@ (tspec (ir1-transform-specifier-type tval))) (if (csubtypep (lvar-type x) tspec) 'x - ;; Note: The THE here makes sure that specifiers like - ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. - `(the ,(lvar-value type) - ,(cond - ((csubtypep tspec (specifier-type 'double-float)) - '(%double-float x)) - ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) - ((csubtypep tspec (specifier-type 'float)) - '(%single-float x)) - ;; Special case STRING and SIMPLE-STRING as they are union types - ;; in SBCL. - ((member tval '(string simple-string)) - `(if (typep x ',tval) + ;; Note: The THE forms we use to wrap the results make sure that + ;; specifiers like (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. + (cond + ((csubtypep tspec (specifier-type 'double-float)) + `(the ,tval (%double-float x))) + ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) + ((csubtypep tspec (specifier-type 'float)) + `(the ,tval (%single-float x))) + ;; Special case STRING and SIMPLE-STRING as they are union types + ;; in SBCL. + ((member tval '(string simple-string)) + `(the ,tval + (if (typep x ',tval) x - (replace (make-array (length x) :element-type 'character) x))) - ;; Handle specialized element types for 1D arrays. - ((csubtypep tspec (specifier-type '(array * (*)))) - ;; Can we avoid checking for dimension issues like (COERCE FOO - ;; '(SIMPLE-VECTOR 5)) returning a vector of length 6? - (if (or (policy node (< safety 3)) ; no need in unsafe code - (and (array-type-p tspec) ; no need when no dimensions - (equal (array-type-dimensions tspec) '(*)))) - ;; We can! - (let ((array-type - (if (csubtypep tspec (specifier-type 'simple-array)) - 'simple-array - 'array))) - (dolist (etype - #+sb-xc-host '(t bit character) - #-sb-xc-host sb!kernel::*specialized-array-element-types* - (give-up-ir1-transform)) - (when etype - (let ((spec `(,array-type ,etype (*)))) - (when (csubtypep tspec (specifier-type spec)) - ;; Is the result required to be non-simple? - (let ((result-simple - (or (eq 'simple-array array-type) - (neq *empty-type* - (type-intersection - tspec (specifier-type 'simple-array)))))) - (return - `(if (typep x ',spec) - x - (replace - (make-array (length x) :element-type ',etype - ,@(unless result-simple - (list :fill-pointer t - :adjustable t))) - x))))))))) - ;; No, duh. Dimension checking required. - (give-up-ir1-transform - "~@<~S specifies dimensions other than (*) in safe code.~:@>" - tval))) - (t - (give-up-ir1-transform - "~@" - tval))))))) + (replace (make-array (length x) :element-type 'character) x)))) + ;; Special case VECTOR + ((eq tval 'vector) + `(the ,tval + (if (vectorp x) + x + (replace (make-array (length x)) x)))) + ;; Handle specialized element types for 1D arrays. + ((csubtypep tspec (specifier-type '(array * (*)))) + ;; Can we avoid checking for dimension issues like (COERCE FOO + ;; '(SIMPLE-VECTOR 5)) returning a vector of length 6? + ;; + ;; CLHS actually allows this for all code with SAFETY < 3, + ;; but we're a conservative bunch. + (if (or (policy node (zerop safety)) ; no need in unsafe code + (and (array-type-p tspec) ; no need when no dimensions + (equal (array-type-dimensions tspec) '(*)))) + ;; We can! + (multiple-value-bind (vtype etype complexp) (simplify-vector-type tspec) + (unless vtype + (give-up-ir1-transform)) + `(the ,vtype + (if (typep x ',vtype) + x + (replace + (make-array (length x) :element-type ',etype + ,@(when complexp + (list :fill-pointer t + :adjustable t))) + x)))) + ;; No, duh. Dimension checking required. + (give-up-ir1-transform + "~@<~S specifies dimensions other than (*) in safe code.~:@>" + tval))) + (t + (give-up-ir1-transform + "~@" + tval))))))