X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=2f10b1e98ee33b5cac10ad5d32441642a14cbb70;hb=c0578d9893429c9c0da80ea5920360e4621fddab;hp=0eba7aa8d2eaf2ca2116a934cd9a9304c8f35742;hpb=b2f0204834bd0c314d44942dd92475c15ffa8c89;p=sbcl.git diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 0eba7aa..2f10b1e 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -101,11 +101,11 @@ (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)))) @@ -334,40 +334,60 @@ ;;; 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. @@ -380,11 +400,13 @@ ;; 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 @@ -492,7 +514,7 @@ (/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 @@ -552,7 +574,10 @@ ;; 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)))