(declaim (special *universal-type*))
;;; This is sorta semantically equivalent to SXHASH, but optimized for
-;;; legal function names. Note: semantically equivalent does *not*
-;;; mean that it always returns the same value as SXHASH, just that it
-;;; satisfies the formal definition of SXHASH. The ``sorta'' is
-;;; because SYMBOL-HASH will not necessarily return the same value in
-;;; different lisp images.
+;;; legal function names.
;;;
;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary
;;; SXHASH, because
;;; aren't used too early in cold boot for SXHASH to run).
#!-sb-fluid (declaim (inline globaldb-sxhashoid))
(defun globaldb-sxhashoid (x)
- (cond #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
- ((symbolp x)
- (symbol-hash x))
- #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
- ((and (listp x)
- (eq (first x) 'setf)
- (let ((rest (rest x)))
- (and (symbolp (car rest))
- (null (cdr rest)))))
- (logxor (symbol-hash (second x))
- 110680597))
- (t (sxhash x))))
+ (logand sb!xc:most-positive-fixnum
+ (cond ((symbolp x) (sxhash x))
+ ((and (listp x)
+ (eq (first x) 'setf)
+ (let ((rest (rest x)))
+ (and (symbolp (car rest))
+ (null (cdr rest)))))
+ ;; We need to declare the type of the value we're feeding to
+ ;; SXHASH so that the DEFTRANSFORM on symbols kicks in.
+ (let ((symbol (second x)))
+ (declare (symbol symbol))
+ (logxor (sxhash symbol) 110680597)))
+ (t (sxhash x)))))
;;; Given any non-negative integer, return a prime number >= to it.
;;;
;; a number that uniquely identifies this type (and implicitly its class)
(number (missing-arg) :type type-number)
;; a type specifier which info of this type must satisfy
- (type nil :type t)
+ (type nil :type t)
;; a function called when there is no information of this type
- (default (lambda () (error "type not defined yet")) :type function))
+ (default (lambda () (error "type not defined yet")) :type function)
+ ;; called by (SETF INFO) before calling SET-INFO-VALUE
+ (validate-function nil :type (or function null)))
;;; a map from class names to CLASS-INFO structures
;;;
;;; order in which the TYPE-INFO-creation forms are generated doesn't
;;; match the relative order in which the forms need to be executed at
;;; cold load time.
-(defparameter *reversed-type-info-init-forms* nil)
+(defparameter *!reversed-type-info-init-forms* nil)
;;; Define a new type of global information for CLASS. TYPE is the
;;; name of the type, DEFAULT is the value for that type when it
define-info-type (&key (class (missing-arg))
(type (missing-arg))
(type-spec (missing-arg))
+ (validate-function)
default)
(declare (type keyword class type))
`(progn
;; values differ in the use of SB!XC symbols instead of CL
;; symbols.)
(push `(let ((type-info (type-info-or-lose ,',class ,',type)))
+ (setf (type-info-validate-function type-info)
+ ,',validate-function)
(setf (type-info-default type-info)
;; FIXME: This code is sort of nasty. It would
;; be cleaner if DEFAULT accepted a real
(declare (ignorable name))
,',default))
(setf (type-info-type type-info) ',',type-spec))
- *reversed-type-info-init-forms*))
+ *!reversed-type-info-init-forms*))
',type))
) ; EVAL-WHEN
(n-info-types '*info-types*))
`(dotimes (,n-index (length ,n-table))
(declare (type index ,n-index))
- (block ,PUNT
+ (block ,punt
(let ((,name-var (svref ,n-table ,n-index)))
(unless (eql ,name-var 0)
(do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
,@body
(unless (zerop (logand ,n-info
compact-info-entry-last))
- (return-from ,PUNT))))))))))))))
+ (return-from ,punt))))))))))))))
;;; Return code to iterate over a volatile info environment.
(defun do-volatile-info (name-var class-var type-var type-number-var value-var
;;;; compact info environments
;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
-(def!constant compact-info-env-entries-bits 16)
+;;;
+;;; "Why (U-B 28)?", you might wonder. Originally this was (U-B 16),
+;;; presumably to ensure that the arrays of :ELEMENT-TYPE
+;;; COMPACT-INFO-ENTRIES-INDEX could use a more space-efficient representation.
+;;; It turns out that a environment of of only 65536 entries is insufficient in
+;;; the modern world (see message from Cyrus Harmon to sbcl-devel, "Subject:
+;;; purify failure when compact-info-env-entries-bits is too small"). Using
+;;; (U-B 28) instead of (U-B 29) is to avoid the need for bignum overflow
+;;; checks, a probably pointless micro-optimization. Hardcoding the amount of
+;;; bits instead of deriving it from SB!VM::N-WORD-BITS is done to allow
+;;; use of a more efficient array representation on 64-bit platforms.
+;;; -- JES, 2005-04-06
+(def!constant compact-info-env-entries-bits 28)
(deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
;;; the type of the values in COMPACT-INFO-ENTRIES-INFO
;;; Encache NAME in the compact environment ENV. HASH is the
;;; GLOBALDB-SXHASHOID of NAME.
(defun compact-info-lookup (env name hash)
- (declare (type compact-info-env env) (type index hash))
+ (declare (type compact-info-env env)
+ (type (integer 0 #.sb!xc:most-positive-fixnum) hash))
(let* ((table (compact-info-env-table env))
(len (length table))
(len-2 (- len 2))
;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
(defun volatile-info-lookup (env name hash)
- (declare (type volatile-info-env env) (type index hash))
+ (declare (type volatile-info-env env)
+ (type (integer 0 #.sb!xc:most-positive-fixnum) hash))
(let ((table (volatile-info-env-table env)))
(macrolet ((lookup (test)
`(dolist (entry (svref table (mod hash (length table))) ())
(lookup eq)
(lookup equal)))
(setf (volatile-info-env-cache-name env) name)))
-
(values))
;;; Given a volatile environment ENV, bind TABLE-VAR the environment's table
&optional (env-list nil env-list-p))
(let* ((info (type-info-or-lose class type))
(tin (type-info-number info)))
+ (when (type-info-validate-function info)
+ (funcall (type-info-validate-function info) name new-value))
(if env-list-p
(set-info-value name
tin
;;; the current environment, allowing any inherited info to become
;;; visible. We return true if there was any info.
(defun clear-info (class type name)
- #!+sb-doc
(let ((info (type-info-or-lose class type)))
(clear-info-value name (type-info-number info))))
#!-sb-fluid
:type :kind
:type-spec (member :primitive :defined :instance
:forthcoming-defclass-type nil)
- :default nil)
+ :default nil
+ :validate-function (lambda (name new-value)
+ (declare (ignore new-value)
+ (notinline info))
+ (when (info :declaration :recognized name)
+ (error 'declaration-type-conflict-error
+ :format-arguments (list name)))))
;;; the expander function for a defined type
(define-info-type
:type :info
:type-spec t
:default nil)
+(define-info-type
+ :class :typed-structure
+ :type :documentation
+ :type-spec (or string null)
+ :default nil)
(define-info-class :declaration)
(define-info-type
:class :declaration
:type :recognized
- :type-spec boolean)
+ :type-spec boolean
+ :validate-function (lambda (name new-value)
+ (declare (ignore new-value)
+ (notinline info))
+ (when (info :type :kind name)
+ (error 'declaration-type-conflict-error
+ :format-arguments (list name)))))
(define-info-class :alien-type)
(define-info-type
;;; we can set their DEFAULT and TYPE slots.
(macrolet ((frob ()
`(!cold-init-forms
- ,@(reverse *reversed-type-info-init-forms*))))
+ ,@(reverse *!reversed-type-info-init-forms*))))
(frob))
\f
;;;; a hack for detecting
projects / sbcl.git / blobdiff