1 ;;;; This file provides a functional interface to global information
2 ;;;; about named things in the system. Information is considered to be
3 ;;;; global if it must persist between invocations of the compiler. The
4 ;;;; use of a functional interface eliminates the need for the compiler
5 ;;;; to worry about the actual representation. This is important, since
6 ;;;; the information may well have several representations.
8 ;;;; The database contains arbitrary Lisp values, addressed by a
9 ;;;; combination of Name, Class and Type. The Name is a EQUAL-thing
10 ;;;; which is the name of the thing we are recording information
11 ;;;; about. Class is the kind of object involved. Typical classes are
12 ;;;; :FUNCTION, :VARIABLE, :TYPE, ... A Type names a particular piece
13 ;;;; of information within a given class. Class and Type are keywords,
14 ;;;; and are compared with EQ.
16 ;;;; This software is part of the SBCL system. See the README file for
17 ;;;; more information.
19 ;;;; This software is derived from the CMU CL system, which was
20 ;;;; written at Carnegie Mellon University and released into the
21 ;;;; public domain. The software is in the public domain and is
22 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
23 ;;;; files for more information.
27 (!begin-collecting-cold-init-forms
)
28 #!+sb-show
(!cold-init-forms
(/show0
"early in globaldb.lisp cold init"))
30 ;;; The DEFVAR for this appears later.
32 (declaim (special *universal-type
*))
34 ;;; This is sorta semantically equivalent to SXHASH, but optimized for
35 ;;; legal function names.
37 ;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary
39 ;;; 1. This hash function has to run when we're initializing the globaldb,
40 ;;; so it has to run before the type system is initialized, and it's
41 ;;; easier to make it do this if we don't try to do a general TYPECASE.
42 ;;; 2. This function is in a potential bottleneck for the compiler,
43 ;;; and avoiding the general TYPECASE lets us improve performance
45 ;;; 2a. the general TYPECASE is intrinsically slow, and
46 ;;; 2b. the general TYPECASE is too big for us to easily afford
47 ;;; to inline it, so it brings with it a full function call.
49 ;;; Why not specialize instead of optimize? (I.e. why fall through to
50 ;;; general SXHASH as a last resort?) Because the INFO database is used
51 ;;; to hold all manner of things, e.g. (INFO :TYPE :BUILTIN ..)
52 ;;; which is called on values like (UNSIGNED-BYTE 29). Falling through
53 ;;; to SXHASH lets us support all manner of things (as long as they
54 ;;; aren't used too early in cold boot for SXHASH to run).
55 #!-sb-fluid
(declaim (inline globaldb-sxhashoid
))
56 (defun globaldb-sxhashoid (x)
57 (logand sb
!xc
:most-positive-fixnum
58 (cond ((symbolp x
) (sxhash x
))
61 (let ((rest (rest x
)))
62 (and (symbolp (car rest
))
64 ;; We need to declare the type of the value we're feeding to
65 ;; SXHASH so that the DEFTRANSFORM on symbols kicks in.
66 (let ((symbol (second x
)))
67 (declare (symbol symbol
))
68 (logxor (sxhash symbol
) 110680597)))
71 ;;; Given any non-negative integer, return a prime number >= to it.
73 ;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in
74 ;;; hash-table.lisp. Perhaps the merged logic should be
75 ;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes
76 ;;; after integral powers of two:
77 ;;; #(17 37 67 131 ..)
78 ;;; (Or, if that's too coarse, after half-integral powers of two.) By
79 ;;; thus getting rid of any need for primality testing at runtime, we
80 ;;; could punt POSITIVE-PRIMEP, too.
82 (declare (type unsigned-byte x
))
83 (do ((n (logior x
1) (+ n
2)))
84 ((positive-primep n
) n
)))
86 ;;;; info classes, info types, and type numbers, part I: what's needed
87 ;;;; not only at compile time but also at run time
89 ;;;; Note: This section is a blast from the past, a little trip down
90 ;;;; memory lane to revisit the weird host/target interactions of the
91 ;;;; CMU CL build process. Because of the way that the cross-compiler
92 ;;;; and target compiler share stuff here, if you change anything in
93 ;;;; here, you'd be well-advised to nuke all your fasl files and
94 ;;;; restart compilation from the very beginning of the bootstrap
97 ;;; At run time, we represent the type of info that we want by a small
98 ;;; non-negative integer.
99 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
100 (def!constant type-number-bits
6))
101 (deftype type-number
() `(unsigned-byte ,type-number-bits
))
103 ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
104 ;;; running the cross-compiler? The cross-compiler (which was built
105 ;;; from these sources) has its version of these data and functions
106 ;;; defined in the same places we'd be defining into. We're happy with
107 ;;; its version, since it was compiled from the same sources, so
108 ;;; there's no point in overwriting its nice compiled version of this
109 ;;; stuff with our interpreted version. (And any time we're *not*
110 ;;; happy with its version, perhaps because we've been editing the
111 ;;; sources partway through bootstrapping, tch tch, overwriting its
112 ;;; version with our version would be unlikely to help, because that
113 ;;; would make the cross-compiler very confused.)
114 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
116 (defstruct (class-info
117 (:constructor make-class-info
(name))
118 #-no-ansi-print-object
119 (:print-object
(lambda (x s
)
120 (print-unreadable-object (x s
:type t
)
121 (prin1 (class-info-name x
)))))
123 ;; name of this class
124 (name nil
:type keyword
:read-only t
)
125 ;; list of Type-Info structures for each type in this class
126 (types () :type list
))
128 ;;; a map from type numbers to TYPE-INFO objects. There is one type
129 ;;; number for each defined CLASS/TYPE pair.
131 ;;; We build its value at build-the-cross-compiler time (with calls to
132 ;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time
133 ;;; value, and arrange for that code to be called in cold load.
134 ;;; KLUDGE: We don't try to reset its value when cross-compiling the
135 ;;; compiler, since that creates too many bootstrapping problems,
136 ;;; instead just reusing the built-in-the-cross-compiler version,
137 ;;; which is theoretically a little bit ugly but pretty safe in
138 ;;; practice because the cross-compiler is as close to the target
139 ;;; compiler as we can make it, i.e. identical in most ways, including
140 ;;; this one. -- WHN 2001-08-19
141 (defvar *info-types
*)
142 (declaim (type simple-vector
*info-types
*))
143 #-sb-xc
; as per KLUDGE note above
144 (eval-when (:compile-toplevel
:execute
)
146 (make-array (ash 1 type-number-bits
) :initial-element nil
)))
148 (defstruct (type-info
149 #-no-ansi-print-object
150 (:print-object
(lambda (x s
)
151 (print-unreadable-object (x s
)
154 (class-info-name (type-info-class x
))
156 (type-info-number x
)))))
158 ;; the name of this type
159 (name (missing-arg) :type keyword
)
161 (class (missing-arg) :type class-info
)
162 ;; a number that uniquely identifies this type (and implicitly its class)
163 (number (missing-arg) :type type-number
)
164 ;; a type specifier which info of this type must satisfy
166 ;; a function called when there is no information of this type
167 (default (lambda () (error "type not defined yet")) :type function
)
168 ;; called by (SETF INFO) before calling SET-INFO-VALUE
169 (validate-function nil
:type
(or function null
)))
171 ;;; a map from class names to CLASS-INFO structures
173 ;;; We build the value for this at compile time (with calls to
174 ;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time
175 ;;; value, and arrange for that code to be called in cold load.
176 ;;; KLUDGE: Just as for *INFO-TYPES*, we don't try to rebuild this
177 ;;; when cross-compiling, but instead just reuse the cross-compiler's
178 ;;; version for the target compiler. -- WHN 2001-08-19
179 (defvar *info-classes
*)
180 (declaim (hash-table *info-classes
*))
181 #-sb-xc
; as per KLUDGE note above
182 (eval-when (:compile-toplevel
:execute
)
183 (setf *info-classes
* (make-hash-table :test
#'eq
)))
185 ;;; If NAME is the name of a type in CLASS, then return the TYPE-INFO,
187 (defun find-type-info (name class
)
188 (declare (type keyword name
) (type class-info class
))
189 (dolist (type (class-info-types class
) nil
)
190 (when (eq (type-info-name type
) name
)
193 ;;; Return the info structure for an info class or type, or die trying.
194 (declaim (ftype (function (keyword) class-info
) class-info-or-lose
))
195 (defun class-info-or-lose (class)
196 (declare (type keyword class
))
197 #+sb-xc
(/noshow0
"entering CLASS-INFO-OR-LOSE, CLASS=..")
198 #+sb-xc
(/nohexstr class
)
200 (flet ((lookup (class)
201 (or (gethash class
*info-classes
*)
202 (error "~S is not a defined info class." class
))))
204 (or (get class
'class-info-or-lose-cache
)
205 (setf (get class
'class-info-or-lose-cache
)
208 #+sb-xc
(/noshow0
"returning from CLASS-INFO-OR-LOSE")))
209 (declaim (ftype (function (keyword keyword
) type-info
) type-info-or-lose
))
210 (defun type-info-or-lose (class type
)
211 #+sb-xc
(/noshow0
"entering TYPE-INFO-OR-LOSE, CLASS,TYPE=..")
212 #+sb-xc
(/nohexstr class
)
213 #+sb-xc
(/nohexstr type
)
215 (or (find-type-info type
(class-info-or-lose class
))
216 (error "~S is not a defined info type." type
))
217 #+sb-xc
(/noshow0
"returning from TYPE-INFO-OR-LOSE")))
221 ;;;; info classes, info types, and type numbers, part II: what's
222 ;;;; needed only at compile time, not at run time
224 ;;; FIXME: Perhaps this stuff (the definition of DEFINE-INFO-CLASS
225 ;;; and the calls to it) could/should go in a separate file,
226 ;;; perhaps info-classes.lisp?
228 (eval-when (:compile-toplevel
:execute
)
230 ;;; Set up the data structures to support an info class.
232 ;;; comment from CMU CL:
233 ;;; We make sure that the class exists at compile time so that
234 ;;; macros can use it, but we don't actually store the init function
235 ;;; until load time so that we don't break the running compiler.
236 ;;; KLUDGE: I don't think that's the way it is any more, but I haven't
237 ;;; looked into it enough to write a better comment. -- WHN 2001-03-06
238 (#+sb-xc-host defmacro
239 #-sb-xc-host sb
!xc
:defmacro
240 define-info-class
(class)
241 (declare (type keyword class
))
243 ;; (We don't need to evaluate this at load time, compile time is
244 ;; enough. There's special logic elsewhere which deals with cold
245 ;; load initialization by inspecting the info class data
246 ;; structures at compile time and generating code to recreate
247 ;; those data structures.)
248 (eval-when (:compile-toplevel
:execute
)
249 (unless (gethash ,class
*info-classes
*)
250 (setf (gethash ,class
*info-classes
*) (make-class-info ,class
))))
253 ;;; Find a type number not already in use by looking for a null entry
255 (defun find-unused-type-number ()
256 (or (position nil
*info-types
*)
257 (error "no more INFO type numbers available")))
259 ;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO
260 ;;; objects, accumulated during compilation and eventually converted
261 ;;; into a function to be called at cold load time after the
262 ;;; appropriate TYPE-INFO objects have been created
264 ;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but
265 ;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery
266 ;;; here. The problem is that the natural order in which the
267 ;;; default-slot-initialization forms are generated relative to the
268 ;;; order in which the TYPE-INFO-creation forms are generated doesn't
269 ;;; match the relative order in which the forms need to be executed at
271 (defparameter *!reversed-type-info-init-forms
* nil
)
273 ;;; Define a new type of global information for CLASS. TYPE is the
274 ;;; name of the type, DEFAULT is the value for that type when it
275 ;;; hasn't been set, and TYPE-SPEC is a type specifier which values of
276 ;;; the type must satisfy. The default expression is evaluated each
277 ;;; time the information is needed, with NAME bound to the name for
278 ;;; which the information is being looked up.
280 ;;; The main thing we do is determine the type's number. We need to do
281 ;;; this at macroexpansion time, since both the COMPILE and LOAD time
282 ;;; calls to %DEFINE-INFO-TYPE must use the same type number.
283 (#+sb-xc-host defmacro
284 #-sb-xc-host sb
!xc
:defmacro
285 define-info-type
(&key
(class (missing-arg))
287 (type-spec (missing-arg))
290 (declare (type keyword class type
))
292 (eval-when (:compile-toplevel
:execute
)
293 ;; At compile time, ensure that the type number exists. It will
294 ;; need to be forced to exist at cold load time, too, but
295 ;; that's not handled here; it's handled by later code which
296 ;; looks at the compile time state and generates code to
297 ;; replicate it at cold load time.
298 (let* ((class-info (class-info-or-lose ',class
))
299 (old-type-info (find-type-info ',type class-info
)))
300 (unless old-type-info
301 (let* ((new-type-number (find-unused-type-number))
303 (make-type-info :name
',type
305 :number new-type-number
)))
306 (setf (aref *info-types
* new-type-number
) new-type-info
)
307 (push new-type-info
(class-info-types class-info
)))))
308 ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
309 ;; at cold load time. (They can't very well be set at
310 ;; cross-compile time, since they differ between the
311 ;; cross-compiler and the target. The DEFAULT slot values
312 ;; differ because they're compiled closures, and the TYPE slot
313 ;; values differ in the use of SB!XC symbols instead of CL
315 (push `(let ((type-info (type-info-or-lose ,',class
,',type
)))
316 (setf (type-info-validate-function type-info
)
317 ,',validate-function
)
318 (setf (type-info-default type-info
)
319 ;; FIXME: This code is sort of nasty. It would
320 ;; be cleaner if DEFAULT accepted a real
321 ;; function, instead of accepting a statement
322 ;; which will be turned into a lambda assuming
323 ;; that the argument name is NAME. It might
324 ;; even be more microefficient, too, since many
325 ;; DEFAULTs could be implemented as (CONSTANTLY
326 ;; NIL) instead of full-blown (LAMBDA (X) NIL).
328 (declare (ignorable name
))
330 (setf (type-info-type type-info
) ',',type-spec
))
331 *!reversed-type-info-init-forms
*))
336 ;;;; generic info environments
338 (defstruct (info-env (:constructor nil
)
340 ;; some string describing what is in this environment, for
341 ;; printing/debugging purposes only
342 (name (missing-arg) :type string
))
343 (def!method print-object
((x info-env
) stream
)
344 (print-unreadable-object (x stream
:type t
)
345 (prin1 (info-env-name x
) stream
)))
347 ;;;; generic interfaces
349 ;;; FIXME: used only in this file, needn't be in runtime
350 (defmacro do-info
((env &key
(name (gensym)) (class (gensym)) (type (gensym))
351 (type-number (gensym)) (value (gensym)) known-volatile
)
354 "DO-INFO (Env &Key Name Class Type Value) Form*
355 Iterate over all the values stored in the Info-Env Env. Name is bound to
356 the entry's name, Class and Type are bound to the class and type
357 (represented as keywords), and Value is bound to the entry's value."
358 (once-only ((n-env env
))
360 (do-volatile-info name class type type-number value n-env body
)
361 `(if (typep ,n-env
'volatile-info-env
)
362 ,(do-volatile-info name class type type-number value n-env body
)
363 ,(do-compact-info name class type type-number value
366 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
368 ;;; Return code to iterate over a compact info environment.
369 (defun do-compact-info (name-var class-var type-var type-number-var value-var
371 (let ((n-index (gensym))
374 (once-only ((n-table `(compact-info-env-table ,n-env
))
375 (n-entries-index `(compact-info-env-index ,n-env
))
376 (n-entries `(compact-info-env-entries ,n-env
))
377 (n-entries-info `(compact-info-env-entries-info ,n-env
))
378 (n-info-types '*info-types
*))
379 `(dotimes (,n-index
(length ,n-table
))
380 (declare (type index
,n-index
))
382 (let ((,name-var
(svref ,n-table
,n-index
)))
383 (unless (eql ,name-var
0)
384 (do-anonymous ((,n-type
(aref ,n-entries-index
,n-index
)
387 (declare (type index
,n-type
))
388 ,(once-only ((n-info `(aref ,n-entries-info
,n-type
)))
389 `(let ((,type-number-var
390 (logand ,n-info compact-info-entry-type-mask
)))
391 ,(once-only ((n-type-info
392 `(svref ,n-info-types
394 `(let ((,type-var
(type-info-name ,n-type-info
))
395 (,class-var
(class-info-name
396 (type-info-class ,n-type-info
)))
397 (,value-var
(svref ,n-entries
,n-type
)))
398 (declare (ignorable ,type-var
,class-var
401 (unless (zerop (logand ,n-info
402 compact-info-entry-last
))
403 (return-from ,punt
))))))))))))))
405 ;;; Return code to iterate over a volatile info environment.
406 (defun do-volatile-info (name-var class-var type-var type-number-var value-var
408 (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
409 (once-only ((n-table `(volatile-info-env-table ,n-env
))
410 (n-info-types '*info-types
*))
411 `(dotimes (,n-index
(length ,n-table
))
412 (declare (type index
,n-index
))
413 (do-anonymous ((,n-names
(svref ,n-table
,n-index
)
416 (let ((,name-var
(caar ,n-names
)))
417 (declare (ignorable ,name-var
))
418 (do-anonymous ((,n-types
(cdar ,n-names
) (cdr ,n-types
)))
420 (let ((,type-number-var
(caar ,n-types
)))
421 ,(once-only ((n-type `(svref ,n-info-types
423 `(let ((,type-var
(type-info-name ,n-type
))
424 (,class-var
(class-info-name
425 (type-info-class ,n-type
)))
426 (,value-var
(cdar ,n-types
)))
427 (declare (ignorable ,type-var
,class-var
,value-var
))
433 ;;;; compact info environments
435 ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
437 ;;; "Why (U-B 28)?", you might wonder. Originally this was (U-B 16),
438 ;;; presumably to ensure that the arrays of :ELEMENT-TYPE
439 ;;; COMPACT-INFO-ENTRIES-INDEX could use a more space-efficient representation.
440 ;;; It turns out that a environment of of only 65536 entries is insufficient in
441 ;;; the modern world (see message from Cyrus Harmon to sbcl-devel, "Subject:
442 ;;; purify failure when compact-info-env-entries-bits is too small"). Using
443 ;;; (U-B 28) instead of (U-B 29) is to avoid the need for bignum overflow
444 ;;; checks, a probably pointless micro-optimization. Hardcoding the amount of
445 ;;; bits instead of deriving it from SB!VM::N-WORD-BITS is done to allow
446 ;;; use of a more efficient array representation on 64-bit platforms.
447 ;;; -- JES, 2005-04-06
448 (def!constant compact-info-env-entries-bits
28)
449 (deftype compact-info-entries-index
() `(unsigned-byte ,compact-info-env-entries-bits
))
451 ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO
452 (deftype compact-info-entry
() `(unsigned-byte ,(1+ type-number-bits
)))
454 ;;; This is an open hashtable with rehashing. Since modification is
455 ;;; not allowed, we don't have to worry about deleted entries. We
456 ;;; indirect through a parallel vector to find the index in the
457 ;;; ENTRIES at which the entries for a given name starts.
458 (defstruct (compact-info-env (:include info-env
)
459 #-sb-xc-host
(:pure
:substructure
)
461 ;; hashtable of the names in this environment. If a bucket is
463 (table (missing-arg) :type simple-vector
)
464 ;; an indirection vector parallel to TABLE, translating indices in
465 ;; TABLE to the start of the ENTRIES for that name. Unused entries
467 (index (missing-arg) :type
(simple-array compact-info-entries-index
(*)))
468 ;; a vector contining in contiguous ranges the values of for all the
469 ;; types of info for each name.
470 (entries (missing-arg) :type simple-vector
)
471 ;; a vector parallel to ENTRIES, indicating the type number for the
472 ;; value stored in that location and whether this location is the
473 ;; last type of info stored for this name. The type number is in the
474 ;; low TYPE-NUMBER-BITS bits, and the next bit is set if this is the
476 (entries-info (missing-arg) :type
(simple-array compact-info-entry
(*))))
478 (def!constant compact-info-entry-type-mask
(ldb (byte type-number-bits
0) -
1))
479 (def!constant compact-info-entry-last
(ash 1 type-number-bits
))
481 ;;; Return the value of the type corresponding to NUMBER for the
482 ;;; index INDEX in ENV.
483 #!-sb-fluid
(declaim (inline compact-info-lookup-index
))
484 (defun compact-info-lookup-index (env number index
)
485 (declare (type compact-info-env env
) (type type-number number
))
486 (let ((entries-info (compact-info-env-entries-info env
)))
488 (do ((index index
(1+ index
)))
490 (declare (type index index
))
491 (let ((info (aref entries-info index
)))
492 (when (= (logand info compact-info-entry-type-mask
) number
)
493 (return (values (svref (compact-info-env-entries env
) index
)
495 (unless (zerop (logand compact-info-entry-last info
))
496 (return (values nil nil
)))))
499 ;;; Look up NAME in the compact environment ENV. HASH is the
500 ;;; GLOBALDB-SXHASHOID of NAME.
501 (defun compact-info-lookup (env name hash number
)
502 (declare (type compact-info-env env
)
503 (type (integer 0 #.sb
!xc
:most-positive-fixnum
) hash
))
504 (let* ((table (compact-info-env-table env
))
507 (hash2 (- len-2
(rem hash len-2
))))
508 (declare (type index len-2 hash2
))
509 (macrolet ((lookup (test)
510 `(do ((probe (rem hash len
)
511 (let ((new (+ probe hash2
)))
512 (declare (type index new
))
513 ;; same as (MOD NEW LEN), but faster.
515 (the index
(- new len
))
518 (let ((entry (svref table probe
)))
521 (when (,test entry name
)
522 (return (compact-info-lookup-index
525 (aref (compact-info-env-index env
) probe
))))))))
530 ;;; the exact density (modulo rounding) of the hashtable in a compact
531 ;;; info environment in names/bucket
532 (def!constant compact-info-environment-density
65)
534 ;;; Return a new compact info environment that holds the same
535 ;;; information as ENV.
536 (defun compact-info-environment (env &key
(name (info-env-name env
)))
540 (/show0
"before COLLECT in COMPACT-INFO-ENVIRONMENT")
542 ;; Iterate over the environment once to find out how many names
543 ;; and entries it has, then build the result. This code assumes
544 ;; that all the entries for a name well be iterated over
545 ;; contiguously, which holds true for the implementation of
546 ;; iteration over both kinds of environments.
549 (/show0
"at head of COLLECT in COMPACT-INFO-ENVIRONMENT")
551 (do-info (env :name name
:type-number num
:value value
)
552 (/noshow0
"at head of DO-INFO in COMPACT-INFO-ENVIRONMENT")
553 (unless (eq name prev-name
)
554 (/noshow0
"not (EQ NAME PREV-NAME) case")
556 (unless (eql prev-name
0)
557 (names (cons prev-name types
)))
558 (setq prev-name name
)
561 (push (cons num value
) types
))
562 (unless (eql prev-name
0)
563 (/show0
"not (EQL PREV-NAME 0) case")
564 (names (cons prev-name types
))))
566 ;; Now that we know how big the environment is, we can build
567 ;; a table to represent it.
569 ;; When building the table, we sort the entries by pointer
570 ;; comparison in an attempt to preserve any VM locality present
571 ;; in the original load order, rather than randomizing with the
572 ;; original hash function.
573 (/show0
"about to make/sort vectors in COMPACT-INFO-ENVIRONMENT")
574 (let* ((table-size (primify
575 (+ (truncate (* name-count
100)
576 compact-info-environment-density
)
578 (table (make-array table-size
:initial-element
0))
579 (index (make-array table-size
580 :element-type
'compact-info-entries-index
))
581 (entries (make-array entry-count
))
582 (entries-info (make-array entry-count
583 :element-type
'compact-info-entry
))
584 (sorted (sort (names)
586 ;; (This MAKE-FIXNUM hack implements
587 ;; pointer comparison, as explained above.)
588 #-sb-xc-host
(lambda (x y
)
589 (< (%primitive make-fixnum x
)
590 (%primitive make-fixnum y
))))))
591 (/show0
"done making/sorting vectors in COMPACT-INFO-ENVIRONMENT")
592 (let ((entries-idx 0))
593 (dolist (types sorted
)
594 (let* ((name (first types
))
595 (hash (globaldb-sxhashoid name
))
596 (len-2 (- table-size
2))
597 (hash2 (- len-2
(rem hash len-2
))))
598 (do ((probe (rem hash table-size
)
599 (rem (+ probe hash2
) table-size
)))
601 (let ((entry (svref table probe
)))
603 (setf (svref table probe
) name
)
604 (setf (aref index probe
) entries-idx
)
606 (aver (not (equal entry name
))))))
608 (unless (zerop entries-idx
)
609 (setf (aref entries-info
(1- entries-idx
))
610 (logior (aref entries-info
(1- entries-idx
))
611 compact-info-entry-last
)))
613 (loop for
(num . value
) in
(rest types
) do
614 (setf (aref entries-info entries-idx
) num
)
615 (setf (aref entries entries-idx
) value
)
617 (/show0
"done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT")
619 (unless (zerop entry-count
)
620 (/show0
"nonZEROP ENTRY-COUNT")
621 (setf (aref entries-info
(1- entry-count
))
622 (logior (aref entries-info
(1- entry-count
))
623 compact-info-entry-last
)))
625 (/show0
"falling through to MAKE-COMPACT-INFO-ENV")
626 (make-compact-info-env :name name
630 :entries-info entries-info
))))))
632 ;;;; volatile environments
634 ;;; This is a closed hashtable, with the bucket being computed by
635 ;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size.
636 (defstruct (volatile-info-env (:include info-env
)
638 ;; vector of alists of alists of the form:
639 ;; ((Name . ((Type-Number . Value) ...) ...)
640 (table (missing-arg) :type simple-vector
)
641 ;; the number of distinct names currently in this table. Each name
642 ;; may have multiple entries, since there can be many types of info.
643 (count 0 :type index
)
644 ;; the number of names at which we should grow the table and rehash
645 (threshold 0 :type index
))
647 ;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
648 (defun volatile-info-lookup (env name hash number
)
649 (declare (type volatile-info-env env
)
650 (type (integer 0 #.sb
!xc
:most-positive-fixnum
) hash
))
651 (let ((table (volatile-info-env-table env
)))
652 (macrolet ((lookup (test)
653 `(dolist (entry (svref table
(mod hash
(length table
))) ())
654 (when (,test
(car entry
) name
)
655 (dolist (type (cdr entry
))
656 (when (eql (car type
) number
)
657 (return-from volatile-info-lookup
658 (values (cdr type
) t
))))
659 (return-from volatile-info-lookup
660 (values nil nil
))))))
665 ;;; Given a volatile environment ENV, bind TABLE-VAR the environment's table
666 ;;; and INDEX-VAR to the index of NAME's bucket in the table.
667 (eval-when (:compile-toplevel
:execute
)
668 (#+sb-xc-host cl
:defmacro
669 #-sb-xc-host sb
!xc
:defmacro
670 with-info-bucket
((table-var index-var name env
) &body body
)
671 (once-only ((n-name name
)
674 (let* ((,table-var
(volatile-info-env-table ,n-env
))
675 (,index-var
(mod (globaldb-sxhashoid ,n-name
)
676 (length ,table-var
))))
679 ;;; Get the info environment that we use for write/modification operations.
680 ;;; This is always the first environment in the list, and must be a
681 ;;; VOLATILE-INFO-ENV.
682 #!-sb-fluid
(declaim (inline get-write-info-env
))
683 (defun get-write-info-env (&optional
(env-list *info-environment
*))
684 (let ((env (car env-list
)))
686 (error "no info environment?"))
687 (unless (typep env
'volatile-info-env
)
688 (error "cannot modify this environment: ~S" env
))
689 (the volatile-info-env env
)))
691 ;;; If Name is already present in the table, then just create or
692 ;;; modify the specified type. Otherwise, add the new name and type,
693 ;;; checking for rehashing.
695 ;;; We rehash by making a new larger environment, copying all of the
696 ;;; entries into it, then clobbering the old environment with the new
697 ;;; environment's table. We clear the old table to prevent it from
698 ;;; holding onto garbage if it is statically allocated.
700 ;;; We return the new value so that this can be conveniently used in a
702 (defun set-info-value (name0 type new-value
703 &optional
(env (get-write-info-env)))
704 (declare (type type-number type
) (type volatile-info-env env
)
706 (let ((name (uncross name0
)))
708 (error "0 is not a legal INFO name."))
709 (with-info-bucket (table index name env
)
710 (let ((types (if (symbolp name
)
711 (assoc name
(svref table index
) :test
#'eq
)
712 (assoc name
(svref table index
) :test
#'equal
))))
715 (let ((value (assoc type
(cdr types
))))
717 (setf (cdr value
) new-value
)
718 (push (cons type new-value
) (cdr types
)))))
720 (push (cons name
(list (cons type new-value
)))
723 (let ((count (incf (volatile-info-env-count env
))))
724 (when (>= count
(volatile-info-env-threshold env
))
725 (let ((new (make-info-environment :size
(* count
2))))
726 (do-info (env :name entry-name
:type-number entry-num
727 :value entry-val
:known-volatile t
)
728 (set-info-value entry-name entry-num entry-val new
))
729 (fill (volatile-info-env-table env
) nil
)
730 (setf (volatile-info-env-table env
)
731 (volatile-info-env-table new
))
732 (setf (volatile-info-env-threshold env
)
733 (volatile-info-env-threshold new
)))))))))
736 ;;; FIXME: It should be possible to eliminate the hairy compiler macros below
737 ;;; by declaring INFO and (SETF INFO) inline and making a simple compiler macro
738 ;;; for TYPE-INFO-OR-LOSE. (If we didn't worry about efficiency of the
739 ;;; cross-compiler, we could even do it by just making TYPE-INFO-OR-LOSE
742 ;;; INFO is the standard way to access the database. It's settable.
744 ;;; Return the information of the specified TYPE and CLASS for NAME.
745 ;;; The second value returned is true if there is any such information
746 ;;; recorded. If there is no information, the first value returned is
747 ;;; the default and the second value returned is NIL.
748 (defun info (class type name
&optional
(env-list nil env-list-p
))
749 ;; FIXME: At some point check systematically to make sure that the
750 ;; system doesn't do any full calls to INFO or (SETF INFO), or at
751 ;; least none in any inner loops.
752 (let ((info (type-info-or-lose class type
)))
754 (get-info-value name
(type-info-number info
) env-list
)
755 (get-info-value name
(type-info-number info
)))))
757 (define-compiler-macro info
758 (&whole whole class type name
&optional
(env-list nil env-list-p
))
759 ;; Constant CLASS and TYPE is an overwhelmingly common special case,
760 ;; and we can implement it much more efficiently than the general case.
761 (if (and (keywordp class
) (keywordp type
))
762 (let ((info (type-info-or-lose class type
)))
763 (with-unique-names (value foundp
)
764 `(multiple-value-bind (,value
,foundp
)
765 (get-info-value ,name
766 ,(type-info-number info
)
767 ,@(when env-list-p
`(,env-list
)))
768 (declare (type ,(type-info-type info
) ,value
))
769 (values ,value
,foundp
))))
772 (defun (setf info
) (new-value
776 &optional
(env-list nil env-list-p
))
777 (let* ((info (type-info-or-lose class type
))
778 (tin (type-info-number info
)))
779 (when (type-info-validate-function info
)
780 (funcall (type-info-validate-function info
) name new-value
))
785 (get-write-info-env env-list
))
792 ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19
793 ;; does not accept them at all, and older SBCLs give a full warning.
794 ;; So the easy thing is to hide this optimization from all xc hosts.
796 (define-compiler-macro (setf info
) (&whole whole
801 &optional
(env-list nil
803 ;; Constant CLASS and TYPE is an overwhelmingly common special case,
804 ;; and we can resolve it much more efficiently than the general
806 (if (and (keywordp class
) (keywordp type
))
807 (let* ((info (type-info-or-lose class type
))
808 (tin (type-info-number info
)))
810 `(set-info-value ,name
813 (get-write-info-env ,env-list
))
814 `(set-info-value ,name
819 ;;; the maximum density of the hashtable in a volatile env (in
822 ;;; FIXME: actually seems to be measured in percent, should be
823 ;;; converted to be measured in names/bucket
824 (def!constant volatile-info-environment-density
50)
826 ;;; Make a new volatile environment of the specified size.
827 (defun make-info-environment (&key
(size 42) (name "Unknown"))
828 (declare (type (integer 1) size
))
829 (let ((table-size (primify (truncate (* size
100)
830 volatile-info-environment-density
))))
831 (make-volatile-info-env :name name
832 :table
(make-array table-size
:initial-element nil
)
835 ;;; Clear the information of the specified TYPE and CLASS for NAME in
836 ;;; the current environment, allowing any inherited info to become
837 ;;; visible. We return true if there was any info.
838 (defun clear-info (class type name
)
839 (let ((info (type-info-or-lose class type
)))
840 (clear-info-value name
(type-info-number info
))))
842 (define-compiler-macro clear-info
(&whole whole class type name
)
843 ;; Constant CLASS and TYPE is an overwhelmingly common special case, and
844 ;; we can resolve it much more efficiently than the general case.
845 (if (and (keywordp class
) (keywordp type
))
846 (let ((info (type-info-or-lose class type
)))
847 `(clear-info-value ,name
,(type-info-number info
)))
849 (defun clear-info-value (name type
)
850 (declare (type type-number type
) (inline assoc
))
851 (with-info-bucket (table index name
(get-write-info-env))
852 (let ((types (assoc name
(svref table index
) :test
#'equal
)))
854 (assoc type
(cdr types
)))
856 (delete type
(cdr types
) :key
#'car
))
859 ;;;; *INFO-ENVIRONMENT*
861 ;;; We do info access relative to the current *INFO-ENVIRONMENT*, a
862 ;;; list of INFO-ENVIRONMENT structures.
863 (defvar *info-environment
*)
864 (declaim (type list
*info-environment
*))
866 (setq *info-environment
*
867 (list (make-info-environment :name
"initial global")))
868 (/show0
"done setting *INFO-ENVIRONMENT*"))
869 ;;; FIXME: should perhaps be *INFO-ENV-LIST*. And rename
870 ;;; all FOO-INFO-ENVIRONMENT-BAR stuff to FOO-INFO-ENV-BAR.
874 ;;; Return the value of NAME / TYPE from the first environment where
875 ;;; has it defined, or return the default if none does. We used to
876 ;;; do a lot of complicated caching here, but that was removed for
877 ;;; thread-safety reasons.
878 (defun get-info-value (name0 type
&optional
(env-list nil env-list-p
))
879 (declare (type type-number type
))
880 ;; sanity check: If we have screwed up initialization somehow, then
881 ;; *INFO-TYPES* could still be uninitialized at the time we try to
882 ;; get an info value, and then we'd be out of luck. (This happened,
883 ;; and was confusing to debug, when rewriting EVAL-WHEN in
885 (aver (aref *info-types
* type
))
886 (let ((name (uncross name0
)))
887 (flet ((lookup (env-list)
889 (dolist (env env-list
890 (multiple-value-bind (val winp
)
891 (funcall (type-info-default
892 (svref *info-types
* type
))
895 (macrolet ((frob (lookup)
897 (setq hash
(globaldb-sxhashoid name
))
898 (multiple-value-bind (value winp
)
899 (,lookup env name hash type
)
900 (when winp
(return (values value t
)))))))
902 (volatile-info-env (frob volatile-info-lookup
))
903 (compact-info-env (frob compact-info-lookup
))))))))
906 (lookup *info-environment
*)))))
908 ;;;; definitions for function information
910 (define-info-class :function
)
912 ;;; the kind of functional object being described. If null, NAME isn't
913 ;;; a known functional object.
917 :type-spec
(member nil
:function
:macro
:special-form
)
918 ;; I'm a little confused what the correct behavior of this default
919 ;; is. It's not clear how to generalize the FBOUNDP expression to
920 ;; the cross-compiler. As far as I can tell, NIL is a safe default
921 ;; -- it might keep the compiler from making some valid
922 ;; optimization, but it shouldn't produce incorrect code. -- WHN
926 #-sb-xc-host
(if (fboundp name
) :function nil
))
928 ;;; The type specifier for this function.
933 ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
934 ;; not clear how to generalize the FBOUNDP expression to the
935 ;; cross-compiler. -- WHN 19990330
937 #+sb-xc-host
(specifier-type 'function
)
938 #-sb-xc-host
(if (fboundp name
)
939 (specifier-type (sb!impl
::%fun-type
(fdefinition name
)))
940 (specifier-type 'function
)))
942 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
943 ;;; due to not having a declaration or definition
947 ;; FIXME: The type-spec really should be
948 ;; (or approximate-fun-type null)).
949 ;; It was changed to T as a hopefully-temporary hack while getting
950 ;; cold init problems untangled.
953 ;;; where this information came from:
954 ;;; :ASSUMED = from uses of the object
955 ;;; :DEFINED = from examination of the definition
956 ;;; :DECLARED = from a declaration
957 ;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
958 ;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
959 ;;; and :DECLARED is useful for ANSIly specializing code which
960 ;;; implements the function, or which uses the function's return values.
964 :type-spec
(member :declared
:assumed
:defined
)
966 ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
967 ;; not clear how to generalize the FBOUNDP expression to the
968 ;; cross-compiler. -- WHN 19990606
969 #+sb-xc-host
:assumed
970 #-sb-xc-host
(if (fboundp name
) :defined
:assumed
))
972 ;;; something which can be decoded into the inline expansion of the
973 ;;; function, or NIL if there is none
975 ;;; To inline a function, we want a lambda expression, e.g.
976 ;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two
978 ;;; * The value in INFO can be the lambda expression itself, e.g.
979 ;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO)
980 ;;; '(LAMBDA (X) (+ X 1)))
981 ;;; This is the ordinary way, the natural way of representing e.g.
982 ;;; (DECLAIM (INLINE FOO))
983 ;;; (DEFUN FOO (X) (+ X 1))
984 ;;; * The value in INFO can be a closure which returns the lambda
986 ;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'BAR-LEFT-CHILD)
988 ;;; '(LAMBDA (BAR) (BAR-REF BAR 3))))
989 ;;; This twisty way of storing values is supported in order to
990 ;;; allow structure slot accessors, and perhaps later other
991 ;;; stereotyped functions, to be represented compactly.
994 :type
:inline-expansion-designator
995 :type-spec
(or list function
)
998 ;;; This specifies whether this function may be expanded inline. If
999 ;;; null, we don't care.
1006 ;;; a macro-like function which transforms a call to this function
1007 ;;; into some other Lisp form. This expansion is inhibited if inline
1008 ;;; expansion is inhibited
1011 :type
:source-transform
1012 :type-spec
(or function null
))
1014 ;;; the macroexpansion function for this macro
1017 :type
:macro-function
1018 :type-spec
(or function null
)
1021 ;;; the compiler-macroexpansion function for this macro
1024 :type
:compiler-macro-function
1025 :type-spec
(or function null
)
1028 ;;; a function which converts this special form into IR1
1032 :type-spec
(or function null
))
1034 ;;; If a function is "known" to the compiler, then this is a FUN-INFO
1035 ;;; structure containing the info used to special-case compilation.
1039 :type-spec
(or fun-info null
)
1044 :type
:documentation
1045 :type-spec
(or string null
)
1051 :type-spec
(or fdefn null
)
1054 ;;;; definitions for other miscellaneous information
1056 (define-info-class :variable
)
1058 ;;; the kind of variable-like thing described
1062 :type-spec
(member :special
:constant
:macro
:global
:alien
)
1063 :default
(if (symbol-self-evaluating-p name
)
1067 ;;; the declared type for this variable
1072 :default
*universal-type
*)
1074 ;;; where this type and kind information came from
1078 :type-spec
(member :declared
:assumed
:defined
)
1081 ;;; the Lisp object which is the value of this constant, if known
1084 :type
:constant-value
1086 ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..).
1087 ;; Now we don't: it was the last remaining multiple-value return from
1088 ;; the INFO system, and bringing it down to one value lets us simplify
1089 ;; things, especially simplifying the declaration of return types.
1090 ;; Software which used to check the second value (for "is it defined
1091 ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT)
1093 :default
(if (symbol-self-evaluating-p name
)
1095 (bug "constant lookup of nonconstant ~S" name
)))
1097 ;;; the macro-expansion for symbol-macros
1100 :type
:macro-expansion
1107 :type-spec
(or heap-alien-info null
)
1112 :type
:documentation
1113 :type-spec
(or string null
)
1116 (define-info-class :type
)
1118 ;;; the kind of type described. We return :INSTANCE for standard types
1119 ;;; that are implemented as structures. For PCL classes, that have
1120 ;;; only been compiled, but not loaded yet, we return
1121 ;;; :FORTHCOMING-DEFCLASS-TYPE.
1125 :type-spec
(member :primitive
:defined
:instance
1126 :forthcoming-defclass-type nil
)
1128 :validate-function
(lambda (name new-value
)
1129 (declare (ignore new-value
)
1131 (when (info :declaration
:recognized name
)
1132 (error 'declaration-type-conflict-error
1133 :format-arguments
(list name
)))))
1135 ;;; the expander function for a defined type
1139 :type-spec
(or function null
)
1144 :type
:documentation
1145 :type-spec
(or string null
))
1147 ;;; function that parses type specifiers into CTYPE structures
1151 :type-spec
(or function null
)
1154 ;;; If true, then the type coresponding to this name. Note that if
1155 ;;; this is a built-in class with a translation, then this is the
1156 ;;; translation, not the class object. This info type keeps track of
1157 ;;; various atomic types (NIL etc.) and also serves as a cache to
1158 ;;; ensure that common standard types (atomic and otherwise) are only
1163 :type-spec
(or ctype null
)
1166 ;;; If this is a class name, then the value is a cons (NAME . CLASS),
1167 ;;; where CLASS may be null if the class hasn't been defined yet. Note
1168 ;;; that for built-in classes, the kind may be :PRIMITIVE and not
1169 ;;; :INSTANCE. The name is in the cons so that we can signal a
1170 ;;; meaningful error if we only have the cons.
1174 :type-spec
(or sb
!kernel
::classoid-cell null
)
1177 ;;; layout for this type being used by the compiler
1180 :type
:compiler-layout
1181 :type-spec
(or layout null
)
1182 :default
(let ((class (find-classoid name nil
)))
1183 (when class
(classoid-layout class
))))
1185 (define-info-class :typed-structure
)
1187 :class
:typed-structure
1192 :class
:typed-structure
1193 :type
:documentation
1194 :type-spec
(or string null
)
1197 (define-info-class :declaration
)
1202 :validate-function
(lambda (name new-value
)
1203 (declare (ignore new-value
)
1205 (when (info :type
:kind name
)
1206 (error 'declaration-type-conflict-error
1207 :format-arguments
(list name
)))))
1209 (define-info-class :alien-type
)
1213 :type-spec
(member :primitive
:defined
:unknown
)
1218 :type-spec
(or function null
)
1223 :type-spec
(or alien-type null
)
1228 :type-spec
(or alien-type null
)
1233 :type-spec
(or alien-type null
)
1238 :type-spec
(or alien-type null
)
1241 (define-info-class :setf
)
1246 :type-spec
(or symbol null
)
1251 :type
:documentation
1252 :type-spec
(or string null
)
1258 :type-spec
(or function null
)
1261 ;;; This is used for storing miscellaneous documentation types. The
1262 ;;; stuff is an alist translating documentation kinds to values.
1263 (define-info-class :random-documentation
)
1265 :class
:random-documentation
1270 ;;; Used to record the source location of definitions.
1271 (define-info-class :source-location
)
1274 :class
:source-location
1280 :class
:source-location
1286 :class
:source-location
1287 :type
:typed-structure
1292 :class
:source-location
1297 #!-sb-fluid
(declaim (freeze-type info-env
))
1299 ;;; Now that we have finished initializing *INFO-CLASSES* and
1300 ;;; *INFO-TYPES* (at compile time), generate code to set them at cold
1301 ;;; load time to the same state they have currently.
1303 (/show0
"beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
1304 (setf *info-classes
*
1305 (make-hash-table :test
'eq
:size
#.
(hash-table-size *info-classes
*)))
1306 (/show0
"done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
1307 (dolist (class-info-name '#.
(let ((result nil
))
1308 (maphash (lambda (key value
)
1309 (declare (ignore value
))
1313 (let ((class-info (make-class-info class-info-name
)))
1314 (setf (gethash class-info-name
*info-classes
*)
1316 (/show0
"done with *INFO-CLASSES* initialization")
1317 (/show0
"beginning *INFO-TYPES* initialization")
1321 (/show0
"in LAMBDA (X), X=..")
1324 (let* ((class-info (class-info-or-lose (second x
)))
1325 (type-info (make-type-info :name
(first x
)
1329 (/show0
"got CLASS-INFO in LAMBDA (X)")
1330 (push type-info
(class-info-types class-info
))
1335 (list (type-info-name info-type
)
1336 (class-info-name (type-info-class info-type
))
1337 (type-info-number info-type
)
1338 (type-info-type info-type
))))
1340 (/show0
"done with *INFO-TYPES* initialization"))
1342 ;;; At cold load time, after the INFO-TYPE objects have been created,
1343 ;;; we can set their DEFAULT and TYPE slots.
1346 ,@(reverse *!reversed-type-info-init-forms
*))))
1349 ;;;; a hack for detecting
1350 ;;;; (DEFUN FOO (X Y)
1352 ;;;; (SETF (BAR A FFH) 12) ; compiles to a call to #'(SETF BAR)
1354 ;;;; (DEFSETF BAR SET-BAR) ; can't influence previous compilation
1356 ;;;; KLUDGE: Arguably it should be another class/type combination in
1357 ;;;; the globaldb. However, IMHO the whole globaldb/fdefinition
1358 ;;;; treatment of SETF functions is a mess which ought to be
1359 ;;;; rewritten, and I'm not inclined to mess with it short of that. So
1360 ;;;; I just put this bag on the side of it instead..
1362 ;;; true for symbols FOO which have been assumed to have '(SETF FOO)
1363 ;;; bound to a function
1364 (defvar *setf-assumed-fboundp
*)
1365 (!cold-init-forms
(setf *setf-assumed-fboundp
* (make-hash-table)))
1367 (!defun-from-collected-cold-init-forms
!globaldb-cold-init
)