From 4e0a82f8b37f0639b7071deecfe5c8c662d6d955 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Fri, 7 Mar 2014 05:25:46 +0400 Subject: [PATCH] Remove src/code/typecheckfuns.lisp. It's no longer used. --- build-order.lisp-expr | 1 - src/code/cold-init.lisp | 1 - src/code/defstruct.lisp | 1 - src/code/target-defstruct.lisp | 2 - src/code/typecheckfuns.lisp | 275 ----------------------------------------- 5 files changed, 280 deletions(-) delete mode 100644 src/code/typecheckfuns.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index afc27701a..f59dd5661 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -400,7 +400,6 @@ ("src/compiler/proclaim") ("src/code/class-init") - ("src/code/typecheckfuns") ;; The DEFSTRUCT machinery needs SB!XC:SUBTYPEP, defined in ;; "code/late-type", and SB!XC:TYPEP, defined in "code/cross-type", diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 808224e2c..9642cc46b 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -114,7 +114,6 @@ (show-and-call !eval-cold-init) (show-and-call !deadline-cold-init) (show-and-call thread-init-or-reinit) - (show-and-call !typecheckfuns-cold-init) ;; Anyone might call RANDOM to initialize a hash value or something; ;; and there's nothing which needs to be initialized in order for diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 3d5f5d6b0..2e7dcd8cb 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1036,7 +1036,6 @@ (let ((info (layout-info (classoid-layout classoid)))) (when (defstruct-description-p info) (let ((type (dd-name info))) - (remhash type *typecheckfuns*) (clear-info :type :compiler-layout type) (undefine-fun-name (dd-copier-name info)) (undefine-fun-name (dd-predicate-name info)) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 1efdaf0ef..a7e898aa8 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -138,8 +138,6 @@ (/show0 "entering %TARGET-DEFSTRUCT") - (remhash (dd-name dd) *typecheckfuns*) - (when (dd-doc dd) (setf (fdocumentation (dd-name dd) 'structure) (dd-doc dd))) diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp deleted file mode 100644 index 3e0174f96..000000000 --- a/src/code/typecheckfuns.lisp +++ /dev/null @@ -1,275 +0,0 @@ -;;;; 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, because that's too much bloat. But when they are -;;;; called, it's unreasonable to just punt to interpreted TYPEP, -;;;; because that's unreasonably slow. The system implemented here -;;;; tries to be a reasonable compromise 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, i.e. a typecheckfun. 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 typecheckfuns, so that -;;;; the dozens of slot accessors which have e.g. :TYPE SYMBOL can all -;;;; share the same typecheckfun instead of having to keep dozens of -;;;; equivalent typecheckfun copies floating around. We can also pull -;;;; a few other tricks to reduce bloat, like implementing all -;;;; typecheckfuns 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 - -;;; initialization value for *COMMON-TYPESPECS* -(eval-when (:compile-toplevel) - (defvar *compile-time-common-typespecs* - (let (;; When we generate collections of common specialized - ;; array types, what should their element types be? - (common-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 - #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (unsigned-byte 32) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (unsigned-byte 64) - #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (signed-byte 32) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (signed-byte 64) - single-float double-float))) - (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) - #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (unsigned-byte 32) - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - (unsigned-byte 64)) - ;; systematic names for array types - (map 'list - (lambda (element-type) - `(simple-array ,element-type 1)) - common-element-typespecs) - (map 'list - (lambda (element-type) - `(vector ,element-type)) - common-element-typespecs) - ;; idiosyncratic names for array types - '(simple-vector - bit-vector simple-bit-vector - string simple-string))) - :test #'equal) - 'simple-vector)))) - -;;; What are the common 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. Hopefully this will reduce -;;; compile time and object file bloat.) -(declaim (type simple-vector *common-typespecs*)) -(defvar *common-typespecs*) -#-sb-xc (eval-when (:compile-toplevel :load-toplevel :execute) - (setf *common-typespecs* - #.*compile-time-common-typespecs*)) -;; (#+SB-XC initialization is handled elsewhere, at cold init time.) - -(defun ctype-is-common-typecheckfun-type-p (ctype) - (position (type-specifier ctype) *common-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* - #-sb-xc (make-hash-table :test 'equal) - ;; (#+SB-XC initialization is handled elsewhere, at cold init time.) - ) - -;;; Memoize the FORM which returns a typecheckfun for TYPESPEC. -(defmacro memoized-typecheckfun-form (form typespec) - (with-unique-names (n-typespec) - `(let ((,n-typespec ,typespec)) - (or (gethash ,n-typespec *typecheckfuns*) - (setf (gethash ,n-typespec *typecheckfuns*) - ,form))))) - -#+sb-xc -(defun !typecheckfuns-cold-init () - (/show0 "in typecheckfuns-cold-init") - (setf *typecheckfuns* (make-hash-table :test 'equal)) - ;; Initialize the table of common typespecs. - (setf *common-typespecs* #.*compile-time-common-typespecs*) - ;; Initialize *TYPECHECKFUNS* with typecheckfuns for common typespecs. - (/show0 "typecheckfuns-cold-init initial setfs done") - (macrolet ((macro () - `(progn - ,@(map 'list - (lambda (typespec) - `(progn - (/show0 "setf") - (setf (gethash ',typespec *typecheckfuns*) - (progn - (/show0 "lambda") - (lambda (arg) - (unless (typep arg ',typespec) - (typecheck-failure arg ',typespec)) - (values)))))) - *common-typespecs*)))) - (macro)) - (values)) - -;;; 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. - (bug "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 - ;; (DEFINE-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) - *common-typespecs* - :test #'equal) - (member-type-p ctype) - (numeric-type-p ctype) - (array-type-p ctype) - (cons-type-p ctype) - #!+sb-simd-pack - (simd-pack-type-p ctype) - (intersection-type-p ctype) - (union-type-p ctype) - (negation-type-p ctype) - (character-set-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 (sfunction (t) function) typespec-typecheckfun)) -(defun typespec-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 typespec-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-classoid-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-common-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 -- 2.11.4.GIT