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.
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.
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
25 ;;;; This software is part of the SBCL system. See the README file for
26 ;;;; more information.
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.
34 (in-package "SB!KERNEL")
36 ;;;; setting up to precompile code for common types once and for all
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
49 bit fixnum (unsigned-byte 32) (signed-byte 32)
50 single-float double-float)))
51 (coerce (remove-duplicates
52 (mapcar (lambda (typespec)
53 (type-specifier (specifier-type typespec)))
54 ;; Note: This collection of input values is
55 ;; pretty arbitrary, just inspired by things I
56 ;; use a lot or see being used a lot in the
57 ;; system. If someone has ideas for better
58 ;; values, lemme know. -- WHN 2001-10-15
81 ;; systematic names for array types
83 (lambda (element-type)
84 `(simple-array ,element-type 1))
85 common-element-typespecs)
87 (lambda (element-type)
88 `(vector ,element-type))
89 common-element-typespecs)
90 ;; idiosyncratic names for array types
92 bit-vector simple-bit-vector
93 string simple-string)))
97 ;;; What are the common testable types? (If a slot accessor looks up
98 ;;; one of these types, it doesn't need to supply a compiled TYPEP
99 ;;; function to initialize the possibly-empty entry: instead it's
100 ;;; guaranteed that the entry is there. Hopefully this will reduce
101 ;;; compile time and object file bloat.)
102 (declaim (type simple-vector *common-typespecs*))
103 (defvar *common-typespecs*)
104 #-sb-xc (eval-when (:compile-toplevel :load-toplevel :execute)
105 (setf *common-typespecs*
106 #.*compile-time-common-typespecs*))
107 ;; (#+SB-XC initialization is handled elsewhere, at cold init time.)
109 (defun ctype-is-common-typecheckfun-type-p (ctype)
110 (position (type-specifier ctype) *common-typespecs*
113 (defun typecheck-failure (arg typespec)
114 (error 'type-error :datum arg :expected-type typespec))
116 ;;; memoization cache for typecheckfuns: a map from fully-expanded type
117 ;;; specifiers to functions which test the type of their argument
118 (defvar *typecheckfuns*
119 #-sb-xc (make-hash-table :test 'equal)
120 ;; (#+SB-XC initialization is handled elsewhere, at cold init time.)
123 ;;; Memoize the FORM which returns a typecheckfun for TYPESPEC.
124 (defmacro memoized-typecheckfun-form (form typespec)
125 (with-unique-names (n-typespec)
126 `(let ((,n-typespec ,typespec))
127 (or (gethash ,n-typespec *typecheckfuns*)
128 (setf (gethash ,n-typespec *typecheckfuns*)
132 (defun !typecheckfuns-cold-init ()
133 (/show0 "in typecheckfuns-cold-init")
134 (setf *typecheckfuns* (make-hash-table :test 'equal))
135 ;; Initialize the table of common typespecs.
136 (setf *common-typespecs* #.*compile-time-common-typespecs*)
137 ;; Initialize *TYPECHECKFUNS* with typecheckfuns for common typespecs.
138 (/show0 "typecheckfuns-cold-init initial setfs done")
145 (setf (gethash ',typespec *typecheckfuns*)
149 (unless (typep arg ',typespec)
150 (typecheck-failure arg ',typespec))
152 *common-typespecs*))))
156 ;;; Return a trivial best-you-can-expect-when-you-don't-predefine-the-type
157 ;;; implementation of a function which checks the type of its argument.
158 (defun interpreted-typecheckfun (typespec)
159 ;; Note that we don't and shouldn't memoize this, since otherwise the
161 ;; (DEFSTRUCT FOO (X NIL :TYPE XYTYPE))
162 ;; (DEFTYPE XYTYPE () (OR SYMBOL CHARACTER))
163 ;; (DEFSTRUCT BAR (Y NIL :TYPE XYTYPE))
164 ;; and be unpleasantly surprised when the memoized old interpreted
165 ;; type check from the FOO-X slot setter interfered with the
166 ;; construction of a shiny new compiled type check for the BAR-Y
169 (unless (typep arg typespec)
170 (typecheck-failure arg typespec))
173 ;;; Type checks for structure objects are all implemented the same
174 ;;; way, with only the LAYOUT varying, so they're practically begging
175 ;;; to be implemented as closures over the layout.
176 (defun %structure-object-typecheckfun (typespec)
177 (let ((layout (compiler-layout-or-lose typespec)))
179 (unless (typep-to-layout arg layout)
180 (typecheck-failure arg typespec))
182 (defun structure-object-typecheckfun (typespec)
183 (memoized-typecheckfun-form (%structure-object-typecheckfun typespec)
186 ;;; General type checks need the full compiler, not just stereotyped
187 ;;; closures. We arrange for UNMEMOIZED-TYPECHECKFUN to be produced
188 ;;; for us at compile time (or it can be skipped if the compiler knows
189 ;;; that the memoization lookup can't fail).
190 (defun general-typecheckfun (typespec &optional unmemoized-typecheckfun)
191 (or (gethash typespec *typecheckfuns*)
192 (setf (gethash typespec *typecheckfuns*) unmemoized-typecheckfun)
193 ;; UNMEMOIZED-TYPECHECKFUN shouldn't be NIL unless the compiler
194 ;; knew that the memo would exist, so we shouldn't be here.
195 (bug "no typecheckfun memo for ~S" typespec)))
197 (defun ctype-needs-to-be-interpreted-p (ctype)
198 ;; What we should really do is factor out the code in
199 ;; (DEFINE-SOURCE-TRANSFORM TYPEP ..) so that it can be shared here.
200 ;; Until then this toy version should be good enough for some testing.
201 (warn "FIXME: This is just a toy stub CTYPE-NEEDS-TO-BE-INTERPRETED-P.")
202 (not (or (position (type-specifier ctype)
205 (member-type-p ctype)
206 (numeric-type-p ctype)
209 (intersection-type-p ctype)
211 (negation-type-p ctype)
212 (character-set-type-p ctype))))
214 ;;; Evaluate (at load/execute time) to a function which checks that
215 ;;; its argument is of the specified type.
217 ;;; The name is slightly misleading, since some cases are memoized, so
218 ;;; we might reuse a value which was made earlier instead of creating
219 ;;; a new one from scratch.
220 (declaim (ftype (sfunction (t) function) typespec-typecheckfun))
221 (defun typespec-typecheckfun (typespec)
222 ;; a general-purpose default case, hopefully overridden by the
223 ;; DEFINE-COMPILER-MACRO implementation
224 (interpreted-typecheckfun typespec))
226 ;;; If we know the value of the typespec at compile time, we might
227 ;;; well be able to avoid interpreting it at runtime.
228 (define-compiler-macro typespec-typecheckfun (&whole whole typespec-form)
229 (if (and (consp typespec-form)
230 (eql (first typespec-form) 'quote))
231 (let* ((typespec (second typespec-form))
232 (ctype (specifier-type typespec)))
233 (aver (= 2 (length typespec-form)))
234 (cond ((structure-classoid-p ctype)
235 `(structure-object-typecheckfun ,typespec-form))
236 ((ctype-needs-to-be-interpreted-p ctype)
237 whole) ; i.e. give up compiler macro
239 `(let ((typespec ,typespec-form))
240 (general-typecheckfun
242 ;; Unless we know that the function is already in the
244 ,@(unless (ctype-is-common-typecheckfun-type-p ctype)
245 ;; Note that we're arranging for the
246 ;; UNMEMOIZED-TYPECHECKFUN argument value to be
247 ;; constructed at compile time. This means the
248 ;; compiler does the work of compiling the function,
249 ;; and the loader does the work of loading the
250 ;; function, regardless of whether the runtime check
251 ;; for "is it in the memoization cache?" succeeds.
252 ;; (Then if the memoization check succeeds, the
253 ;; compiled and loaded function is eventually GCed.)
254 ;; The wasted motion in the case of a successful
255 ;; memoization check is unfortunate, but it avoids
256 ;; having to invoke the compiler at load time when
257 ;; memoization fails, which is probably more
260 (unless (typep arg typespec)
261 (typecheck-failure arg typespec))))))))))
262 whole)) ; i.e. give up compiler macro