src/code/target-type.lisp

   1 ;;;; type-related stuff which exists only in the target SBCL runtime
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!KERNEL")
  13
  14 (!begin-collecting-cold-init-forms)
  15 \f
  16 ;;; If TYPE is a type that we can do a compile-time test on, then
  17 ;;; return whether the object is of that type as the first value and
  18 ;;; second value true. Otherwise return NIL, NIL.
  19 ;;;
  20 ;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
  21 ;;; types. For STRUCTURE- types, we require that the type be defined
  22 ;;; in both the current and compiler environments, and that the
  23 ;;; INCLUDES be the same.
  24 ;;;
  25 ;;; KLUDGE: This should probably be a type method instead of a big
  26 ;;; ETYPECASE. But then the type method system should probably be CLOS
  27 ;;; too, and until that happens wedging more stuff into it might be
  28 ;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16
  29 (defun ctypep (obj type)
  30   (declare (type ctype type))
  31   (etypecase type
  32     ((or numeric-type
  33          named-type
  34          member-type
  35          array-type
  36          character-set-type
  37          built-in-classoid
  38          cons-type
  39          #!+sb-simd-pack simd-pack-type)
  40      (values (%%typep obj type) t))
  41     (classoid
  42      (if (if (csubtypep type (specifier-type 'function))
  43              (funcallable-instance-p obj)
  44              (%instancep obj))
  45          (if (eq (classoid-layout type)
  46                  (info :type :compiler-layout (classoid-name type)))
  47              (values (sb!xc:typep obj type) t)
  48              (values nil nil))
  49          (values nil t)))
  50     (compound-type
  51      (funcall (etypecase type
  52                 (intersection-type #'every/type)
  53                 (union-type #'any/type))
  54               #'ctypep
  55               obj
  56               (compound-type-types type)))
  57     (fun-type
  58      (values (functionp obj) t))
  59     (unknown-type
  60      (values nil nil))
  61     (alien-type-type
  62      (values (alien-typep obj (alien-type-type-alien-type type)) t))
  63     (negation-type
  64      (multiple-value-bind (res win)
  65          (ctypep obj (negation-type-type type))
  66        (if win
  67            (values (not res) t)
  68            (values nil nil))))
  69     (hairy-type
  70      ;; Now the tricky stuff.
  71      (let* ((hairy-spec (hairy-type-specifier type))
  72             (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
  73        (ecase symbol
  74          (and
  75           (if (atom hairy-spec)
  76               (values t t)
  77               (dolist (spec (cdr hairy-spec) (values t t))
  78                 (multiple-value-bind (res win)
  79                     (ctypep obj (specifier-type spec))
  80                   (unless win (return (values nil nil)))
  81                   (unless res (return (values nil t)))))))
  82          (not
  83           (multiple-value-bind (res win)
  84               (ctypep obj (specifier-type (cadr hairy-spec)))
  85             (if win
  86                 (values (not res) t)
  87                 (values nil nil))))
  88          (satisfies
  89           ;; If the SATISFIES function is not foldable, we cannot answer!
  90           (let* ((form `(,(second hairy-spec) ',obj)))
  91             (multiple-value-bind (ok result)
  92                 (sb!c::constant-function-call-p form nil nil)
  93               (values (not (null result)) ok)))))))))
  94 \f
  95 ;;;; miscellaneous interfaces
  96
  97 ;;; Clear memoization of all type system operations that can be
  98 ;;; altered by type definition/redefinition.
  99 ;;;
 100 (defun clear-type-caches ()
 101   ;; FIXME: We would like to differentiate between different cache
 102   ;; kinds, but at the moment all our caches pretty much are type
 103   ;; caches.
 104   (drop-all-hash-caches)
 105   (values))
 106
 107 ;;; This is like TYPE-OF, only we return a CTYPE structure instead of
 108 ;;; a type specifier, and we try to return the type most useful for
 109 ;;; type checking, rather than trying to come up with the one that the
 110 ;;; user might find most informative.
 111 ;;;
 112 ;;; To avoid inadvertent memory retention we avoid using arrays
 113 ;;; and functions as keys.
 114 ;;; During cross-compilation, the CTYPE-OF function is not memoized.
 115 ;;; Constants get their type stored in their LEAF, so it's ok.
 116
 117 (defun-cached (ctype-of :hash-bits 7 :hash-function #'sxhash
 118                         :memoizer memoize)
 119 ;; an unfortunate aspect of using EQ is that several appearances
 120 ;; of the = double-float can be in the cache, but it's
 121 ;; probably more efficient overall to use object identity.
 122     ((x eq))
 123   (flet ((try-cache (x)
 124            (memoize
 125             ;; For functions, the input is a type specifier
 126             ;; of the form (FUNCTION (...) ...)
 127             (cond ((listp x) (specifier-type x)) ; NIL can't occur
 128                   ((symbolp x) (make-eql-type x))
 129                   (t (ctype-of-number x))))))
 130     (typecase x
 131       (function
 132        (if (funcallable-instance-p x)
 133            (classoid-of x)
 134            (let ((type (sb!impl::%fun-type x)))
 135              (if (typep type '(cons (eql function))) ; sanity test
 136                  (try-cache type)
 137                  (classoid-of x)))))
 138       (symbol (if x (try-cache x) (specifier-type 'null)))
 139       (number (try-cache x))
 140       (array (ctype-of-array x))
 141       (cons (specifier-type 'cons))
 142       (character
 143        (typecase x
 144          (standard-char (specifier-type 'standard-char))
 145          (base-char (specifier-type 'base-char))
 146          ;; If the last case were expressed as EXTENDED-CHAR,
 147          ;; we wrongly get "this is not a (VALUES CTYPE): NIL"
 148          ;; because the compiler is too naive to see that
 149          ;; the last 2 cases partition CHARACTER.
 150          (t (specifier-type 'extended-char))))
 151       #!+sb-simd-pack
 152       (simd-pack
 153        (let ((tag (%simd-pack-tag x)))
 154          (svref (load-time-value
 155                  (coerce (cons (specifier-type 'simd-pack)
 156                                (mapcar (lambda (x) (specifier-type `(simd-pack ,x)))
 157                                        *simd-pack-element-types*))
 158                          'vector)
 159                  t)
 160                 (if (<= 0 tag #.(1- (length *simd-pack-element-types*)))
 161                     (1+ tag)
 162                     0))))
 163       (t
 164        (classoid-of x)))))
 165
 166 ;; Helper function that implements (CTYPE-OF x) when X is an array.
 167 (defun-cached (ctype-of-array
 168                :values (ctype) ; Bind putative output to this when probing.
 169                :hash-bits 7
 170                :hash-function (lambda (a &aux (hash cookie))
 171                                 (if header-p
 172                                     (dotimes (axis rank hash)
 173                                       (mixf hash (%array-dimension a axis)))
 174                                     (mixf hash (length a)))))
 175     ;; "type-key" is a perfect hash of rank + widetag + simple-p.
 176     ;; If it matches, then compare dims, which are read from the output.
 177     ;; The hash of the type-key + dims can have collisions.
 178     ((array (lambda (array type-key)
 179               (and (eq type-key cookie)
 180                    (let ((dims (array-type-dimensions ctype)))
 181                      (if header-p
 182                          (dotimes (axis rank t)
 183                            (unless (eq (pop (truly-the list dims))
 184                                        (%array-dimension array axis))
 185                              (return nil)))
 186                          (eq (length array) (car dims))))))
 187             cookie) ; Store COOKIE as the single key.
 188      &aux (rank (array-rank array))
 189           (simple-p (if (simple-array-p array) 1 0))
 190           (header-p (array-header-p array)) ; non-simple or rank <> 1 or both
 191           (cookie (the fixnum (logior (ash (logior (ash rank 1) simple-p)
 192                                            sb!vm:n-widetag-bits)
 193                                       (array-underlying-widetag array)))))
 194   ;; The value computed on cache miss.
 195   (let ((etype (specifier-type (array-element-type array))))
 196     (make-array-type (array-dimensions array)
 197                      :complexp (not (simple-array-p array))
 198                      :element-type etype
 199                      :specialized-element-type etype)))
 200 \f
 201 (!defun-from-collected-cold-init-forms !target-type-cold-init)
 202
 203 ;;;; Some functions for examining the type system
 204 ;;;; which are not needed during self-build.
 205
 206 (defun typexpand-all (type-specifier &optional env)
 207   "Takes and expands a type specifier recursively like MACROEXPAND-ALL."
 208   ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to
 209   ;; defer to VALUES-SPECIFIER-TYPE for the check.
 210   (declare (type lexenv-designator env) (ignore env))
 211   ;; I first thought this would not be a good implementation because
 212   ;; it signals an error on e.g. (CONS 1 2) until I realized that
 213   ;; walking and calling TYPEXPAND would also result in errors, and
 214   ;; it actually makes sense.
 215   ;;
 216   ;; There's still a small problem in that
 217   ;;   (TYPEXPAND-ALL '(CONS * FIXNUM)) => (CONS T FIXNUM)
 218   ;; whereas walking+typexpand would result in (CONS * FIXNUM).
 219   ;;
 220   ;; Similiarly, (TYPEXPAND-ALL '(FUNCTION (&REST T) *)) => FUNCTION.
 221   (type-specifier (values-specifier-type type-specifier)))
 222
 223 (defun defined-type-name-p (name &optional env)
 224   "Returns T if NAME is known to name a type specifier, otherwise NIL."
 225   (declare (symbol name))
 226   (declare (ignore env))
 227   (and (info :type :kind name) t))
 228
 229 (defun valid-type-specifier-p (type-specifier &optional env)
 230   "Returns T if TYPE-SPECIFIER is a valid type specifier, otherwise NIL.
 231
 232 There may be different metrics on what constitutes a \"valid type
 233 specifier\" depending on context. If this function does not suit your
 234 exact need, you may be able to craft a particular solution using a
 235 combination of DEFINED-TYPE-NAME-P and the TYPEXPAND functions.
 236
 237 The definition of \"valid type specifier\" employed by this function
 238 is based on the following mnemonic:
 239
 240           \"Would TYPEP accept it as second argument?\"
 241
 242 Except that unlike TYPEP, this function fully supports compound
 243 FUNCTION type specifiers, and the VALUES type specifier, too.
 244
 245 In particular, VALID-TYPE-SPECIFIER-P will return NIL if
 246 TYPE-SPECIFIER is not a class, not a symbol that is known to name a
 247 type specifier, and not a cons that represents a known compound type
 248 specifier in a syntactically and recursively correct way.
 249
 250 Examples:
 251
 252   (valid-type-specifier-p '(cons * *))     => T
 253   (valid-type-specifier-p '#:foo)          => NIL
 254   (valid-type-specifier-p '(cons * #:foo)) => NIL
 255   (valid-type-specifier-p '(cons 1 *)      => NIL
 256
 257 Experimental."
 258   (declare (ignore env))
 259   ;; We don't even care if the spec is parseable -
 260   ;; just deem it invalid.
 261   (not (null (ignore-errors
 262                (type-or-nil-if-unknown type-specifier t)))))