(defun primify (x)
(declare (type unsigned-byte x))
(do ((n (logior x 1) (+ n 2)))
- ((sb!sys:positive-primep n)
- n)))
+ ((positive-primep n) n)))
\f
;;;; info classes, info types, and type numbers, part I: what's needed
;;;; not only at compile time but also at run time
#-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)))))
+ (:copier nil))
;; name of this class
(name nil :type keyword :read-only t)
- ;; List of Type-Info structures for each type in this class.
+ ;; list of Type-Info structures for each type in this class
(types () :type list))
;;; a map from type numbers to TYPE-INFO objects. There is one type
;;; number for each defined CLASS/TYPE pair.
;;;
-;;; We build its value at compile time (with calls to
+;;; We build its value at build-the-cross-compiler time (with calls to
;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time
;;; value, and arrange for that code to be called in cold load.
+;;; KLUDGE: We don't try to reset its value when cross-compiling the
+;;; compiler, since that creates too many bootstrapping problems,
+;;; instead just reusing the built-in-the-cross-compiler version,
+;;; which is theoretically a little bit ugly but pretty safe in
+;;; practice because the cross-compiler is as close to the target
+;;; compiler as we can make it, i.e. identical in most ways, including
+;;; this one. -- WHN 2001-08-19
(defvar *info-types*)
(declaim (type simple-vector *info-types*))
+#-sb-xc ; as per KLUDGE note above
(eval-when (:compile-toplevel :execute)
(setf *info-types*
(make-array (ash 1 type-number-bits) :initial-element nil)))
"~S ~S, Number = ~D"
(class-info-name (type-info-class x))
(type-info-name x)
- (type-info-number x))))))
+ (type-info-number x)))))
+ (:copier nil))
;; the name of this type
(name (required-argument) :type keyword)
;; this type's class
;;; We build the value for this at compile time (with calls to
;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time
;;; value, and arrange for that code to be called in cold load.
+;;; KLUDGE: Just as for *INFO-TYPES*, we don't try to rebuild this
+;;; when cross-compiling, but instead just reuse the cross-compiler's
+;;; version for the target compiler. -- WHN 2001-08-19
(defvar *info-classes*)
(declaim (hash-table *info-classes*))
+#-sb-xc ; as per KLUDGE note above
(eval-when (:compile-toplevel :execute)
(setf *info-classes* (make-hash-table)))
-;;; If Name is the name of a type in Class, then return the TYPE-INFO,
+;;; If NAME is the name of a type in CLASS, then return the TYPE-INFO,
;;; otherwise NIL.
(defun find-type-info (name class)
(declare (type keyword name) (type class-info class))
(declaim (ftype (function (keyword) class-info) class-info-or-lose))
(defun class-info-or-lose (class)
(declare (type keyword class))
- (or (gethash class *info-classes*)
- (error "~S is not a defined info class." class)))
+ #+sb-xc (/noshow0 "entering CLASS-INFO-OR-LOSE, CLASS=..")
+ #+sb-xc (/nohexstr class)
+ (prog1
+ (or (gethash class *info-classes*)
+ (error "~S is not a defined info class." class))
+ #+sb-xc (/noshow0 "returning from CLASS-INFO-OR-LOSE")))
(declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
(defun type-info-or-lose (class type)
- (or (find-type-info type (class-info-or-lose class))
- (error "~S is not a defined info type." type)))
+ #+sb-xc (/noshow0 "entering TYPE-INFO-OR-LOSE, CLASS,TYPE=..")
+ #+sb-xc (/nohexstr class)
+ #+sb-xc (/nohexstr type)
+ (prog1
+ (or (find-type-info type (class-info-or-lose class))
+ (error "~S is not a defined info type." type))
+ #+sb-xc (/noshow0 "returning from TYPE-INFO-OR-LOSE")))
) ; EVAL-WHEN
\f
(eval-when (:compile-toplevel :execute)
-;;; Set up the data structures to support an info class. We make sure
-;;; that the class exists at compile time so that macros can use it,
-;;; but don't actually store the init function until load time so that
-;;; we don't break the running compiler.
+;;; Set up the data structures to support an info class.
+;;;
+;;; comment from CMU CL:
+;;; We make sure that the class exists at compile time so that
+;;; macros can use it, but we don't actually store the init function
+;;; until load time so that we don't break the running compiler.
+;;; KLUDGE: I don't think that's the way it is any more, but I haven't
+;;; looked into it enough to write a better comment. -- WHN 2001-03-06
(#+sb-xc-host defmacro
#-sb-xc-host sb!xc:defmacro
define-info-class (class)
- #!+sb-doc
- "Define-Info-Class Class
- Define a new class of global information."
(declare (type keyword class))
`(progn
;; (We don't need to evaluate this at load time, compile time is
;;; 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))
+(defstruct (info-env (:constructor nil)
+ (:copier nil))
;; some string describing what is in this environment, for
;; printing/debugging purposes only
(name (required-argument) :type string))
(declare (ignorable ,type-var ,class-var
,value-var))
,@body
- (unless (zerop (logand ,n-info compact-info-entry-last))
+ (unless (zerop (logand ,n-info
+ compact-info-entry-last))
(return-from ,PUNT))))))))))))))
;;; Return code to iterate over a volatile info environment.
;;; indirect through a parallel vector to find the index in the
;;; ENTRIES at which the entries for a given name starts.
(defstruct (compact-info-env (:include info-env)
- #-sb-xc-host (:pure :substructure))
+ #-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)
;;; info environment in names/bucket
(defconstant compact-info-environment-density 65)
-;;; Iterate over the environment once to find out how many names and entries
-;;; it has, then build the result. This code assumes that all the entries for
-;;; a name well be iterated over contiguously, which holds true for the
-;;; implementation of iteration over both kinds of environments.
-;;;
-;;; When building the table, we sort the entries by POINTER< in an attempt
-;;; to preserve any VM locality present in the original load order, rather than
-;;; randomizing with the original hash function.
+;;; Return a new compact info environment that holds the same
+;;; information as ENV.
(defun compact-info-environment (env &key (name (info-env-name env)))
- #!+sb-doc
- "Return a new compact info environment that holds the same information as
- Env."
(let ((name-count 0)
(prev-name 0)
(entry-count 0))
+ (/show0 "before COLLECT in COMPACT-INFO-ENVIRONMENT")
+
+ ;; Iterate over the environment once to find out how many names
+ ;; and entries it has, then build the result. This code assumes
+ ;; that all the entries for a name well be iterated over
+ ;; contiguously, which holds true for the implementation of
+ ;; iteration over both kinds of environments.
(collect ((names))
+
+ (/show0 "at head of COLLECT in COMPACT-INFO-ENVIRONMENT")
(let ((types ()))
(do-info (env :name name :type-number num :value value)
+ (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT")
(unless (eq name prev-name)
+ (/noshow0 "not (EQ NAME PREV-NAME) case")
(incf name-count)
(unless (eql prev-name 0)
(names (cons prev-name types)))
(incf entry-count)
(push (cons num value) types))
(unless (eql prev-name 0)
+ (/show0 "not (EQL PREV-NAME 0) case")
(names (cons prev-name types))))
+ ;; Now that we know how big the environment is, we can build
+ ;; a table to represent it.
+ ;;
+ ;; When building the table, we sort the entries by pointer
+ ;; comparison in an attempt to preserve any VM locality present
+ ;; in the original load order, rather than randomizing with the
+ ;; original hash function.
+ (/show0 "about to make/sort vectors in COMPACT-INFO-ENVIRONMENT")
(let* ((table-size (primify
(+ (truncate (* name-count 100)
compact-info-environment-density)
:element-type 'compact-info-entry))
(sorted (sort (names)
#+sb-xc-host #'<
+ ;; (This MAKE-FIXNUM hack implements
+ ;; pointer comparison, as explained above.)
#-sb-xc-host (lambda (x y)
- ;; FIXME: What's going on here?
(< (%primitive make-fixnum x)
(%primitive make-fixnum y))))))
+ (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT")
(let ((entries-idx 0))
(dolist (types sorted)
(let* ((name (first types))
(setf (svref table probe) name)
(setf (aref index probe) entries-idx)
(return))
- (assert (not (equal entry name))))))
+ (aver (not (equal entry name))))))
(unless (zerop entries-idx)
(setf (aref entries-info (1- entries-idx))
(setf (aref entries-info entries-idx) num)
(setf (aref entries entries-idx) value)
(incf entries-idx)))
+ (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT")
(unless (zerop entry-count)
+ (/show0 "nonZEROP ENTRY-COUNT")
(setf (aref entries-info (1- entry-count))
(logior (aref entries-info (1- entry-count))
compact-info-entry-last)))
+ (/show0 "falling through to MAKE-COMPACT-INFO-ENV")
(make-compact-info-env :name name
:table table
:index index
\f
;;;; volatile environments
-;;; This is a closed hashtable, with the bucket being computed by taking the
-;;; GLOBALDB-SXHASHOID of the Name mod the table size.
-(defstruct (volatile-info-env (:include info-env))
- ;; 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.
+;;; This is a closed hashtable, with the bucket being computed by
+;;; 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.
+ ;; 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:
+ ;; vector of alists of alists of the form:
;; ((Name . ((Type-Number . Value) ...) ...)
(table (required-argument) :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.
+ ;; 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)
- ;; The number of names at which we should grow the table and rehash.
+ ;; 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.
;;; foldable.)
;;; INFO is the standard way to access the database. It's settable.
+;;;
+;;; Return the information of the specified TYPE and CLASS for NAME.
+;;; The second value returned is true if there is any such information
+;;; recorded. If there is no information, the first value returned is
+;;; the default and the second value returned is NIL.
(defun info (class type name &optional (env-list nil env-list-p))
- #!+sb-doc
- "Return the information of the specified TYPE and CLASS for NAME.
- The second value returned is true if there is any such information
- recorded. If there is no information, the first value returned is
- the default and the second value returned is NIL."
- ;; FIXME: At some point check systematically to make sure that the system
- ;; doesn't do any full calls to INFO or (SETF INFO), or at least none in any
- ;; inner loops.
+ ;; FIXME: At some point check systematically to make sure that the
+ ;; system doesn't do any full calls to INFO or (SETF INFO), or at
+ ;; least none in any inner loops.
(let ((info (type-info-or-lose class type)))
(if env-list-p
- (get-info-value name (type-info-number info) env-list)
- (get-info-value name (type-info-number info)))))
+ (get-info-value name (type-info-number info) env-list)
+ (get-info-value name (type-info-number info)))))
#!-sb-fluid
(define-compiler-macro info
(&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 resolve it much more efficiently than the general case.
+ ;; 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))
(let ((info (type-info-or-lose class type)))
`(the ,(type-info-type info)
:table (make-array table-size :initial-element nil)
:threshold size)))
+;;; Clear the information of the specified TYPE and CLASS for NAME in
+;;; 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
- "Clear the information of the specified Type and Class for Name in the
- current environment, allowing any inherited info to become visible. We
- return true if there was any info."
(let ((info (type-info-or-lose class type)))
(clear-info-value name (type-info-number info))))
#!-sb-fluid
;;; 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 possiblity of the cache being partially
-;;; updated if the lookup is interrupted.
+;;; 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.
(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
+ ;; *INFO-TYPES* could still be uninitialized at the time we try to
+ ;; get an info value, and then we'd be out of luck. (This happened,
+ ;; and was confusing to debug, when rewriting EVAL-WHEN in
+ ;; sbcl-0.pre7.x.)
+ (aver (aref *info-types* type))
(let ((name (uncross name0)))
(flet ((lookup-ignoring-global-cache (env-list)
(let ((hash nil))
(multiple-value-bind (value winp)
(,cache env type)
(when winp (return (values value t)))))))
- (if (typep env 'volatile-info-env)
- (frob volatile-info-lookup volatile-info-cache-hit
- volatile-info-env-cache-name)
- (frob compact-info-lookup compact-info-cache-hit
- compact-info-env-cache-name)))))))
+ (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
(define-info-type
:class :function
:type :assumed-type
- :type-spec (or approximate-function-type null))
+ ;; FIXME: The type-spec really should be
+ ;; (or approximate-function-type null)).
+ ;; It was changed to T as a hopefully-temporary hack while getting
+ ;; cold init problems untangled.
+ :type-spec t)
;;; where this information came from:
-;;; :DECLARED = from a declaration.
-;;; :ASSUMED = from uses of the object.
-;;; :DEFINED = from examination of the definition.
-;;; FIXME: The :DEFINED assumption that the definition won't change
-;;; isn't ANSI. KLUDGE: CMU CL uses function type information in a way
-;;; which violates its "type declarations are assertions" principle,
-;;; and SBCL has inherited that behavior. It would be really good to
-;;; fix the compiler so that it tests the return types of functions..
-;;; -- WHN ca. 19990801
+;;; :ASSUMED = from uses of the object
+;;; :DEFINED = from examination of the definition
+;;; :DECLARED = from a declaration
+;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :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.
(define-info-type
:class :function
:type :where-from
(define-info-class :variable)
-;;; The kind of variable-like thing described.
+;;; the kind of variable-like thing described
(define-info-type
:class :variable
:type :kind
:constant
:global))
-;;; The declared type for this variable.
+;;; the declared type for this variable
(define-info-type
:class :variable
:type :type
:type-spec ctype
:default *universal-type*)
-;;; Where this type and kind information came from.
+;;; where this type and kind information came from
(define-info-type
:class :variable
:type :where-from
:type-spec (member :declared :assumed :defined)
:default :assumed)
-;;; The lisp object which is the value of this constant, if known.
+;;; the Lisp object which is the value of this constant, if known
(define-info-type
:class :variable
:type :constant-value
(define-info-class :type)
-;;; The kind of type described. We return :INSTANCE for standard types that
-;;; are implemented as structures.
+;;; the kind of type described. We return :INSTANCE for standard types
+;;; that are implemented as structures.
(define-info-type
:class :type
:type :kind
:type-spec (member :primitive :defined :instance nil)
:default nil)
-;;; Expander function for a defined type.
+;;; the expander function for a defined type
(define-info-type
:class :type
:type :expander
(setf *info-types*
(map 'vector
(lambda (x)
+ (/show0 "in LAMBDA (X), X=..")
+ (/hexstr x)
(when x
(let* ((class-info (class-info-or-lose (second x)))
(type-info (make-type-info :name (first x)
:class class-info
:number (third x)
:type (fourth x))))
+ (/show0 "got CLASS-INFO in LAMBDA (X)")
(push type-info (class-info-types class-info))
type-info)))
'#.(map 'list
projects / sbcl.git / blobdiff