(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
;;; 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
;;; 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)))
(: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
;;; 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)))
;;; cold load time.
(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
+;;; hasn't been set, and TYPE-SPEC is a type specifier which values of
+;;; the type must satisfy. The default expression is evaluated each
+;;; time the information is needed, with NAME bound to the name for
+;;; which the information is being looked up.
+;;;
;;; The main thing we do is determine the type's number. We need to do
;;; this at macroexpansion time, since both the COMPILE and LOAD time
;;; 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)
- #!+sb-doc
- "Define-Info-Type Class Type default Type-Spec
- 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 hasn't been set, and
- Type-Spec is a type-specifier which values of the type must satisfy. The
- default expression is evaluated each time the information is needed, with
- Name bound to the name for which the information is being looked up. If the
- default evaluates to something with the second value true, then the second
- value of Info will also be true."
(declare (type keyword class type))
`(progn
(eval-when (:compile-toplevel :execute)
(: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)))
;;;; 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)
+(def!constant compact-info-env-entries-bits 16)
(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)
- ;; 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 (*))))
-
-(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
-(defconstant 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.
+ (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 (missing-arg) :type (simple-array compact-info-entry (*))))
+
+(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.
#!-sb-fluid (declaim (inline compact-info-cache-hit))
(defun compact-info-cache-hit (env number)
(declare (type compact-info-env env) (type type-number number))
(return (values nil nil)))))
(values nil nil))))
-;;; Encache Name in the compact environment Env. Hash is the
-;;; GLOBALDB-SXHASHOID of Name.
+;;; 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))
(let* ((table (compact-info-env-table env))
`(do ((probe (rem hash len)
(let ((new (+ probe hash2)))
(declare (type index new))
- ;; same as (mod new len), but faster.
+ ;; same as (MOD NEW LEN), but faster.
(if (>= new len)
(the index (- new len))
new))))
;;; 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)
(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
;;; 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)
#!-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 implement 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)
- (get-info-value ,name
- ,(type-info-number info)
- ,@(when env-list-p `(,env-list)))))
+ (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)))
+ (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"))
: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
:default
#+sb-xc-host (specifier-type 'function)
#-sb-xc-host (if (fboundp name)
- (extract-function-type (fdefinition name))
+ (extract-fun-type (fdefinition name))
(specifier-type 'function)))
;;; the ASSUMED-TYPE for this function, if we have to infer the type
:class :function
:type :assumed-type
;; FIXME: The type-spec really should be
- ;; (or approximate-function-type null)).
+ ;; (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
#+sb-xc-host :assumed
#-sb-xc-host (if (fboundp name) :defined :assumed))
-;;; lambda used for inline expansion of this function
+;;; something which can be decoded into the inline expansion of the
+;;; function, or NIL if there is none
+;;;
+;;; To inline a function, we want a lambda expression, e.g.
+;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two
+;;; ways.
+;;; * The value in INFO can be the lambda expression itself, e.g.
+;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO)
+;;; '(LAMBDA (X) (+ X 1)))
+;;; This is the ordinary way, the natural way of representing e.g.
+;;; (DECLAIM (INLINE FOO))
+;;; (DEFUN FOO (X) (+ X 1))
+;;; * The value in INFO can be a closure which returns the lambda
+;;; expression, e.g.
+;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'BAR-LEFT-CHILD)
+;;; (LAMBDA ()
+;;; '(LAMBDA (BAR) (BAR-REF BAR 3))))
+;;; This twisty way of storing values is supported in order to
+;;; allow structure slot accessors, and perhaps later other
+;;; stereotyped functions, to be represented compactly.
(define-info-type
:class :function
- :type :inline-expansion
- :type-spec list)
+ :type :inline-expansion-designator
+ :type-spec (or list function)
+ :default nil)
;;; 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 a slot accessor or setter, then this is the class
-;;; that it accesses slots of.
-(define-info-type
- :class :function
- :type :accessor-for
- :type-spec (or sb!xc:class null)
- :default nil)
-
-;;; 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)
- :default (if (or (eq (symbol-package name) *keyword-package*)
- (member name '(t nil)))
- :constant
- :global))
+ :type-spec (member :special :constant :macro :global :alien)
+ :default (if (symbol-self-evaluating-p name)
+ :constant
+ :global))
;;; the declared type for this variable
(define-info-type
:class :variable
:type :constant-value
:type-spec t
- :default (if (boundp name)
- (values (symbol-value name) t)
- (values nil nil)))
+ ;; 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)))
+
+;;; 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
projects / sbcl.git / blobdiff