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 ;;; Just call %TYPEP.
  17 ;;;
  18 ;;; Note that when cross-compiling, SB!XC:TYPEP is interpreted as
  19 ;;; a test that the host Lisp object OBJECT translates to a target SBCL
  20 ;;; type TYPE. (This behavior is needed e.g. to test for the validity of
  21 ;;; numeric subtype bounds read when cross-compiling.)
  22 ;;;
  23 ;;; KLUDGE: In classic CMU CL this was wrapped in a (DECLAIM (START-BLOCK
  24 ;;; TYPEP %TYPEP CLASS-CELL-TYPEP)) to make calls efficient. Once I straighten
  25 ;;; out bootstrapping and cross-compiling issues it'd likely be a good idea to
  26 ;;; do this again. -- WHN 19990413
  27 (defun typep (object type)
  28   #!+sb-doc
  29   "Return T iff OBJECT is of type TYPE."
  30   (%typep object type))
  31
  32 ;;; If Type is a type that we can do a compile-time test on, then return the
  33 ;;; whether the object is of that type as the first value and second value
  34 ;;; true. Otherwise return NIL, NIL.
  35 ;;;
  36 ;;; We give up on unknown types and pick off FUNCTION and UNION types. For
  37 ;;; structure types, we require that the type be defined in both the current
  38 ;;; and compiler environments, and that the INCLUDES be the same.
  39 (defun ctypep (obj type)
  40   (declare (type ctype type))
  41   (etypecase type
  42     ((or numeric-type
  43          named-type
  44          member-type
  45          array-type
  46          ;; MNA: cons compound-type patch
  47          ;; FIXIT: all commented out
  48          ; cons-type
  49          sb!xc:built-in-class)
  50      (values (%typep obj type) t))
  51     (sb!xc:class
  52      (if (if (csubtypep type (specifier-type 'funcallable-instance))
  53              (funcallable-instance-p obj)
  54              (typep obj 'instance))
  55          (if (eq (class-layout type)
  56                  (info :type :compiler-layout (sb!xc:class-name type)))
  57              (values (sb!xc:typep obj type) t)
  58              (values nil nil))
  59          (values nil t)))
  60     (union-type
  61      (dolist (mem (union-type-types type) (values nil t))
  62        (multiple-value-bind (val win) (ctypep obj mem)
  63          (unless win (return (values nil nil)))
  64          (when val (return (values t t))))))
  65     (function-type
  66      (values (functionp obj) t))
  67     (unknown-type
  68      (values nil nil))
  69     (alien-type-type
  70      (values (alien-typep obj (alien-type-type-alien-type type)) t))
  71     (hairy-type
  72      ;; Now the tricky stuff.
  73      (let* ((hairy-spec (hairy-type-specifier type))
  74             (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
  75        (ecase symbol
  76          (and
  77           (if (atom hairy-spec)
  78               (values t t)
  79               (dolist (spec (cdr hairy-spec) (values t t))
  80                 (multiple-value-bind (res win)
  81                     (ctypep obj (specifier-type spec))
  82                   (unless win (return (values nil nil)))
  83                   (unless res (return (values nil t)))))))
  84          (not
  85           (multiple-value-bind (res win)
  86               (ctypep obj (specifier-type (cadr hairy-spec)))
  87             (if win
  88                 (values (not res) t)
  89                 (values nil nil))))
  90          (satisfies
  91           ;; KLUDGE: This stuff might well blow up if we tried to execute it
  92           ;; when cross-compiling. But since for the foreseeable future the
  93           ;; only code we'll try to cross-compile is SBCL itself, and SBCL is
  94           ;; built without using SATISFIES types, it's arguably not important
  95           ;; to worry about this. -- WHN 19990210.
  96           (let ((fun (second hairy-spec)))
  97             (cond ((and (consp fun)
  98                         (eq (car fun) 'lambda))
  99                    (values (not (null (funcall (coerce fun 'function) obj)))
 100                            t))
 101                   ((and (symbolp fun) (fboundp fun))
 102                    (values (not (null (funcall fun obj))) t))
 103                   (t
 104                    (values nil nil))))))))))
 105 \f
 106 ;;; LAYOUT-OF  --  Exported
 107 ;;;
 108 ;;;    Return the layout for an object. This is the basic operation for
 109 ;;; finding out the "type" of an object, and is used for generic function
 110 ;;; dispatch. The standard doesn't seem to say as much as it should about what
 111 ;;; this returns for built-in objects. For example, it seems that we must
 112 ;;; return NULL rather than LIST when X is NIL so that GF's can specialize on
 113 ;;; NULL.
 114 #!-sb-fluid (declaim (inline layout-of))
 115 (defun layout-of (x)
 116   (declare (optimize (speed 3) (safety 0)))
 117   (cond ((typep x 'instance) (%instance-layout x))
 118         ((funcallable-instance-p x) (%funcallable-instance-layout x))
 119         ((null x)
 120          ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))).
 121          ;; I (WHN 19990209) replaced this with an expression evaluated at
 122          ;; run time in order to make it easier to build the cross-compiler.
 123          ;; If it doesn't work, something else will be needed..
 124          (locally
 125            ;; KLUDGE: In order to really make it run at run time (instead of
 126            ;; doing some weird broken thing at cold load time),
 127            ;; we need to suppress a DEFTRANSFORM.. -- WHN 19991004
 128            (declare (notinline sb!xc:find-class))
 129            (class-layout (sb!xc:find-class 'null))))
 130         (t (svref *built-in-class-codes* (get-type x)))))
 131
 132 #!-sb-fluid (declaim (inline sb!xc:class-of))
 133 (defun sb!xc:class-of (object)
 134   #!+sb-doc
 135   "Return the class of the supplied object, which may be any Lisp object, not
 136    just a CLOS STANDARD-OBJECT."
 137   (layout-class (layout-of object)))
 138
 139 ;;; Pull the type specifier out of a function object.
 140 (defun extract-function-type (fun)
 141   (if (sb!eval:interpreted-function-p fun)
 142       (sb!eval:interpreted-function-type fun)
 143       (typecase fun
 144         (byte-function (byte-function-type fun))
 145         (byte-closure (byte-function-type (byte-closure-function fun)))
 146         (t
 147          (specifier-type (%function-type (%closure-function fun)))))))
 148 \f
 149 ;;;; miscellaneous interfaces
 150
 151 ;;; Clear memoization of all type system operations that can be altered by
 152 ;;; type definition/redefinition.
 153 (defun clear-type-caches ()
 154   (when *type-system-initialized*
 155     (dolist (sym '(values-specifier-type-cache-clear
 156                    values-type-union-cache-clear
 157                    type-union-cache-clear
 158                    values-subtypep-cache-clear
 159                    csubtypep-cache-clear
 160                    type-intersection-cache-clear
 161                    values-type-intersection-cache-clear))
 162       (funcall (symbol-function sym))))
 163   (values))
 164
 165 ;;; Like TYPE-OF, only we return a CTYPE structure instead of a type specifier,
 166 ;;; and we try to return the type most useful for type checking, rather than
 167 ;;; trying to come up with the one that the user might find most informative.
 168 (declaim (ftype (function (t) ctype) ctype-of))
 169 (defun-cached (ctype-of
 170                :hash-function (lambda (x) (logand (sxhash x) #x1FF))
 171                :hash-bits 9
 172                :init-wrapper !cold-init-forms)
 173               ((x eq))
 174   (typecase x
 175     (function
 176      (if (funcallable-instance-p x)
 177          (sb!xc:class-of x)
 178          (extract-function-type x)))
 179     (symbol
 180      (make-member-type :members (list x)))
 181     (number
 182      (let* ((num (if (complexp x) (realpart x) x))
 183             (res (make-numeric-type
 184                   :class (etypecase num
 185                            (integer 'integer)
 186                            (rational 'rational)
 187                            (float 'float))
 188                   :format (if (floatp num)
 189                               (float-format-name num)
 190                               nil))))
 191        (cond ((complexp x)
 192               (setf (numeric-type-complexp res) :complex)
 193               (let ((imag (imagpart x)))
 194                 (setf (numeric-type-low res) (min num imag))
 195                 (setf (numeric-type-high res) (max num imag))))
 196              (t
 197               (setf (numeric-type-low res) num)
 198               (setf (numeric-type-high res) num)))
 199        res))
 200     (array
 201      (let ((etype (specifier-type (array-element-type x))))
 202        (make-array-type :dimensions (array-dimensions x)
 203                         :complexp (not (typep x 'simple-array))
 204                         :element-type etype
 205                         :specialized-element-type etype)))
 206     ;; MNA: cons compound-type patch
 207     ;; FIXIT: all commented
 208     ; (cons
 209     ; (make-cons-type))
 210     (t
 211      (sb!xc:class-of x))))
 212
 213 ;;; Clear this cache on GC so that we don't hold onto too much garbage.
 214 (pushnew 'ctype-of-cache-clear *before-gc-hooks*)
 215 \f
 216 (!defun-from-collected-cold-init-forms !target-type-cold-init)