(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.
;;;
;;; At run time, we represent the type of info that we want by a small
;;; non-negative integer.
-(defconstant type-number-bits 6)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def!constant type-number-bits 6))
(deftype type-number () `(unsigned-byte ,type-number-bits))
;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
(:print-object (lambda (x s)
(print-unreadable-object (x s)
(format s
- "~S ~S, Number = ~D"
+ "~S ~S, Number = ~W"
(class-info-name (type-info-class x))
(type-info-name x)
(type-info-number x)))))
(:copier nil))
;; the name of this type
- (name (required-argument) :type keyword)
+ (name (missing-arg) :type keyword)
;; this type's class
- (class (required-argument) :type class-info)
+ (class (missing-arg) :type class-info)
;; a number that uniquely identifies this type (and implicitly its class)
- (number (required-argument) :type type-number)
+ (number (missing-arg) :type type-number)
;; a type specifier which info of this type must satisfy
(type nil :type t)
;; a function called when there is no information of this type
;;; 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
;;; calls to %DEFINE-INFO-TYPE must use the same type number.
(#+sb-xc-host defmacro
#-sb-xc-host sb!xc:defmacro
- define-info-type (&key (class (required-argument))
- (type (required-argument))
- (type-spec (required-argument))
+ define-info-type (&key (class (missing-arg))
+ (type (missing-arg))
+ (type-spec (missing-arg))
default)
(declare (type keyword class type))
`(progn
(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
(:copier nil))
;; some string describing what is in this environment, for
;; printing/debugging purposes only
- (name (required-argument) :type string))
+ (name (missing-arg) :type string))
(def!method print-object ((x info-env) stream)
(print-unreadable-object (x stream :type t)
(prin1 (info-env-name x) stream)))
,(do-compact-info name class type type-number value
n-env body)))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; Return code to iterate over a compact info environment.
(defun do-compact-info (name-var class-var type-var type-number-var value-var
(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.
-(defconstant 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
(cache-index nil :type (or compact-info-entries-index null))
;; hashtable of the names in this environment. If a bucket is
;; unused, it is 0.
- (table (required-argument) :type simple-vector)
+ (table (missing-arg) :type simple-vector)
;; an indirection vector parallel to TABLE, translating indices in
;; TABLE to the start of the ENTRIES for that name. Unused entries
;; are undefined.
- (index (required-argument)
- :type (simple-array compact-info-entries-index (*)))
+ (index (missing-arg) :type (simple-array compact-info-entries-index (*)))
;; a vector contining in contiguous ranges the values of for all the
;; types of info for each name.
- (entries (required-argument) :type simple-vector)
+ (entries (missing-arg) :type simple-vector)
;; a vector parallel to ENTRIES, indicating the type number for the
;; value stored in that location and whether this location is the
;; last type of info stored for this name. The type number is in the
;; low TYPE-NUMBER-BITS bits, and the next bit is set if this is the
;; last entry.
- (entries-info (required-argument)
- :type (simple-array compact-info-entry (*))))
+ (entries-info (missing-arg) :type (simple-array compact-info-entry (*))))
-(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
-(defconstant compact-info-entry-last (ash 1 type-number-bits))
+(def!constant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
+(def!constant compact-info-entry-last (ash 1 type-number-bits))
;;; Return the value of the type corresponding to NUMBER for the
;;; currently cached name in ENV.
;;; 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))
;;; the exact density (modulo rounding) of the hashtable in a compact
;;; info environment in names/bucket
-(defconstant compact-info-environment-density 65)
+(def!constant compact-info-environment-density 65)
;;; Return a new compact info environment that holds the same
;;; information as ENV.
(cache-types nil :type list)
;; vector of alists of alists of the form:
;; ((Name . ((Type-Number . Value) ...) ...)
- (table (required-argument) :type simple-vector)
+ (table (missing-arg) :type simple-vector)
;; the number of distinct names currently in this table. Each name
;; may have multiple entries, since there can be many types of info.
(count 0 :type index)
;;; 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
-;;; and Index-Var to the index of Name's bucket in the table. We also flush
+;;; Given a volatile environment ENV, bind TABLE-VAR the environment's table
+;;; and INDEX-VAR to the index of NAME's bucket in the table. We also flush
;;; the cache so that things will be consistent if body modifies something.
(eval-when (:compile-toplevel :execute)
(#+sb-xc-host cl:defmacro
;; Constant CLASS and TYPE is an overwhelmingly common special case,
;; and we can implement it much more efficiently than the general case.
(if (and (constantp class) (constantp type))
- (let ((info (type-info-or-lose class type))
- (value (gensym "VALUE"))
- (foundp (gensym "FOUNDP")))
- `(multiple-value-bind (,value ,foundp)
- (get-info-value ,name
- ,(type-info-number info)
- ,@(when env-list-p `(,env-list)))
- (values (the ,(type-info-type info) ,value)
- ,foundp)))
+ (let ((info (type-info-or-lose class type)))
+ (with-unique-names (value foundp)
+ `(multiple-value-bind (,value ,foundp)
+ (get-info-value ,name
+ ,(type-info-number info)
+ ,@(when env-list-p `(,env-list)))
+ (declare (type ,(type-info-type info) ,value))
+ (values ,value ,foundp))))
whole))
(defun (setf info) (new-value
class
(let* ((info (type-info-or-lose class type))
(tin (type-info-number info)))
(if env-list-p
- (set-info-value name
- tin
- new-value
- (get-write-info-env env-list))
- (set-info-value name
- tin
- new-value)))
+ (set-info-value name
+ tin
+ new-value
+ (get-write-info-env env-list))
+ (set-info-value name
+ tin
+ new-value)))
new-value)
;;; FIXME: We'd like to do this, but Python doesn't support
;;; compiler macros and it's hard to change it so that it does.
;;;
;;; FIXME: actually seems to be measured in percent, should be
;;; converted to be measured in names/bucket
-(defconstant volatile-info-environment-density 50)
+(def!constant volatile-info-environment-density 50)
;;; Make a new volatile environment of the specified size.
(defun make-info-environment (&key (size 42) (name "Unknown"))
;;; 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
;; (or approximate-fun-type null)).
;; It was changed to T as a hopefully-temporary hack while getting
;; cold init problems untangled.
- :type-spec t)
+ :type-spec t)
;;; where this information came from:
;;; :ASSUMED = from uses of the object
:type :inline-expansion-designator
:type-spec (or list function)
:default nil)
-;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
-;;; value into a lambda expression, or return NIL if there is none.
-(declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion))
-(defun fun-name-inline-expansion (fun-name)
- (let ((info (info :function :inline-expansion-designator fun-name)))
- (if (functionp info)
- (funcall info)
- info)))
;;; This specifies whether this function may be expanded inline. If
;;; null, we don't care.
:type :ir1-convert
:type-spec (or function null))
-;;; a function which gets a chance to do stuff to the IR1 for any call
-;;; to this function.
-(define-info-type
- :class :function
- :type :ir1-transform
- :type-spec (or function null))
-
-;;; If a function is "known" to the compiler, then this is a
-;;; FUNCTION-INFO structure containing the info used to special-case
-;;; compilation.
+;;; If a function is "known" to the compiler, then this is a FUN-INFO
+;;; structure containing the info used to special-case compilation.
(define-info-type
:class :function
:type :info
- :type-spec (or function-info null)
+ :type-spec (or fun-info null)
:default nil)
(define-info-type
(define-info-type
:class :function
:type :definition
- :type-spec t
+ :type-spec (or fdefn null)
:default nil)
\f
;;;; definitions for other miscellaneous information
(define-info-type
:class :variable
:type :kind
- :type-spec (member :special :constant :global :alien)
+ :type-spec (member :special :constant :macro :global :alien)
:default (if (symbol-self-evaluating-p name)
:constant
:global))
;; instead.
:default (if (symbol-self-evaluating-p name)
name
- (error "internal error: constant lookup of nonconstant ~S"
- name)))
+ (bug "constant lookup of nonconstant ~S" name)))
+
+;;; the macro-expansion for symbol-macros
+(define-info-type
+ :class :variable
+ :type :macro-expansion
+ :type-spec t
+ :default nil)
(define-info-type
:class :variable
(define-info-class :type)
;;; the kind of type described. We return :INSTANCE for standard types
-;;; that are implemented as structures.
+;;; that are implemented as structures. For PCL classes, that have
+;;; only been compiled, but not loaded yet, we return
+;;; :FORTHCOMING-DEFCLASS-TYPE.
(define-info-type
:class :type
:type :kind
- :type-spec (member :primitive :defined :instance nil)
+ :type-spec (member :primitive :defined :instance
+ :forthcoming-defclass-type nil)
:default nil)
;;; the expander function for a defined type
;;; If this is a class name, then the value is a cons (NAME . CLASS),
;;; where CLASS may be null if the class hasn't been defined yet. Note
;;; that for built-in classes, the kind may be :PRIMITIVE and not
-;;; :INSTANCE. The the name is in the cons so that we can signal a
+;;; :INSTANCE. The name is in the cons so that we can signal a
;;; meaningful error if we only have the cons.
(define-info-type
:class :type
- :type :class
- :type-spec (or sb!kernel::class-cell null)
+ :type :classoid
+ :type-spec (or sb!kernel::classoid-cell null)
:default nil)
;;; layout for this type being used by the compiler
:class :type
:type :compiler-layout
:type-spec (or layout null)
- :default (let ((class (sb!xc:find-class name nil)))
- (when class (class-layout class))))
+ :default (let ((class (find-classoid name nil)))
+ (when class (classoid-layout class))))
(define-info-class :typed-structure)
(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
;;; 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