;;;; predicates so complex that the only reasonable implentation is
;;;; via function call.
;;;;
-;;;; Some standard types (such as SEQUENCE) are best tested by letting
-;;;; the TYPEP source transform do its thing with the expansion. These
+;;;; Some standard types (such as ATOM) are best tested by letting the
+;;;; TYPEP source transform do its thing with the expansion. These
;;;; types (and corresponding predicates) are not maintained in this
;;;; association. In this case, there need not be any predicate
;;;; function unless it is required by the Common Lisp specification.
;;; constant. At worst, it will convert to %TYPEP, which will prevent
;;; spurious attempts at transformation (and possible repeated
;;; warnings.)
-(deftransform typep ((object type))
+(deftransform typep ((object type) * * :node node)
(unless (constant-lvar-p type)
(give-up-ir1-transform "can't open-code test of non-constant type"))
- `(typep object ',(lvar-value type)))
+ (multiple-value-bind (expansion fail-p)
+ (source-transform-typep 'object (lvar-value type))
+ (if fail-p
+ (abort-ir1-transform)
+ expansion)))
;;; If the lvar OBJECT definitely is or isn't of the specified
;;; type, then return T or NIL as appropriate. Otherwise quietly
(aver ctype)
(ir1-transform-type-predicate object ctype)))
-;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
-;;; at load time.
+;;; If FIND-CLASSOID is called on a constant class, locate the
+;;; CLASSOID-CELL at load time.
(deftransform find-classoid ((name) ((constant-arg symbol)) *)
(let* ((name (lvar-value name))
- (cell (find-classoid-cell name)))
+ (cell (find-classoid-cell name :create t)))
`(or (classoid-cell-classoid ',cell)
(error "class not yet defined: ~S" name))))
\f
(define-type-predicate numberp number)
(define-type-predicate rationalp rational)
(define-type-predicate realp real)
+ (define-type-predicate sequencep sequence)
+ (define-type-predicate extended-sequence-p extended-sequence)
(define-type-predicate simple-bit-vector-p simple-bit-vector)
(define-type-predicate simple-string-p simple-string)
(define-type-predicate simple-vector-p simple-vector)
`(%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)
;;; Return forms to test that OBJ has the rank and dimensions
;;; specified by TYPE, where STYPE is the type we have checked against
;;; (which is the same but for dimensions and element type).
+;;;
+;;; Secondary return value is true if passing the generated tests implies that
+;;; the array has a header.
(defun test-array-dimensions (obj type stype)
(declare (type array-type type stype))
(let ((obj `(truly-the ,(type-specifier stype) ,obj))
(dims (array-type-dimensions type)))
(unless (or (eq dims '*)
(equal dims (array-type-dimensions stype)))
- (collect ((res))
- (when (eq (array-type-dimensions stype) '*)
- (res `(= (array-rank ,obj) ,(length dims))))
- (do ((i 0 (1+ i))
- (dim dims (cdr dim)))
- ((null dim))
- (let ((dim (car dim)))
- (unless (eq dim '*)
- (res `(= (array-dimension ,obj ,i) ,dim)))))
- (res)))))
+ (cond ((cdr dims)
+ (values `((array-header-p ,obj)
+ ,@(when (eq (array-type-dimensions stype) '*)
+ `((= (%array-rank ,obj) ,(length dims))))
+ ,@(loop for d in dims
+ for i from 0
+ unless (eq '* d)
+ collect `(= (%array-dimension ,obj ,i) ,d)))
+ t))
+ ((not dims)
+ (values `((array-header-p ,obj)
+ (= (%array-rank ,obj) 0))
+ t))
+ ((not (array-type-complexp type))
+ (if (csubtypep stype (specifier-type 'vector))
+ (values (unless (eq '* (car dims))
+ `((= (vector-length ,obj) ,@dims)))
+ nil)
+ (values (if (eq '* (car dims))
+ `((not (array-header-p ,obj)))
+ `((not (array-header-p ,obj))
+ (= (vector-length ,obj) ,@dims)))
+ nil)))
+ (t
+ (values (unless (eq '* (car dims))
+ `((if (array-header-p ,obj)
+ (= (%array-dimension ,obj 0) ,@dims)
+ (= (vector-length ,obj) ,@dims))))
+ nil))))))
-;;; Return forms to test that OBJ has the element-type specified by
-;;; type specified by TYPE, where STYPE is the type we have checked
-;;; against (which is the same but for dimensions and element type).
-(defun test-array-element-type (obj type stype)
+;;; Return forms to test that OBJ has the element-type specified by type
+;;; specified by TYPE, where STYPE is the type we have checked against (which
+;;; is the same but for dimensions and element type). If HEADERP is true, OBJ
+;;; is guaranteed to be an array-header.
+(defun test-array-element-type (obj type stype headerp)
(declare (type array-type type stype))
(let ((obj `(truly-the ,(type-specifier stype) ,obj))
(eltype (array-type-specialized-element-type type)))
- (unless (type= eltype (array-type-specialized-element-type stype))
- (with-unique-names (data)
- `((do ((,data ,obj (%array-data-vector ,data)))
- ((not (array-header-p ,data))
- ;; KLUDGE: this isn't in fact maximally efficient,
- ;; because though we know that DATA is a (SIMPLE-ARRAY *
- ;; (*)), we will still check to see if the lowtag is
- ;; appropriate.
- (typep ,data
- '(simple-array ,(type-specifier eltype) (*))))))))))
+ (unless (or (type= eltype (array-type-specialized-element-type stype))
+ (eq eltype *wild-type*))
+ (let ((typecode (sb!vm:saetp-typecode (find-saetp-by-ctype eltype))))
+ (with-unique-names (data)
+ (if (and headerp (not (array-type-complexp stype)))
+ ;; If we know OBJ is an array header, and that the array is
+ ;; simple, we also know there is exactly one indirection to
+ ;; follow.
+ `((eq (%other-pointer-widetag (%array-data-vector ,obj)) ,typecode))
+ `((do ((,data ,(if headerp `(%array-data-vector ,obj) obj)
+ (%array-data-vector ,data)))
+ ((not (array-header-p ,data))
+ (eq (%other-pointer-widetag ,data) ,typecode))))))))))
;;; If we can find a type predicate that tests for the type without
;;; dimensions, then use that predicate and test for dimensions.
;; 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))
- `(and (,pred ,n-obj)
- ,@(test-array-dimensions n-obj type stype)
- ,@(test-array-element-type n-obj type stype)))
- `(%typep ,obj ',(type-specifier 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)))))
;;; Transform a type test against some instance type. The type test is
;;; flushed if the result is known at compile time. If not properly
class:~% ~S"
class))
(t
- ;; Delay the type transform to give type propagation a chance.
- (delay-ir1-transform node :constraint)
+ ;; Delay the type transform to give type propagation a chance.
+ (delay-ir1-transform node :constraint)
;; Otherwise transform the type test.
(multiple-value-bind (pred get-layout)
`((when (layout-invalid ,n-layout)
(%layout-invalid-error object ',layout))))
(eq ,n-layout ',layout)))))
- ((and (typep class 'basic-structure-classoid) layout)
+ ((and (typep class 'structure-classoid) layout)
;; structure type tests; hierarchical layout depths
(let ((depthoid (layout-depthoid layout))
(n-layout (gensym)))
`(and (,pred object)
(let ((,n-layout (,get-layout object)))
- ,@(when (policy *lexenv* (>= safety speed))
- `((when (layout-invalid ,n-layout)
- (%layout-invalid-error object ',layout))))
+ ;; we used to check for invalid layouts here,
+ ;; but in fact that's both unnecessary and
+ ;; wrong; it's unnecessary because structure
+ ;; classes can't be redefined, and it's wrong
+ ;; because it is quite legitimate to pass an
+ ;; object with an invalid layout to a structure
+ ;; type test.
(if (eq ,n-layout ',layout)
t
(and (> (layout-depthoid ,n-layout)
,depthoid)
(locally (declare (optimize (safety 0)))
- (eq (svref (layout-inherits ,n-layout)
- ,depthoid)
+ ;; Use DATA-VECTOR-REF directly,
+ ;; since that's what SVREF in a
+ ;; SAFETY 0 lexenv will eventually be
+ ;; transformed to. This can give a
+ ;; large compilation speedup, since
+ ;; %INSTANCE-TYPEPs are frequently
+ ;; created during GENERATE-TYPE-CHECKS,
+ ;; and the normal aref transformation path
+ ;; is pretty heavy.
+ (eq (data-vector-ref (layout-inherits ,n-layout)
+ ,depthoid)
',layout))))))))
((and layout (>= (layout-depthoid layout) 0))
;; hierarchical layout depths for other things (e.g.
- ;; CONDITIONs)
+ ;; CONDITION, STREAM)
(let ((depthoid (layout-depthoid layout))
(n-layout (gensym))
(n-inherits (gensym)))
`(and (,pred object)
(let ((,n-layout (,get-layout object)))
- ,@(when (policy *lexenv* (>= safety speed))
- `((when (layout-invalid ,n-layout)
- (%layout-invalid-error object ',layout))))
+ (when (layout-invalid ,n-layout)
+ (setq ,n-layout (update-object-layout-or-invalid
+ object ',layout)))
(if (eq ,n-layout ',layout)
t
(let ((,n-inherits (layout-inherits ,n-layout)))
(declare (optimize (safety 0)))
(and (> (length ,n-inherits) ,depthoid)
- (eq (svref ,n-inherits ,depthoid)
+ ;; See above.
+ (eq (data-vector-ref ,n-inherits ,depthoid)
',layout))))))))
(t
(/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
`(and (,pred object)
(classoid-cell-typep (,get-layout object)
- ',(find-classoid-cell name)
+ ',(find-classoid-cell name :create t)
object)))))))))
;;; If the specifier argument is a quoted constant, then we consider
;;; 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)
+ (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)))
+ (let ((pred (cdr (assoc ctype *backend-type-predicates*
+ :test #'type=))))
+ (when pred `(,pred ,object)))
+ (typecase ctype
+ (hairy-type
+ (source-transform-hairy-typep object ctype))
+ (negation-type
+ (source-transform-negation-typep object ctype))
+ (union-type
+ (source-transform-union-typep object ctype))
+ (intersection-type
+ (source-transform-intersection-typep object ctype))
+ (member-type
+ `(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)))
+ (t nil))
+ (typecase ctype
+ (numeric-type
+ (source-transform-numeric-typep object ctype))
+ (classoid
+ `(%instance-typep ,object ',type))
+ (array-type
+ (source-transform-array-typep object ctype))
+ (cons-type
+ (source-transform-cons-typep object ctype))
+ (character-set-type
+ (source-transform-character-set-typep object ctype))
+ (t nil))
+ `(%typep ,object ',type))))
+
(define-source-transform typep (object spec)
;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
;; since that would overlook other kinds of constants. But it turns
;; 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) (eq (car spec) 'quote))
- (let ((type (careful-specifier-type (cadr spec))))
- (or (when (not type)
- (compiler-warn "illegal type specifier for TYPEP: ~S"
- (cadr spec))
- `(%typep ,object ,spec))
- (let ((pred (cdr (assoc type *backend-type-predicates*
- :test #'type=))))
- (when pred `(,pred ,object)))
- (typecase type
- (hairy-type
- (source-transform-hairy-typep object type))
- (negation-type
- (source-transform-negation-typep object type))
- (union-type
- (source-transform-union-typep object type))
- (intersection-type
- (source-transform-intersection-typep object type))
- (member-type
- `(if (member ,object ',(member-type-members type)) t))
- (args-type
- (compiler-warn "illegal type specifier for TYPEP: ~S"
- (cadr spec))
- `(%typep ,object ,spec))
- (t nil))
- (typecase type
- (numeric-type
- (source-transform-numeric-typep object type))
- (classoid
- `(%instance-typep ,object ,spec))
- (array-type
- (source-transform-array-typep object type))
- (cons-type
- (source-transform-cons-typep object type))
- (character-set-type
- (source-transform-character-set-typep object type))
- (t nil))
- `(%typep ,object ,spec)))
+ (if (and (consp spec)
+ (eq (car spec) 'quote)
+ (or (not *allow-instrumenting*)
+ (policy *lexenv* (= store-coverage-data 0))))
+ (source-transform-typep object (cadr spec))
(values nil t)))
\f
;;;; coercion
(deftransform coerce ((x type) (* *) * :node node)
(unless (constant-lvar-p type)
(give-up-ir1-transform))
- (let ((tspec (ir1-transform-specifier-type (lvar-value type))))
+ (let* ((tval (lvar-value type))
+ (tspec (ir1-transform-specifier-type tval)))
(if (csubtypep (lvar-type x) tspec)
'x
;; Note: The THE here makes sure that specifiers like
;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
((csubtypep tspec (specifier-type 'float))
'(%single-float x))
- ((and (csubtypep tspec (specifier-type 'simple-vector))
- ;; Can we avoid checking for dimension issues like
- ;; (COERCE FOO '(SIMPLE-VECTOR 5)) returning a
- ;; vector of length 6?
- (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) '(*)))))
- `(if (simple-vector-p x)
+ ;; Special case STRING and SIMPLE-STRING as they are union types
+ ;; in SBCL.
+ ((member tval '(string simple-string))
+ `(if (typep x ',tval)
+ x
+ (replace (make-array (length x) :element-type 'character) x)))
+ ;; Special case VECTOR
+ ((eq tval 'vector)
+ `(if (vectorp x)
x
(replace (make-array (length x)) x)))
- ;; FIXME: other VECTOR types?
+ ;; 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)))))))
-
-
+ (give-up-ir1-transform
+ "~@<open coding coercion to ~S not implemented.~:@>"
+ tval)))))))
projects / sbcl.git / blobdiff