From 1817553af5c3e33486994d5d4079fca26d910ffd Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 16 Oct 2001 21:01:52 +0000 Subject: [PATCH] 0.pre7.69: added current draft of typecheckfuns.lisp to CVS (but not to stems-and-flags yet) -- cvs add typecheckfuns.lisp --- src/code/typecheckfuns.lisp | 239 +++++++++++++++++++++++++++++++++++++++++++ src/compiler/typetran.lisp | 3 +- 2 files changed, 241 insertions(+), 1 deletion(-) create mode 100644 src/code/typecheckfuns.lisp diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp new file mode 100644 index 0000000..2c87b86 --- /dev/null +++ b/src/code/typecheckfuns.lisp @@ -0,0 +1,239 @@ +;;;; Out-of-line structure slot accessor functions need to do type +;;;; tests. These accessor functions aren't called very often, so it's +;;;; unreasonable to implement them all as different compiled +;;;; functions. But when they are called, it's not reasonable to just +;;;; punt to interpreted TYPEP. The system implemented here is +;;;; a solution to this problem. +;;;; +;;;; Structure accessor functions are still implemented as closures, +;;;; but now one of the closed-over variables is a function which does +;;;; the type test. When a type can be expanded fully into known +;;;; types at compile time, we compile a LAMBDA which does TYPEP on it, and +;;;; use that. If the function can't be expanded at compile time, +;;;; then it can't be compiled efficiently anyway, so we just emit a note. +;;;; +;;;; As a further wrinkle on this, we reuse the type-test functions, +;;;; so that the dozens of slot accessors which have e.g. :TYPE SYMBOL +;;;; can all share the same code instead of having to keep dozens of +;;;; copies of the same function floating around. We can also pull a few +;;;; other tricks to reduce bloat, like implementing tests for structure +;;;; classes as a closure over structure LAYOUTs. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!KERNEL") + +;;; setting up to precompile code for common types once and for all +(declaim (type simple-vector *typecheckfun-standard-typespecs*)) +(declaim (type simple-vector *typecheckfun-standard-typespecs*)) +(eval-when (:compile-toplevel) + ;; When we generate collections of standard specialized array types, + ;; what should their element types be? + (defvar *typecheckfun-standard-element-typespecs* + ;; Note: This table is pretty arbitrary, just things I use a lot + ;; or see used a lot. If someone has ideas for better values, + ;; lemme know. -- WHN 2001-10-15 + #(t + character + bit fixnum (unsigned-byte 32) (signed-byte 32) + single-float double-float)) + ;; What are the standard testable types? (If a slot accessor looks + ;; up one of these types, it doesn't need to supply a compiled TYPEP + ;; function to initialize the possibly-empty entry: instead it's + ;; guaranteed that the entry is there. This should save some compile + ;; time and object file bloat.) + (defvar *typecheckfun-standard-typespecs* + (coerce (remove-duplicates + (mapcar (lambda (typespec) + (type-specifier (specifier-type typespec))) + ;; Note: This collection of input values is + ;; pretty arbitrary, just inspired by things I + ;; use a lot or see being used a lot in the + ;; system. If someone has ideas for better + ;; values, lemme know. -- WHN 2001-10-15 + (concatenate + 'list + ;; non-array types + '(bit + boolean + character + cons + double-float + fixnum + hash-table + index + integer + list + package + signed-byte + (signed-byte 8) + single-float + structure-object + symbol + unsigned-byte + (unsigned-byte 8) + (unsigned-byte 32)) + ;; systematic names for array types + (map 'list + (lambda (element-type) + `(simple-array ,element-type 1)) + *typecheckfun-standard-element-typespecs*) + (map 'list + (lambda (element-type) + `(vector ,element-type)) + *typecheckfun-standard-element-typespecs*) + ;; idiosyncratic names for array types + '(simple-vector + bit-vector simple-bit-vector + string simple-string))) + :test #'equal) + 'simple-vector))) + +(defun ctype-is-standard-typecheckfun-type-p (ctype) + (position (type-specifier ctype) *typecheckfun-standard-typespecs* + :test #'equal)) + +(defun typecheck-failure (arg typespec) + (error 'type-error :datum arg :expected-type typespec)) + +;;; memoization cache for typecheckfuns: a map from fully-expanded type +;;; specifiers to functions which test the type of their argument +(defvar *typecheckfuns* + (make-hash-table :test 'equal)) + +;;; Memoize the FORM which returns a typecheckfun for TYPESPEC. +(defmacro memoized-typecheckfun-form (form typespec) + (let ((n-typespec (gensym "TYPESPEC"))) + `(let ((,n-typespec ,typespec)) + (or (gethash ,n-typespec *typecheckfuns*) + (setf (gethash ,n-typespec *typecheckfuns*) + ,form))))) + +;;; Initialize the memoization cache with typecheckfuns for +;;; *TYPECHECKFUN-STANDARD-TYPESPECS*. +(macrolet ((macro () + `(progn + ,@(map 'list + (lambda (typespec) + `(setf (gethash ',typespec *typecheckfuns*) + (lambda (arg) + (unless (typep arg ',typespec) + (typecheck-failure arg ',typespec)) + (values)))) + *typecheckfun-standard-typespecs*)))) + (macro)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (warn "FIXME: Init *TYPECHECKFUN-STANDARD-TYPESPECS* at cold init time?") + (warn "FIXME: Don't forget to clear the cache when a structure type is undefined.")) + +;;; Return a trivial best-you-can-expect-when-you-don't-predefine-the-type +;;; implementation of a function which checks the type of its argument. +(defun interpreted-typecheckfun (typespec) + ;; Note that we don't and shouldn't memoize this, since otherwise the + ;; user could do + ;; (DEFSTRUCT FOO (X NIL :TYPE XYTYPE)) + ;; (DEFTYPE XYTYPE () (OR SYMBOL CHARACTER)) + ;; (DEFSTRUCT BAR (Y NIL :TYPE XYTYPE)) + ;; and be unpleasantly surprised when the memoized old interpreted + ;; type check from the FOO-X slot setter interfered with the + ;; construction of a shiny new compiled type check for the BAR-Y + ;; slot setter. + (lambda (arg) + (unless (typep arg typespec) + (typecheck-failure arg typespec)) + (values))) + +;;; Type checks for structure objects are all implemented the same +;;; way, with only the LAYOUT varying, so they're practically begging +;;; to be implemented as closures over the layout. +(defun %structure-object-typecheckfun (typespec) + (let ((layout (compiler-layout-or-lose typespec))) + (lambda (arg) + (unless (typep-to-layout arg layout) + (typecheck-failure arg typespec)) + (values)))) +(defun structure-object-typecheckfun (typespec) + (memoized-typecheckfun-form (%structure-object-typecheckfun typespec) + typespec)) + +;;; General type checks need the full compiler, not just stereotyped +;;; closures. We arrange for UNMEMOIZED-TYPECHECKFUN to be produced +;;; for us at compile time (or it can be skipped if the compiler knows +;;; that the memoization lookup can't fail). +(defun general-typecheckfun (typespec &optional unmemoized-typecheckfun) + (or (gethash typespec *typecheckfuns*) + (setf (gethash typespec *typecheckfuns*) unmemoized-typecheckfun) + ;; UNMEMOIZED-TYPECHECKFUN shouldn't be NIL unless the compiler + ;; knew that the memo would exist, so we shouldn't be here. + (error "internal error: no typecheckfun memo for ~% ~S" typespec))) + +(defun ctype-needs-to-be-interpreted-p (ctype) + ;; What we should really do is factor out the code in + ;; (DEF-SOURCE-TRANSFORM TYPEP ..) so that it can be shared here. + ;; Until then this toy version should be good enough for some testing. + (warn "FIXME: This is just a toy stub CTYPE-NEEDS-TO-BE-INTERPRETED-P.") + (not (or (position (type-specifier ctype) + *typecheckfun-standard-typespecs* + :test #'equal) + (member-type-p ctype) + (numeric-type-p ctype) + (array-type-p ctype) + (cons-type-p ctype)))) + +;;; Evaluate (at load/execute time) to a function which checks that +;;; its argument is of the specified type. +;;; +;;; The name is slightly misleading, since some cases are memoized, so +;;; we might reuse a value which was made earlier instead of creating +;;; a new one from scratch. +(declaim (ftype (function (t) function) make-typecheckfun)) +(defun make-typecheckfun (typespec) + ;; a general-purpose default case, hopefully overridden by the + ;; DEFINE-COMPILER-MACRO implementation + (interpreted-typecheckfun typespec)) + +;;; If we know the value of the typespec at compile time, we might +;;; well be able to avoid interpreting it at runtime. +(define-compiler-macro make-typecheckfun (&whole whole typespec-form) + (if (and (consp typespec-form) + (eql (first typespec-form) 'quote)) + (let* ((typespec (second typespec-form)) + (ctype (specifier-type typespec))) + (aver (= 2 (length typespec-form))) + (cond ((structure-class-p ctype) + `(structure-object-typecheckfun ,typespec-form)) + ((ctype-needs-to-be-interpreted-p ctype) + whole) ; i.e. give up compiler macro + (t + `(let ((typespec ,typespec-form)) + (general-typecheckfun + typespec + ;; Unless we know that the function is already in the + ;; memoization cache + ,@(unless (ctype-is-standard-typecheckfun-type-p ctype) + ;; Note that we're arranging for the + ;; UNMEMOIZED-TYPECHECKFUN argument value to be + ;; constructed at compile time. This means the + ;; compiler does the work of compiling the function, + ;; and the loader does the work of loading the + ;; function, regardless of whether the runtime check + ;; for "is it in the memoization cache?" succeeds. + ;; (Then if the memoization check succeeds, the + ;; compiled and loaded function is eventually GCed.) + ;; The wasted motion in the case of a successful + ;; memoization check is unfortunate, but it avoids + ;; having to invoke the compiler at load time when + ;; memoization fails, which is probably more + ;; important. + `((lambda (arg) + (unless (typep arg typespec) + (typecheck-failure arg typespec)))))))))) + whole)) ; i.e. give up compiler macro diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 74940f5..1a332aa 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -77,7 +77,8 @@ ;;; Flush %TYPEP tests whose result is known at compile time. (deftransform %typep ((object type)) - (unless (constant-continuation-p type) (give-up-ir1-transform)) + (unless (constant-continuation-p type) + (give-up-ir1-transform)) (ir1-transform-type-predicate object (specifier-type (continuation-value type)))) -- 1.7.10.4