X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-type.lisp;h=1f877a01bb087f2044ab61da80acf744d2372d10;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=e561d872b6cf00a2c8adfd12a2fa51bb88d0cdce;hpb=148e3820ad314a9b59d0133c1d60eaac4af9118b;p=sbcl.git diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index e561d87..1f877a0 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -30,78 +30,67 @@ (declare (type ctype type)) (etypecase type ((or numeric-type - named-type - member-type - array-type - sb!xc:built-in-class - cons-type) + named-type + member-type + array-type + character-set-type + built-in-classoid + cons-type + #!+sb-simd-pack simd-pack-type) (values (%typep obj type) t)) - (sb!xc:class - (if (if (csubtypep type (specifier-type 'funcallable-instance)) - (funcallable-instance-p obj) - (typep obj 'instance)) - (if (eq (class-layout type) - (info :type :compiler-layout (sb!xc:class-name type))) - (values (sb!xc:typep obj type) t) - (values nil nil)) - (values nil t))) + (classoid + (if (if (csubtypep type (specifier-type 'function)) + (funcallable-instance-p obj) + (%instancep obj)) + (if (eq (classoid-layout type) + (info :type :compiler-layout (classoid-name type))) + (values (sb!xc:typep obj type) t) + (values nil nil)) + (values nil t))) (compound-type (funcall (etypecase type - (intersection-type #'every/type) - (union-type #'any/type)) - #'ctypep - obj - (compound-type-types type))) + (intersection-type #'every/type) + (union-type #'any/type)) + #'ctypep + obj + (compound-type-types type))) (fun-type (values (functionp obj) t)) (unknown-type (values nil nil)) (alien-type-type (values (alien-typep obj (alien-type-type-alien-type type)) t)) + (negation-type + (multiple-value-bind (res win) + (ctypep obj (negation-type-type type)) + (if win + (values (not res) t) + (values nil nil)))) (hairy-type ;; Now the tricky stuff. (let* ((hairy-spec (hairy-type-specifier type)) - (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) (ecase symbol - (and - (if (atom hairy-spec) - (values t t) - (dolist (spec (cdr hairy-spec) (values t t)) - (multiple-value-bind (res win) - (ctypep obj (specifier-type spec)) - (unless win (return (values nil nil))) - (unless res (return (values nil t))))))) - (not - (multiple-value-bind (res win) - (ctypep obj (specifier-type (cadr hairy-spec))) - (if win - (values (not res) t) - (values nil nil)))) - (satisfies - (let ((predicate-name (second hairy-spec))) - (declare (type symbol predicate-name)) ; by ANSI spec of SATISFIES - (if (fboundp predicate-name) - (let* (;; "Is OBJ of the SATISFIES type?" represented - ;; as a generalized boolean. - ;; - ;; (Why IGNORE-ERRORS? This code is used to try to - ;; check type relationships at compile time. - ;; Passing only-slightly-twisted types like - ;; (AND INTEGER (SATISFIES ODDP)) into the - ;; rather-significantly-twisted type dispatch - ;; system can easily give rise to oddities like - ;; calling predicates like ODDP on values they - ;; don't like. (E.g. on OBJ=#\NEWLINE when the - ;; above type is tested for TYPE= against - ;; STANDARD-CHAR, represented as a - ;; MEMBER-TYPE.) In such cases, NIL seems to be - ;; an appropriate answer to "is OBJ of the - ;; SATISFIES type?") - (gbool (ignore-errors (funcall predicate-name obj))) - ;; RAW coerced to a pure BOOLEAN value - (bool (not (not gbool)))) - (values bool t)) - (values nil nil))))))))) + (and + (if (atom hairy-spec) + (values t t) + (dolist (spec (cdr hairy-spec) (values t t)) + (multiple-value-bind (res win) + (ctypep obj (specifier-type spec)) + (unless win (return (values nil nil))) + (unless res (return (values nil t))))))) + (not + (multiple-value-bind (res win) + (ctypep obj (specifier-type (cadr hairy-spec))) + (if win + (values (not res) t) + (values nil nil)))) + (satisfies + ;; If the SATISFIES function is not foldable, we cannot answer! + (let* ((form `(,(second hairy-spec) ',obj))) + (multiple-value-bind (ok result) + (sb!c::constant-function-call-p form nil nil) + (values (not (null result)) ok))))))))) ;;; Return the layout for an object. This is the basic operation for ;;; finding out the "type" of an object, and is used for generic @@ -112,46 +101,41 @@ #!-sb-fluid (declaim (inline layout-of)) (defun layout-of (x) (declare (optimize (speed 3) (safety 0))) - (cond ((typep x 'instance) (%instance-layout x)) - ((funcallable-instance-p x) (%funcallable-instance-layout x)) - ((null x) - ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))). - ;; I (WHN 19990209) replaced this with an expression evaluated at - ;; run time in order to make it easier to build the cross-compiler. - ;; If it doesn't work, something else will be needed.. - (locally - ;; KLUDGE: In order to really make this run at run time - ;; (instead of doing some weird broken thing at cold load - ;; time), we need to suppress a DEFTRANSFORM.. -- WHN 19991004 - (declare (notinline sb!xc:find-class)) - (class-layout (sb!xc:find-class 'null)))) - (t (svref *built-in-class-codes* (widetag-of x))))) + (cond ((%instancep x) (%instance-layout x)) + ((funcallable-instance-p x) (%funcallable-instance-layout x)) + ((null x) + ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))). + ;; I (WHN 19990209) replaced this with an expression evaluated at + ;; run time in order to make it easier to build the cross-compiler. + ;; + ;; KLUDGE: Since there's a DEFTRANSFORM for FIND-CLASSOID on + ;; constant names which creates non-cold-loadable code, we + ;; can't just use (CLASSOID-LAYOUT (FIND-CLASSOID 'NULL)) + ;; here. The original (WHN 19991004) solution was to locally + ;; notinline FIND-CLASSOID. However, the full call to + ;; FIND-CLASSOID caused suboptimal register allocation in PCL + ;; dfuns. So instead we now use a special variable which is + ;; initialized during cold init. -- JES, 2006-07-04 + *null-classoid-layout*) + (t (svref *built-in-class-codes* (widetag-of x))))) -#!-sb-fluid (declaim (inline sb!xc:class-of)) -(defun sb!xc:class-of (object) +#!-sb-fluid (declaim (inline classoid-of)) +(defun classoid-of (object) #!+sb-doc "Return the class of the supplied object, which may be any Lisp object, not just a CLOS STANDARD-OBJECT." - (layout-class (layout-of object))) - -;;; Pull the type specifier out of a function object. -(defun extract-fun-type (fun) - (specifier-type (%simple-fun-type (%closure-fun fun)))) + (layout-classoid (layout-of object))) ;;;; miscellaneous interfaces ;;; Clear memoization of all type system operations that can be ;;; altered by type definition/redefinition. +;;; (defun clear-type-caches () - (when *type-system-initialized* - (dolist (sym '(values-specifier-type-cache-clear - values-type-union-cache-clear - type-union2-cache-clear - values-subtypep-cache-clear - csubtypep-cache-clear - type-intersection2-cache-clear - values-type-intersection-cache-clear)) - (funcall (the function (symbol-function sym))))) + ;; FIXME: We would like to differentiate between different cache + ;; kinds, but at the moment all our caches pretty much are type + ;; caches. + (drop-all-hash-caches) (values)) ;;; This is like TYPE-OF, only we return a CTYPE structure instead of @@ -160,15 +144,15 @@ ;;; user might find most informative. (declaim (ftype (function (t) ctype) ctype-of)) (defun-cached (ctype-of - :hash-function (lambda (x) (logand (sxhash x) #x1FF)) - :hash-bits 9 - :init-wrapper !cold-init-forms) - ((x eq)) + :hash-function (lambda (x) (logand (sxhash x) #x1FF)) + :hash-bits 9 + :init-wrapper !cold-init-forms) + ((x eq)) (typecase x (function (if (funcallable-instance-p x) - (sb!xc:class-of x) - (extract-fun-type x))) + (classoid-of x) + (specifier-type (sb!impl::%fun-type x)))) (symbol (make-member-type :members (list x))) (number @@ -176,15 +160,20 @@ (array (let ((etype (specifier-type (array-element-type x)))) (make-array-type :dimensions (array-dimensions x) - :complexp (not (typep x 'simple-array)) - :element-type etype - :specialized-element-type etype))) + :complexp (not (typep x 'simple-array)) + :element-type etype + :specialized-element-type etype))) (cons (make-cons-type *universal-type* *universal-type*)) + (character + (specifier-type 'character)) + #!+sb-simd-pack + (simd-pack + (let ((type (nth (%simd-pack-tag x) *simd-pack-element-types*))) + (if type + (specifier-type `(simd-pack ,type)) + (specifier-type 'simd-pack)))) (t - (sb!xc:class-of x)))) - -;;; Clear this cache on GC so that we don't hold onto too much garbage. -(pushnew 'ctype-of-cache-clear *before-gc-hooks*) + (classoid-of x)))) (!defun-from-collected-cold-init-forms !target-type-cold-init)