#-no-ansi-print-object
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
- (prin1 (class-info-name x)))))
+ (prin1 (class-info-name x) s))))
(:copier nil))
;; name of this class
(name nil :type keyword :read-only t)
(new-type-info
(make-type-info :name ',type
:class class-info
- :number new-type-number)))
+ :number new-type-number
+ :type ',type-spec)))
(setf (aref *info-types* new-type-number) new-type-info)
(push new-type-info (class-info-types class-info)))))
- ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
- ;; at cold load time. (They can't very well be set at
- ;; cross-compile time, since they differ between the
- ;; cross-compiler and the target. The DEFAULT slot values
- ;; differ because they're compiled closures, and the TYPE slot
- ;; values differ in the use of SB!XC symbols instead of CL
- ;; symbols.)
+ ;; Arrange for TYPE-INFO-DEFAULT and
+ ;; TYPE-INFO-VALIDATE-FUNCTION to be set at cold load
+ ;; time. (They can't very well be set at cross-compile time,
+ ;; since they differ between host and target and are
+ ;; host-compiled closures.)
(push `(let ((type-info (type-info-or-lose ,',class ,',type)))
(setf (type-info-validate-function type-info)
,',validate-function)
;; NIL) instead of full-blown (LAMBDA (X) NIL).
(lambda (name)
(declare (ignorable name))
- ,',default))
- (setf (type-info-type type-info) ',',type-spec))
+ ,',default)))
*!reversed-type-info-init-forms*))
',type))
\f
;;;; generic info environments
-;;; Note: the CACHE-NAME slot is deliberately not shared for
-;;; bootstrapping reasons. If we access with accessors for the exact
-;;; type, then the inline type check will win. If the inline check
-;;; didn't win, we would try to use the type system before it was
-;;; properly initialized.
(defstruct (info-env (:constructor nil)
(:copier nil))
;; some string describing what is in this environment, for
\f
;;;; generic interfaces
-;;; FIXME: used only in this file, needn't be in runtime
(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
(type-number (gensym)) (value (gensym)) known-volatile)
&body body)
) ; EVAL-WHEN
\f
-;;;; INFO cache
-;;;; We use a hash cache to cache name X type => value for the current
-;;;; value of *INFO-ENVIRONMENT*. This is in addition to the
-;;;; per-environment caching of name => types.
-
-;;; The value of *INFO-ENVIRONMENT* that has cached values.
-;;; *INFO-ENVIRONMENT* should never be destructively modified, so if
-;;; it is EQ to this, then the cache is valid.
-(defvar *cached-info-environment*)
-(!cold-init-forms
- (setf *cached-info-environment* nil))
-
-;;; the hash function used for the INFO cache
-#!-sb-fluid (declaim (inline info-cache-hash))
-(defun info-cache-hash (name type)
- (logand
- (the fixnum
- (logxor (globaldb-sxhashoid name)
- (ash (the fixnum type) 7)))
- #x3FF))
-
-(!cold-init-forms
- (/show0 "before initialization of INFO hash cache"))
-(define-hash-cache info ((name eq) (type eq))
- :values 2
- :hash-function info-cache-hash
- :hash-bits 10
- :default (values nil :empty)
- :init-wrapper !cold-init-forms)
-(!cold-init-forms
- (/show0 "clearing INFO hash cache")
- (info-cache-clear)
- (/show0 "done clearing INFO hash cache"))
-
-;;; If the info cache is invalid, then clear it.
-#!-sb-fluid (declaim (inline clear-invalid-info-cache))
-(defun clear-invalid-info-cache ()
- ;; Unless the cache is valid..
- (unless (eq *info-environment* *cached-info-environment*)
- (;; In the target Lisp, this should be done without interrupts,
- ;; but in the host Lisp when cross-compiling, we don't need to
- ;; sweat it, since no affected-by-GC hashes should be used when
- ;; running under the host Lisp (since that's non-portable) and
- ;; since only one thread should be used when running under the
- ;; host Lisp (because multiple threads are non-portable too).
- #-sb-xc-host without-interrupts
- #+sb-xc-host progn
- (info-cache-clear)
- (setq *cached-info-environment* *info-environment*))))
-\f
;;;; compact info environments
;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
(defstruct (compact-info-env (:include info-env)
#-sb-xc-host (:pure :substructure)
(:copier nil))
- ;; If this value is EQ to the name we want to look up, then the
- ;; cache hit function can be called instead of the lookup function.
- (cache-name 0)
- ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has
- ;; no entries.
- (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 (missing-arg) :type simple-vector)
(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.
-#!-sb-fluid (declaim (inline compact-info-cache-hit))
-(defun compact-info-cache-hit (env number)
+;;; index INDEX in ENV.
+#!-sb-fluid (declaim (inline compact-info-lookup-index))
+(defun compact-info-lookup-index (env number index)
(declare (type compact-info-env env) (type type-number number))
- (let ((entries-info (compact-info-env-entries-info env))
- (index (compact-info-env-cache-index env)))
+ (let ((entries-info (compact-info-env-entries-info env)))
(if index
(do ((index index (1+ index)))
(nil)
(return (values nil nil)))))
(values nil nil))))
-;;; Encache NAME in the compact environment ENV. HASH is the
+;;; Look up NAME in the compact environment ENV. HASH is the
;;; GLOBALDB-SXHASHOID of NAME.
-(defun compact-info-lookup (env name hash)
+(defun compact-info-lookup (env name hash number)
(declare (type compact-info-env env)
(type (integer 0 #.sb!xc:most-positive-fixnum) hash))
(let* ((table (compact-info-env-table env))
(when (eql entry 0)
(return nil))
(when (,test entry name)
- (return (aref (compact-info-env-index env)
- probe)))))))
- (setf (compact-info-env-cache-index env)
- (if (symbolp name)
- (lookup eq)
- (lookup equal)))
- (setf (compact-info-env-cache-name env) name)))
-
- (values))
+ (return (compact-info-lookup-index
+ env
+ number
+ (aref (compact-info-env-index env) probe))))))))
+ (if (symbolp name)
+ (lookup eq)
+ (lookup equal)))))
;;; the exact density (modulo rounding) of the hashtable in a compact
;;; info environment in names/bucket
:element-type 'compact-info-entry))
(sorted (sort (names)
#+sb-xc-host #'<
- ;; (This MAKE-FIXNUM hack implements
- ;; pointer comparison, as explained above.)
+ ;; POINTER-HASH hack implements pointer
+ ;; comparison, as explained above.
#-sb-xc-host (lambda (x y)
- (< (%primitive make-fixnum x)
- (%primitive make-fixnum y))))))
+ (< (pointer-hash x)
+ (pointer-hash y))))))
(/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT")
(let ((entries-idx 0))
(dolist (types sorted)
;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size.
(defstruct (volatile-info-env (:include info-env)
(:copier nil))
- ;; If this value is EQ to the name we want to look up, then the
- ;; cache hit function can be called instead of the lookup function.
- (cache-name 0)
- ;; the alist translating type numbers to values for the currently
- ;; cached name
- (cache-types nil :type list)
;; vector of alists of alists of the form:
;; ((Name . ((Type-Number . Value) ...) ...)
(table (missing-arg) :type simple-vector)
;; the number of names at which we should grow the table and rehash
(threshold 0 :type index))
-;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
-#!-sb-fluid (declaim (inline volatile-info-cache-hit))
-(defun volatile-info-cache-hit (env number)
- (declare (type volatile-info-env env) (type type-number number))
- (dolist (type (volatile-info-env-cache-types env) (values nil nil))
- (when (eql (car type) number)
- (return (values (cdr type) t)))))
-
;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
-(defun volatile-info-lookup (env name hash)
+(defun volatile-info-lookup (env name hash number)
(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))) ())
(when (,test (car entry) name)
- (return (cdr entry))))))
- (setf (volatile-info-env-cache-types env)
- (if (symbolp name)
- (lookup eq)
- (lookup equal)))
- (setf (volatile-info-env-cache-name env) name)))
- (values))
+ (dolist (type (cdr entry))
+ (when (eql (car type) number)
+ (return-from volatile-info-lookup
+ (values (cdr type) t))))
+ (return-from volatile-info-lookup
+ (values nil nil))))))
+ (if (symbolp name)
+ (lookup eq)
+ (lookup equal)))))
;;; 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.
+;;; and INDEX-VAR to the index of NAME's bucket in the table.
(eval-when (:compile-toplevel :execute)
(#+sb-xc-host cl:defmacro
#-sb-xc-host sb!xc:defmacro
(once-only ((n-name name)
(n-env env))
`(progn
- (setf (volatile-info-env-cache-name ,n-env) 0)
(let* ((,table-var (volatile-info-env-table ,n-env))
(,index-var (mod (globaldb-sxhashoid ,n-name)
(length ,table-var))))
(let ((name (uncross name0)))
(when (eql name 0)
(error "0 is not a legal INFO name."))
- ;; We don't enter the value in the cache because we don't know that this
- ;; info-environment is part of *cached-info-environment*.
- (info-cache-enter name type nil :empty)
(with-info-bucket (table index name env)
(let ((types (if (symbolp name)
(assoc name (svref table index) :test #'eq)
(&whole whole class type name &optional (env-list nil env-list-p))
;; 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)))
+ (if (and (keywordp class) (keywordp type))
+ (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+ (info (type-info-or-lose class type)))
(with-unique-names (value foundp)
`(multiple-value-bind (,value ,foundp)
(get-info-value ,name
(declare (type ,(type-info-type info) ,value))
(values ,value ,foundp))))
whole))
-(defun (setf info) (new-value
- class
- type
- name
- &optional (env-list nil env-list-p))
+
+(defun (setf info)
+ (new-value class type name &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)
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.
-;;; It might make more sense to just convert INFO :FOO :BAR into
-;;; an ordinary function, so that instead of calling INFO :FOO :BAR
-;;; you call e.g. INFO%FOO%BAR. Then dynamic linking could be handled
-;;; by the ordinary Lisp mechanisms and we wouldn't have to maintain
-;;; all this cruft..
-#|
#!-sb-fluid
(progn
- (define-compiler-macro (setf info) (&whole whole
- new-value
- class
- type
- name
- &optional (env-list nil env-list-p))
- ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
- ;; can resolve it much more efficiently than the general case.
- (if (and (constantp class) (constantp type))
+ ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19
+ ;; does not accept them at all, and older SBCLs give a full warning.
+ ;; So the easy thing is to hide this optimization from all xc hosts.
+ #-sb-xc-host
+ (define-compiler-macro (setf info)
+ (&whole whole new-value class type name &optional (env-list nil env-list-p))
+ ;; Constant CLASS and TYPE is an overwhelmingly common special case,
+ ;; and we can resolve it much more efficiently than the general
+ ;; case.
+ (if (and (keywordp class) (keywordp type))
(let* ((info (type-info-or-lose class type))
(tin (type-info-number info)))
(if env-list-p
(get-write-info-env ,env-list))
`(set-info-value ,name
,tin
- ,new-value)))
- whole)))
-|#
+ ,new-value))))
+ whole))
;;; the maximum density of the hashtable in a volatile env (in
;;; names/bucket)
whole))
(defun clear-info-value (name type)
(declare (type type-number type) (inline assoc))
- (clear-invalid-info-cache)
- (info-cache-enter name type nil :empty)
(with-info-bucket (table index name (get-write-info-env))
(let ((types (assoc name (svref table index) :test #'equal)))
(when (and types
\f
;;;; GET-INFO-VALUE
-;;; Check whether the name and type is in our cache, if so return it.
-;;; Otherwise, search for the value and encache it.
-;;;
-;;; Return the value from the first environment which has it defined,
-;;; or return the default if none does. We have a cache for the last
-;;; name looked up in each environment. We don't compute the hash
-;;; until the first time the cache misses. When the cache does miss,
-;;; we invalidate it before calling the lookup routine to eliminate
-;;; the possibility of the cache being partially updated if the lookup
-;;; is interrupted.
+;;; Return the value of NAME / TYPE from the first environment where
+;;; has it defined, or return the default if none does. We used to
+;;; do a lot of complicated caching here, but that was removed for
+;;; thread-safety reasons.
(defun get-info-value (name0 type &optional (env-list nil env-list-p))
(declare (type type-number type))
;; sanity check: If we have screwed up initialization somehow, then
;; sbcl-0.pre7.x.)
(aver (aref *info-types* type))
(let ((name (uncross name0)))
- (flet ((lookup-ignoring-global-cache (env-list)
+ (flet ((lookup (env-list)
(let ((hash nil))
(dolist (env env-list
- (multiple-value-bind (val winp)
- (funcall (type-info-default
- (svref *info-types* type))
- name)
- (values val winp)))
- (macrolet ((frob (lookup cache slot)
+ (multiple-value-bind (val winp)
+ (funcall (type-info-default
+ (svref *info-types* type))
+ name)
+ (values val winp)))
+ (macrolet ((frob (lookup)
`(progn
- (unless (eq name (,slot env))
- (unless hash
- (setq hash (globaldb-sxhashoid name)))
- (setf (,slot env) 0)
- (,lookup env name hash))
+ (setq hash (globaldb-sxhashoid name))
(multiple-value-bind (value winp)
- (,cache env type)
+ (,lookup env name hash type)
(when winp (return (values value t)))))))
(etypecase env
- (volatile-info-env (frob
- volatile-info-lookup
- volatile-info-cache-hit
- volatile-info-env-cache-name))
- (compact-info-env (frob
- compact-info-lookup
- compact-info-cache-hit
- compact-info-env-cache-name))))))))
- (cond (env-list-p
- (lookup-ignoring-global-cache env-list))
- (t
- (clear-invalid-info-cache)
- (multiple-value-bind (val winp) (info-cache-lookup name type)
- (if (eq winp :empty)
- (multiple-value-bind (val winp)
- (lookup-ignoring-global-cache *info-environment*)
- (info-cache-enter name type val winp)
- (values val winp))
- (values val winp))))))))
+ (volatile-info-env (frob volatile-info-lookup))
+ (compact-info-env (frob compact-info-lookup))))))))
+ (if env-list-p
+ (lookup env-list)
+ (lookup *info-environment*)))))
\f
;;;; definitions for function information
:default
#+sb-xc-host (specifier-type 'function)
#-sb-xc-host (if (fboundp name)
- (extract-fun-type (fdefinition name))
+ (handler-bind ((style-warning #'muffle-warning))
+ (specifier-type (sb!impl::%fun-type (fdefinition name))))
(specifier-type 'function)))
;;; the ASSUMED-TYPE for this function, if we have to infer the type
;;; where this information came from:
;;; :ASSUMED = from uses of the object
;;; :DEFINED = from examination of the definition
+;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
;;; :DECLARED = from a declaration
-;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
+;;; and :DECLARED trumps :DEFINED-METHOD.
;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
-;;; and :DECLARED is useful for ANSIly specializing code which
-;;; implements the function, or which uses the function's return values.
+;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
+;;; code which implements the function, or which uses the function's
+;;; return values.
(define-info-type
:class :function
:type :where-from
- :type-spec (member :declared :assumed :defined)
+ :type-spec (member :declared :defined-method :assumed :defined)
:default
;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
;; not clear how to generalize the FBOUNDP expression to the
(define-info-type
:class :function
- :type :documentation
- :type-spec (or string null)
+ :type :definition
+ :type-spec (or fdefn null)
:default nil)
(define-info-type
:class :function
- :type :definition
- :type-spec (or fdefn null)
+ :type :structure-accessor
+ :type-spec (or defstruct-description null)
:default nil)
\f
;;;; definitions for other miscellaneous information
(define-info-type
:class :variable
:type :kind
- :type-spec (member :special :constant :macro :global :alien)
- :default (if (symbol-self-evaluating-p name)
+ :type-spec (member :special :constant :macro :global :alien :unknown)
+ :default (if (typep name '(or boolean keyword))
:constant
- :global))
+ :unknown))
+
+(define-info-type
+ :class :variable
+ :type :always-bound
+ :type-spec boolean
+ :default nil)
;;; the declared type for this variable
(define-info-type
:type-spec (member :declared :assumed :defined)
:default :assumed)
-;;; the Lisp object which is the value of this constant, if known
+;;; We only need a mechanism different from the
+;;; usual SYMBOL-VALUE for the cross compiler.
+#+sb-xc-host
(define-info-type
:class :variable
- :type :constant-value
+ :type :xc-constant-value
:type-spec t
- ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..).
- ;; Now we don't: it was the last remaining multiple-value return from
- ;; the INFO system, and bringing it down to one value lets us simplify
- ;; things, especially simplifying the declaration of return types.
- ;; Software which used to check the second value (for "is it defined
- ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT)
- ;; instead.
- :default (if (symbol-self-evaluating-p name)
- name
- (bug "constant lookup of nonconstant ~S" name)))
+ :default nil)
;;; the macro-expansion for symbol-macros
(define-info-type
:type-spec (or ctype null)
:default nil)
-;;; 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 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 :classoid
- :type-spec (or sb!kernel::classoid-cell null)
- :default nil)
-
;;; layout for this type being used by the compiler
(define-info-type
:class :type
:default (let ((class (find-classoid name nil)))
(when class (classoid-layout class))))
+;;; DEFTYPE lambda-list
+(define-info-type
+ :class :type
+ :type :lambda-list
+ :type-spec list
+ :default nil)
+
+(define-info-type
+ :class :type
+ :type :source-location
+ :type-spec t
+ :default nil)
+
(define-info-class :typed-structure)
(define-info-type
:class :typed-structure
(when (info :type :kind name)
(error 'declaration-type-conflict-error
:format-arguments (list name)))))
+(define-info-type
+ :class :declaration
+ :type :handler
+ :type-spec (or function null))
(define-info-class :alien-type)
(define-info-type
(!cold-init-forms
(/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
(setf *info-classes*
- (make-hash-table :test 'eq :size #.(hash-table-size *info-classes*)))
+ (make-hash-table :test 'eq :size #.(* 2 (hash-table-count *info-classes*))))
(/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
(dolist (class-info-name '#.(let ((result nil))
(maphash (lambda (key value)
(declare (ignore value))
(push key result))
*info-classes*)
- result))
+ (sort result #'string<)))
(let ((class-info (make-class-info class-info-name)))
(setf (gethash class-info-name *info-classes*)
class-info)))
(list (type-info-name info-type)
(class-info-name (type-info-class info-type))
(type-info-number info-type)
- (type-info-type info-type))))
+ ;; KLUDGE: for repeatable xc fasls, to
+ ;; avoid different cross-compiler
+ ;; treatment of equal constants here we
+ ;; COPY-TREE, which is not in general a
+ ;; valid identity transformation
+ ;; [e.g. on (EQL (FOO))] but is OK for
+ ;; all the types we use here.
+ (copy-tree (type-info-type info-type)))))
*info-types*)))
(/show0 "done with *INFO-TYPES* initialization"))