X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypecheckfuns.lisp;h=8fe8217c06ebc13bd7359dcd45557769c2eb4190;hb=a4cffc065c83d046fce193919bf6d4e53f181455;hp=f8253cc30e3acba14c0dc9320785456e02cb08b7;hpb=942e5de3f3e27e1cc6ae4aae69c040fa1dc7db00;p=sbcl.git diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp index f8253cc..8fe8217 100644 --- a/src/code/typecheckfuns.lisp +++ b/src/code/typecheckfuns.lisp @@ -3,7 +3,7 @@ ;;;; 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 +;;;; 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, @@ -39,60 +39,71 @@ (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 (unsigned-byte 32) (signed-byte 32) - single-float double-float))) + ;; 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) - (unsigned-byte 32)) - ;; 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)))) + (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 @@ -102,13 +113,13 @@ (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*)) + (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)) + :test #'equal)) (defun typecheck-failure (arg typespec) (error 'type-error :datum arg :expected-type typespec)) @@ -125,25 +136,31 @@ (with-unique-names (n-typespec) `(let ((,n-typespec ,typespec)) (or (gethash ,n-typespec *typecheckfuns*) - (setf (gethash ,n-typespec *typecheckfuns*) - ,form))))) + (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) - `(setf (gethash ',typespec *typecheckfuns*) - (lambda (arg) - (unless (typep arg ',typespec) - (typecheck-failure arg ',typespec)) - (values)))) - *common-typespecs*)))) + `(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)) @@ -151,7 +168,7 @@ ;;; 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 + ;; user could do ;; (DEFSTRUCT FOO (X NIL :TYPE XYTYPE)) ;; (DEFTYPE XYTYPE () (OR SYMBOL CHARACTER)) ;; (DEFSTRUCT BAR (Y NIL :TYPE XYTYPE)) @@ -171,11 +188,11 @@ (let ((layout (compiler-layout-or-lose typespec))) (lambda (arg) (unless (typep-to-layout arg layout) - (typecheck-failure arg typespec)) + (typecheck-failure arg typespec)) (values)))) (defun structure-object-typecheckfun (typespec) (memoized-typecheckfun-form (%structure-object-typecheckfun typespec) - typespec)) + typespec)) ;;; General type checks need the full compiler, not just stereotyped ;;; closures. We arrange for UNMEMOIZED-TYPECHECKFUN to be produced @@ -194,12 +211,16 @@ ;; 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)))) + *common-typespecs* + :test #'equal) + (member-type-p ctype) + (numeric-type-p ctype) + (array-type-p ctype) + (cons-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. @@ -217,36 +238,36 @@ ;;; 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)) + (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)))))))))) + (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