src/code/typecheckfuns.lisp

   1 ;;;; Out-of-line structure slot accessor functions need to do type
   2 ;;;; tests. These accessor functions aren't called very often, so it's
   3 ;;;; unreasonable to implement them all as different compiled
   4 ;;;; functions, because that's too much bloat. But when they are
   5 ;;;; called, it's unreasonable to just punt to interpreted TYPEP,
   6 ;;;; because that's unreasonably slow. The system implemented here
   7 ;;;; tries to be a reasonable compromise solution to this problem.
   8 ;;;;
   9 ;;;; Structure accessor functions are still implemented as closures,
  10 ;;;; but now one of the closed-over variables is a function which does
  11 ;;;; the type test, i.e. a typecheckfun. When a type can be expanded
  12 ;;;; fully into known types at compile time, we compile a LAMBDA which
  13 ;;;; does TYPEP on it, and use that. If the function can't be expanded
  14 ;;;; at compile time, then it can't be compiled efficiently anyway, so
  15 ;;;; we just emit a note.
  16 ;;;;
  17 ;;;; As a further wrinkle on this, we reuse the typecheckfuns, so that
  18 ;;;; the dozens of slot accessors which have e.g. :TYPE SYMBOL can all
  19 ;;;; share the same typecheckfun instead of having to keep dozens of
  20 ;;;; equivalent typecheckfun copies floating around. We can also pull
  21 ;;;; a few other tricks to reduce bloat, like implementing all
  22 ;;;; typecheckfuns for structure classes as a closure over structure
  23 ;;;; LAYOUTs.
  24
  25 ;;;; This software is part of the SBCL system. See the README file for
  26 ;;;; more information.
  27 ;;;;
  28 ;;;; This software is derived from the CMU CL system, which was
  29 ;;;; written at Carnegie Mellon University and released into the
  30 ;;;; public domain. The software is in the public domain and is
  31 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  32 ;;;; files for more information.
  33
  34 (in-package "SB!KERNEL")
  35 \f
  36 ;;;; setting up to precompile code for common types once and for all
  37
  38 ;;; initialization value for *COMMON-TYPESPECS*
  39 (eval-when (:compile-toplevel)
  40   (defvar *compile-time-common-typespecs*
  41     (let (;; When we generate collections of common specialized
  42           ;; array types, what should their element types be?
  43           (common-element-typespecs
  44            ;; Note: This table is pretty arbitrary, just things I use a lot
  45            ;; or see used a lot. If someone has ideas for better values,
  46            ;; lemme know. -- WHN 2001-10-15
  47            #(t
  48              character
  49              bit fixnum
  50              #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
  51              (unsigned-byte 32)
  52              #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
  53              (unsigned-byte 64)
  54              #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
  55              (signed-byte 32)
  56              #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
  57              (signed-byte 64)
  58              single-float double-float)))
  59       (coerce (remove-duplicates
  60                (mapcar (lambda (typespec)
  61                          (type-specifier (specifier-type typespec)))
  62                        ;; Note: This collection of input values is
  63                        ;; pretty arbitrary, just inspired by things I
  64                        ;; use a lot or see being used a lot in the
  65                        ;; system. If someone has ideas for better
  66                        ;; values, lemme know. -- WHN 2001-10-15
  67                        (concatenate
  68                         'list
  69                         ;; non-array types
  70                         '(bit
  71                           boolean
  72                           character
  73                           cons
  74                           double-float
  75                           fixnum
  76                           hash-table
  77                           index
  78                           integer
  79                           list
  80                           package
  81                           signed-byte
  82                           (signed-byte 8)
  83                           single-float
  84                           structure-object
  85                           symbol
  86                           unsigned-byte
  87                           (unsigned-byte 8)
  88                           #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
  89                           (unsigned-byte 32)
  90                           #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
  91                           (unsigned-byte 64))
  92                         ;; systematic names for array types
  93                         (map 'list
  94                              (lambda (element-type)
  95                                `(simple-array ,element-type 1))
  96                              common-element-typespecs)
  97                         (map 'list
  98                              (lambda (element-type)
  99                                `(vector ,element-type))
 100                              common-element-typespecs)
 101                         ;; idiosyncratic names for array types
 102                         '(simple-vector
 103                           bit-vector simple-bit-vector
 104                           string simple-string)))
 105                :test #'equal)
 106               'simple-vector))))
 107
 108 ;;; What are the common testable types? (If a slot accessor looks up
 109 ;;; one of these types, it doesn't need to supply a compiled TYPEP
 110 ;;; function to initialize the possibly-empty entry: instead it's
 111 ;;; guaranteed that the entry is there. Hopefully this will reduce
 112 ;;; compile time and object file bloat.)
 113 (declaim (type simple-vector *common-typespecs*))
 114 (defvar *common-typespecs*)
 115 #-sb-xc (eval-when (:compile-toplevel :load-toplevel :execute)
 116           (setf *common-typespecs*
 117                 #.*compile-time-common-typespecs*))
 118 ;; (#+SB-XC initialization is handled elsewhere, at cold init time.)
 119
 120 (defun ctype-is-common-typecheckfun-type-p (ctype)
 121   (position (type-specifier ctype) *common-typespecs*
 122             :test #'equal))
 123
 124 (defun typecheck-failure (arg typespec)
 125   (error 'type-error :datum arg :expected-type typespec))
 126
 127 ;;; memoization cache for typecheckfuns: a map from fully-expanded type
 128 ;;; specifiers to functions which test the type of their argument
 129 (defvar *typecheckfuns*
 130   #-sb-xc (make-hash-table :test 'equal)
 131   ;; (#+SB-XC initialization is handled elsewhere, at cold init time.)
 132   )
 133
 134 ;;; Memoize the FORM which returns a typecheckfun for TYPESPEC.
 135 (defmacro memoized-typecheckfun-form (form typespec)
 136   (with-unique-names (n-typespec)
 137     `(let ((,n-typespec ,typespec))
 138        (or (gethash ,n-typespec *typecheckfuns*)
 139            (setf (gethash ,n-typespec *typecheckfuns*)
 140                  ,form)))))
 141
 142 #+sb-xc
 143 (defun !typecheckfuns-cold-init ()
 144   (/show0 "in typecheckfuns-cold-init")
 145   (setf *typecheckfuns* (make-hash-table :test 'equal))
 146   ;; Initialize the table of common typespecs.
 147   (setf *common-typespecs* #.*compile-time-common-typespecs*)
 148   ;; Initialize *TYPECHECKFUNS* with typecheckfuns for common typespecs.
 149   (/show0 "typecheckfuns-cold-init initial setfs done")
 150   (macrolet ((macro ()
 151                `(progn
 152                   ,@(map 'list
 153                          (lambda (typespec)
 154                            `(progn
 155                               (/show0 "setf")
 156                               (setf (gethash ',typespec *typecheckfuns*)
 157                                     (progn
 158                                       (/show0 "lambda")
 159                                       (lambda (arg)
 160                                         (unless (typep arg ',typespec)
 161                                           (typecheck-failure arg ',typespec))
 162                                         (values))))))
 163                          *common-typespecs*))))
 164     (macro))
 165   (values))
 166
 167 ;;; Return a trivial best-you-can-expect-when-you-don't-predefine-the-type
 168 ;;; implementation of a function which checks the type of its argument.
 169 (defun interpreted-typecheckfun (typespec)
 170   ;; Note that we don't and shouldn't memoize this, since otherwise the
 171   ;; user could do
 172   ;;   (DEFSTRUCT FOO (X NIL :TYPE XYTYPE))
 173   ;;   (DEFTYPE XYTYPE () (OR SYMBOL CHARACTER))
 174   ;;   (DEFSTRUCT BAR (Y NIL :TYPE XYTYPE))
 175   ;; and be unpleasantly surprised when the memoized old interpreted
 176   ;; type check from the FOO-X slot setter interfered with the
 177   ;; construction of a shiny new compiled type check for the BAR-Y
 178   ;; slot setter.
 179   (lambda (arg)
 180     (unless (typep arg typespec)
 181       (typecheck-failure arg typespec))
 182     (values)))
 183
 184 ;;; Type checks for structure objects are all implemented the same
 185 ;;; way, with only the LAYOUT varying, so they're practically begging
 186 ;;; to be implemented as closures over the layout.
 187 (defun %structure-object-typecheckfun (typespec)
 188   (let ((layout (compiler-layout-or-lose typespec)))
 189     (lambda (arg)
 190       (unless (typep-to-layout arg layout)
 191         (typecheck-failure arg typespec))
 192       (values))))
 193 (defun structure-object-typecheckfun (typespec)
 194   (memoized-typecheckfun-form (%structure-object-typecheckfun typespec)
 195                               typespec))
 196
 197 ;;; General type checks need the full compiler, not just stereotyped
 198 ;;; closures. We arrange for UNMEMOIZED-TYPECHECKFUN to be produced
 199 ;;; for us at compile time (or it can be skipped if the compiler knows
 200 ;;; that the memoization lookup can't fail).
 201 (defun general-typecheckfun (typespec &optional unmemoized-typecheckfun)
 202   (or (gethash typespec *typecheckfuns*)
 203       (setf (gethash typespec *typecheckfuns*) unmemoized-typecheckfun)
 204       ;; UNMEMOIZED-TYPECHECKFUN shouldn't be NIL unless the compiler
 205       ;; knew that the memo would exist, so we shouldn't be here.
 206       (bug "no typecheckfun memo for ~S" typespec)))
 207
 208 (defun ctype-needs-to-be-interpreted-p (ctype)
 209   ;; What we should really do is factor out the code in
 210   ;; (DEFINE-SOURCE-TRANSFORM TYPEP ..) so that it can be shared here.
 211   ;; Until then this toy version should be good enough for some testing.
 212   (warn "FIXME: This is just a toy stub CTYPE-NEEDS-TO-BE-INTERPRETED-P.")
 213   (not (or (position (type-specifier ctype)
 214                      *common-typespecs*
 215                      :test #'equal)
 216            (member-type-p ctype)
 217            (numeric-type-p ctype)
 218            (array-type-p ctype)
 219            (cons-type-p ctype)
 220            (intersection-type-p ctype)
 221            (union-type-p ctype)
 222            (negation-type-p ctype)
 223            (character-set-type-p ctype))))
 224
 225 ;;; Evaluate (at load/execute time) to a function which checks that
 226 ;;; its argument is of the specified type.
 227 ;;;
 228 ;;; The name is slightly misleading, since some cases are memoized, so
 229 ;;; we might reuse a value which was made earlier instead of creating
 230 ;;; a new one from scratch.
 231 (declaim (ftype (sfunction (t) function) typespec-typecheckfun))
 232 (defun typespec-typecheckfun (typespec)
 233   ;; a general-purpose default case, hopefully overridden by the
 234   ;; DEFINE-COMPILER-MACRO implementation
 235   (interpreted-typecheckfun typespec))
 236
 237 ;;; If we know the value of the typespec at compile time, we might
 238 ;;; well be able to avoid interpreting it at runtime.
 239 (define-compiler-macro typespec-typecheckfun (&whole whole typespec-form)
 240   (if (and (consp typespec-form)
 241            (eql (first typespec-form) 'quote))
 242       (let* ((typespec (second typespec-form))
 243              (ctype (specifier-type typespec)))
 244         (aver (= 2 (length typespec-form)))
 245         (cond ((structure-classoid-p ctype)
 246                `(structure-object-typecheckfun ,typespec-form))
 247               ((ctype-needs-to-be-interpreted-p ctype)
 248                whole) ; i.e. give up compiler macro
 249               (t
 250                `(let ((typespec ,typespec-form))
 251                   (general-typecheckfun
 252                    typespec
 253                    ;; Unless we know that the function is already in the
 254                    ;; memoization cache
 255                    ,@(unless (ctype-is-common-typecheckfun-type-p ctype)
 256                        ;; Note that we're arranging for the
 257                        ;; UNMEMOIZED-TYPECHECKFUN argument value to be
 258                        ;; constructed at compile time. This means the
 259                        ;; compiler does the work of compiling the function,
 260                        ;; and the loader does the work of loading the
 261                        ;; function, regardless of whether the runtime check
 262                        ;; for "is it in the memoization cache?" succeeds.
 263                        ;; (Then if the memoization check succeeds, the
 264                        ;; compiled and loaded function is eventually GCed.)
 265                        ;; The wasted motion in the case of a successful
 266                        ;; memoization check is unfortunate, but it avoids
 267                        ;; having to invoke the compiler at load time when
 268                        ;; memoization fails, which is probably more
 269                        ;; important.
 270                        `((lambda (arg)
 271                            (unless (typep arg typespec)
 272                              (typecheck-failure arg typespec))))))))))
 273       whole)) ; i.e. give up compiler macro