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       ;; This makes no distinction for BASE/EXTENDED-CHAR. Should it?
 143       (character (specifier-type 'character))
 144       #!+sb-simd-pack
 145       (simd-pack
 146        (let ((tag (%simd-pack-tag x)))
 147          (svref (load-time-value
 148                  (coerce (cons (specifier-type 'simd-pack)
 149                                (mapcar (lambda (x) (specifier-type `(simd-pack ,x)))
 150                                        *simd-pack-element-types*))
 151                          'vector)
 152                  t)
 153                 (if (<= 0 tag #.(1- (length *simd-pack-element-types*)))
 154                     (1+ tag)
 155                     0))))
 156       (t
 157        (classoid-of x)))))
 158
 159 ;; Helper function that implements (CTYPE-OF x) when X is an array.
 160 (defun-cached (ctype-of-array
 161                :values (ctype) ; Bind putative output to this when probing.
 162                :hash-bits 7
 163                :hash-function (lambda (a &aux (hash cookie))
 164                                 (if header-p
 165                                     (dotimes (axis rank hash)
 166                                       (mixf hash (%array-dimension a axis)))
 167                                     (mixf hash (length a)))))
 168     ;; "type-key" is a perfect hash of rank + widetag + simple-p.
 169     ;; If it matches, then compare dims, which are read from the output.
 170     ;; The hash of the type-key + dims can have collisions.
 171     ((array (lambda (array type-key)
 172               (and (eq type-key cookie)
 173                    (let ((dims (array-type-dimensions ctype)))
 174                      (if header-p
 175                          (dotimes (axis rank t)
 176                            (unless (eq (pop (truly-the list dims))
 177                                        (%array-dimension array axis))
 178                              (return nil)))
 179                          (eq (length array) (car dims))))))
 180             cookie) ; Store COOKIE as the single key.
 181      &aux (rank (array-rank array))
 182           (simple-p (if (simple-array-p array) 1 0))
 183           (header-p (array-header-p array)) ; non-simple or rank <> 1 or both
 184           (cookie (the fixnum (logior (ash (logior (ash rank 1) simple-p)
 185                                            sb!vm:n-widetag-bits)
 186                                       (array-underlying-widetag array)))))
 187   ;; The value computed on cache miss.
 188   (let ((etype (specifier-type (array-element-type array))))
 189     (make-array-type (array-dimensions array)
 190                      :complexp (not (simple-array-p array))
 191                      :element-type etype
 192                      :specialized-element-type etype)))
 193 \f
 194 (!defun-from-collected-cold-init-forms !target-type-cold-init)
 195
 196 ;;;; Some functions for examining the type system
 197 ;;;; which are not needed during self-build.
 198
 199 (defun typexpand-all (type-specifier &optional env)
 200   #!+sb-doc
 201   "Takes and expands a type specifier recursively like MACROEXPAND-ALL."
 202   ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to
 203   ;; defer to VALUES-SPECIFIER-TYPE for the check.
 204   (declare (type lexenv-designator env) (ignore env))
 205   ;; I first thought this would not be a good implementation because
 206   ;; it signals an error on e.g. (CONS 1 2) until I realized that
 207   ;; walking and calling TYPEXPAND would also result in errors, and
 208   ;; it actually makes sense.
 209   ;;
 210   ;; There's still a small problem in that
 211   ;;   (TYPEXPAND-ALL '(CONS * FIXNUM)) => (CONS T FIXNUM)
 212   ;; whereas walking+typexpand would result in (CONS * FIXNUM).
 213   ;;
 214   ;; Similiarly, (TYPEXPAND-ALL '(FUNCTION (&REST T) *)) => FUNCTION.
 215   (type-specifier (values-specifier-type type-specifier)))
 216
 217 (defun defined-type-name-p (name &optional env)
 218   #!+sb-doc
 219   "Returns T if NAME is known to name a type specifier, otherwise NIL."
 220   (declare (symbol name))
 221   (declare (ignore env))
 222   (and (info :type :kind name) t))
 223
 224 (defun valid-type-specifier-p (type-specifier &optional env)
 225   #!+sb-doc
 226   "Returns T if TYPE-SPECIFIER is a valid type specifier, otherwise NIL.
 227
 228 There may be different metrics on what constitutes a \"valid type
 229 specifier\" depending on context. If this function does not suit your
 230 exact need, you may be able to craft a particular solution using a
 231 combination of DEFINED-TYPE-NAME-P and the TYPEXPAND functions.
 232
 233 The definition of \"valid type specifier\" employed by this function
 234 is based on the following mnemonic:
 235
 236           \"Would TYPEP accept it as second argument?\"
 237
 238 Except that unlike TYPEP, this function fully supports compound
 239 FUNCTION type specifiers, and the VALUES type specifier, too.
 240
 241 In particular, VALID-TYPE-SPECIFIER-P will return NIL if
 242 TYPE-SPECIFIER is not a class, not a symbol that is known to name a
 243 type specifier, and not a cons that represents a known compound type
 244 specifier in a syntactically and recursively correct way.
 245
 246 Examples:
 247
 248   (valid-type-specifier-p '(cons * *))     => T
 249   (valid-type-specifier-p '#:foo)          => NIL
 250   (valid-type-specifier-p '(cons * #:foo)) => NIL
 251   (valid-type-specifier-p '(cons 1 *)      => NIL
 252
 253 Experimental."
 254   (declare (ignore env))
 255   ;; We don't even care if the spec is parseable -
 256   ;; just deem it invalid.
 257   (not (null (ignore-errors
 258                (type-or-nil-if-unknown type-specifier t)))))