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