X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=b6c1a8ffe310c7c56d7882c645219b70d4ddeac0;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=3c000d5bbebbd799d834c42ab6339026806629ab;hpb=7619132f587e6d30935a38cd19da7d0d80dbc7a3;p=sbcl.git diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 3c000d5..b6c1a8f 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -71,32 +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 - (let ((intersect (type-intersection2 type otype))) - (unless intersect - (give-up-ir1-transform)) - (multiple-value-bind (constantp value) - (type-singleton-p intersect) - (if constantp - `(eql object ',value) - (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 @@ -108,7 +122,7 @@ (basic-combination-fun node)))) *backend-predicate-types*))) (aver ctype) - (ir1-transform-type-predicate object ctype))) + (ir1-transform-type-predicate object ctype node))) ;;; If FIND-CLASSOID is called on a constant class, locate the ;;; CLASSOID-CELL at load time. @@ -118,6 +132,35 @@ `(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) ;;;; @@ -218,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))) @@ -326,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) @@ -480,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)) @@ -556,11 +614,11 @@ ;;; 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))) @@ -580,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 @@ -593,9 +651,21 @@ (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)))) +(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