(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
;;; 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 generated tests passing imply
+;;; 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))
+ (values (unless (eq '* (car dims))
+ `((= (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
(/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
;; 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))
+ (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
projects / sbcl.git / blobdiff