X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=b6c1a8ffe310c7c56d7882c645219b70d4ddeac0;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=67f5873cf6e6431d7a7d7ff6abb918329b03b84e;hpb=49e92ee57b3b01f5862d0c6fa65f521de1688941;p=sbcl.git diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 67f5873..b6c1a8f 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -57,9 +57,11 @@ ;;; 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 @@ -69,25 +71,46 @@ ;;; 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 @@ -99,16 +122,45 @@ (basic-combination-fun node)))) *backend-predicate-types*))) (aver ctype) - (ir1-transform-type-predicate object ctype))) + (ir1-transform-type-predicate object ctype node))) -;;; 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)))) +(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))))) + ;;;; standard type predicates, i.e. those defined in package COMMON-LISP, ;;;; plus at least one oddball (%INSTANCEP) ;;;; @@ -209,8 +261,14 @@ (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))) @@ -238,7 +296,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) @@ -316,6 +375,20 @@ 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) @@ -334,40 +407,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))))) - -;;; 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) + (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). 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. @@ -379,11 +478,23 @@ ;; 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))) + (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)) - `(and (,pred ,n-obj) - ,@(test-array-dimensions n-obj type stype) - ,@(test-array-element-type n-obj type stype))) + (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 @@ -432,13 +543,8 @@ ((and (eq (classoid-state class) :sealed) layout (not (classoid-subclasses class))) ;; Sealed and has no subclasses. - (let ((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)))) - (eq ,n-layout ',layout))))) + `(and (,pred object) + (eq (,get-layout object) ',layout))) ((and (typep class 'structure-classoid) layout) ;; structure type tests; hierarchical layout depths (let ((depthoid (layout-depthoid layout)) @@ -492,7 +598,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 @@ -508,11 +614,14 @@ ;;; 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))) @@ -529,7 +638,7 @@ `(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 @@ -542,17 +651,30 @@ (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)))) @@ -571,33 +693,86 @@ (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)) - (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 - ;; (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)) - ((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) + ;; 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)) x))) - ;; FIXME: other VECTOR types? - (t - (give-up-ir1-transform))))))) - - + (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? + ;; + ;; 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 + "~@" + tval))))))