;;; 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
;;; If the lvar OBJECT definitely is or isn't of the specified
;;; type, then return T or NIL as appropriate. Otherwise quietly
;;; GIVE-UP-IR1-TRANSFORM.
-(defun ir1-transform-type-predicate (object type)
+(defun ir1-transform-type-predicate (object type node)
(declare (type lvar object) (type ctype type))
(let ((otype (lvar-type object)))
- (cond ((not (types-equal-or-intersect otype type))
- nil)
- ((csubtypep otype type)
- t)
- ((eq type *empty-type*)
- nil)
- (t
- (give-up-ir1-transform)))))
+ (flet ((tricky ()
+ (cond ((typep type 'alien-type-type)
+ ;; We don't transform alien type tests until here, because
+ ;; once we do that the rest of the type system can no longer
+ ;; reason about them properly -- so we'd miss out on type
+ ;; derivation, etc.
+ (delay-ir1-transform node :optimize)
+ (let ((alien-type (alien-type-type-alien-type type)))
+ ;; If it's a lisp-rep-type, the CTYPE should be one already.
+ (aver (not (compute-lisp-rep-type alien-type)))
+ `(sb!alien::alien-value-typep object ',alien-type)))
+ (t
+ (give-up-ir1-transform)))))
+ (cond ((not (types-equal-or-intersect otype type))
+ nil)
+ ((csubtypep otype type)
+ t)
+ ((eq type *empty-type*)
+ nil)
+ (t
+ (let ((intersect (type-intersection2 type otype)))
+ (unless intersect
+ (tricky))
+ (multiple-value-bind (constantp value)
+ (type-singleton-p intersect)
+ (if constantp
+ `(eql object ',value)
+ (tricky)))))))))
;;; Flush %TYPEP tests whose result is known at compile time.
-(deftransform %typep ((object type))
+(deftransform %typep ((object type) * * :node node)
(unless (constant-lvar-p type)
(give-up-ir1-transform))
(ir1-transform-type-predicate
object
- (ir1-transform-specifier-type (lvar-value type))))
+ (ir1-transform-specifier-type (lvar-value type))
+ node))
;;; This is the IR1 transform for simple type predicates. It checks
;;; whether the single argument is known to (not) be of the
(basic-combination-fun node))))
*backend-predicate-types*)))
(aver ctype)
- (ir1-transform-type-predicate object ctype)))
+ (ir1-transform-type-predicate object ctype node)))
;;; If FIND-CLASSOID is called on a constant class, locate the
;;; CLASSOID-CELL at load time.
`(or (classoid-cell-classoid ',cell)
(error "class not yet defined: ~S" name))))
\f
+(defoptimizer (%typep-wrapper constraint-propagate-if)
+ ((test-value variable type) node gen)
+ (aver (constant-lvar-p type))
+ (let ((type (lvar-value type)))
+ (values variable (if (ctype-p type)
+ type
+ (handler-case (careful-specifier-type type)
+ (t () nil))))))
+
+(deftransform %typep-wrapper ((test-value variable type) * * :node node)
+ (aver (constant-lvar-p type))
+ (if (constant-lvar-p test-value)
+ `',(lvar-value test-value)
+ (let* ((type (lvar-value type))
+ (type (if (ctype-p type)
+ type
+ (handler-case (careful-specifier-type type)
+ (t () nil))))
+ (value-type (lvar-type variable)))
+ (cond ((not type)
+ 'test-value)
+ ((csubtypep value-type type)
+ t)
+ ((not (types-equal-or-intersect value-type type))
+ nil)
+ (t
+ (delay-ir1-transform node :constraint)
+ 'test-value)))))
+\f
;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
;;;; plus at least one oddball (%INSTANCEP)
;;;;
(once-only ((n-object object))
(ecase (numeric-type-complexp type)
(:real
- `(and (typep ,n-object ',base)
- ,(transform-numeric-bound-test n-object type base)))
+ (if (and #!-(or x86 x86-64) ;; Not implemented elsewhere yet
+ nil
+ (eql (numeric-type-class type) 'integer)
+ (eql (numeric-type-low type) 0)
+ (fixnump (numeric-type-high type)))
+ `(fixnum-mod-p ,n-object ,(numeric-type-high type))
+ `(and (typep ,n-object ',base)
+ ,(transform-numeric-bound-test n-object type base))))
(:complex
`(and (complexp ,n-object)
,(once-only ((n-real `(realpart (truly-the complex ,n-object)))
`(%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)
collect
`(<= ,(car pair) ,n-code ,(cdr pair)))))))))))
+#!+sb-simd-pack
+(defun source-transform-simd-pack-typep (object type)
+ (if (type= type (specifier-type 'simd-pack))
+ `(simd-pack-p ,object)
+ (once-only ((n-obj object))
+ (let ((n-tag (gensym "TAG")))
+ `(and
+ (simd-pack-p ,n-obj)
+ (let ((,n-tag (%simd-pack-tag ,n-obj)))
+ (or ,@(loop
+ for type in (simd-pack-type-element-type type)
+ for index = (position type *simd-pack-element-types*)
+ collect `(eql ,n-tag ,index)))))))))
+
;;; Return the predicate and type from the most specific entry in
;;; *TYPE-PREDICATES* that is a supertype of TYPE.
(defun find-supertype-predicate (type)
;; 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
;;; to that predicate. Otherwise, we dispatch off of the type's type.
;;; These transformations can increase space, but it is hard to tell
;;; when, so we ignore policy and always do them.
-(defun source-transform-typep (object type)
+(defun %source-transform-typep (object type)
(let ((ctype (careful-specifier-type type)))
(or (when (not ctype)
(compiler-warn "illegal type specifier for TYPEP: ~S" type)
- (return-from source-transform-typep (values nil t)))
+ (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)))
`(if (member ,object ',(member-type-members ctype)) t))
(args-type
(compiler-warn "illegal type specifier for TYPEP: ~S" type)
- (return-from source-transform-typep (values nil t)))
+ (return-from %source-transform-typep (values nil t)))
(t nil))
(typecase ctype
(numeric-type
(source-transform-cons-typep object ctype))
(character-set-type
(source-transform-character-set-typep object ctype))
+ #!+sb-simd-pack
+ (simd-pack-type
+ (source-transform-simd-pack-typep object ctype))
(t nil))
`(%typep ,object ',type))))
-(define-source-transform typep (object spec)
+(defun source-transform-typep (object type)
+ (let ((name (gensym "OBJECT")))
+ (multiple-value-bind (transform error)
+ (%source-transform-typep name type)
+ (if error
+ (values nil t)
+ (values `(let ((,name ,object))
+ (%typep-wrapper ,transform ,name ',type)))))))
+
+(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))))
(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))
(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)))
- ;; Special case VECTOR
- ((eq tval 'vector)
- `(if (vectorp x)
+ (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?
- (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
- "~@<open coding coercion to ~S not implemented.~:@>"
- tval)))))))
+ (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
+ "~@<open coding coercion to ~S not implemented.~:@>"
+ tval))))))
projects / sbcl.git / blobdiff