X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=4f47e172178744b148aa04c313c2c8fc1ee5338d;hb=5a9a81ca693a7b82d810cbe725818cd96244099e;hp=71061b0fbce1969242932e7a5b6958168d9ceb67;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 71061b0..4f47e17 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -24,8 +24,8 @@ ;;;; 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. @@ -57,10 +57,14 @@ ;;; 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 @@ -97,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)))) @@ -132,6 +136,8 @@ (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) @@ -232,7 +238,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) @@ -328,40 +335,66 @@ ;;; 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. @@ -374,11 +407,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 @@ -410,8 +445,8 @@ 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) @@ -433,46 +468,60 @@ `((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 @@ -488,6 +537,43 @@ ;;; 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 @@ -495,44 +581,11 @@ ;; 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))) ;;;; coercion @@ -550,7 +603,8 @@ (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 @@ -562,18 +616,56 @@ ;; 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 + "~@" + tval)))))))