Newer
Older
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.21 1992/02/15 12:07:02 wlott Exp $")
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
;;; **********************************************************************
;;;
;;; This file provides a functional interface to global information about
;;; named things in the system. Information is considered to be global if it
;;; must persist between invocations of the compiler. The use of a functional
;;; interface eliminates the need for the compiler to worry about the actual
;;; representation. This is important, since the information may well have
;;; several representations. This code also deals with the need for multiple
;;; "global" environments, so that changing something in the compiler doesn't
;;; trash the running Lisp environment.
;;;
;;; The database contains arbitrary Lisp values, addressed by a combination
;;; of Name, Class and Type. The Name is a EQUAL-thing which is the name of
;;; the thing we are recording information about. Class is the kind of object
;;; involved. Typical classes are Function, Variable, Type, ... A Type names
;;; a particular piece of information within a given class. Class and Type are
;;; symbols, but are compared with STRING=.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package "C")
(use-package "EXTENSIONS")
(use-package "SYSTEM")
(in-package "EXTENSIONS")
(export '(info clear-info define-info-class define-info-type
make-info-environment do-info *info-environment*
compact-info-environment))
(in-package "C")
;;; The defvar for this appears later.
(proclaim '(special *universal-type*))
(proclaim '(type list type-specifier-symbols))
;;; PRIMIFY -- Internal
;;;
;;; Given any non-negative integer, return a prime number >= to it.
;;;
(defun primify (x)
(declare (type unsigned-byte x))
(do ((n (logior x 1) (+ n 2)))
((system:primep n) n)))
;;;; Defining info types:
(eval-when (compile load eval)
(defstruct (class-info
(:constructor make-class-info (name))
(:print-function
(lambda (s stream d)
(declare (ignore d))
(format stream "#<Class-Info ~S>" (class-info-name s)))))
;;
;; String name of this class.
(name nil :type simple-string)
;;
;; List of Type-Info structures for each type in this class.
(types () :type list))
;;; At run-time, we represent the type of info that we want by a small
;;; non-negative integer.
;;;
(defconstant type-number-bits 6)
(deftype type-number () `(unsigned-byte ,type-number-bits))
;;;
;;; Also initialized in GLOBALDB-INIT...
(defvar *type-numbers*
(make-array (ash 1 type-number-bits) :initial-element nil))
(defstruct (type-info
(:print-function
(lambda (s stream d)
(declare (ignore d))
(format stream "#<Type-Info ~S ~S, Number = ~D>"
(class-info-name (type-info-class s))
(type-info-name s)
(type-info-number s)))))
;;
;; String name of this type.
(name (required-argument) :type simple-string)
(class (required-argument) :type class-info)
;;
;; A number that uniquely identifies this type (and implicitly its class.)
(number (required-argument) :type type-number)
;;
;; Type specifier which info of this type must satisfy.
(type nil :type t)
;;
;; Function called when there is no information of this type.
(default #'(lambda () (error "Type not defined yet.")) :type function))
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
;;; A hashtable from class names to Class-Info structures. This data structure
;;; exists at compile time as well as run time. Also initialized in
;;; GLOBALDB-INIT...
;;;
(defvar *info-classes* (make-hash-table :test #'equal))
(proclaim '(hash-table *info-classes*))
;;; FIND-TYPE-INFO -- Internal
;;;
;;; If Name is the name of a type in Class, then return the TYPE-INFO,
;;; otherwise NIL.
;;;
(defun find-type-info (name class)
(declare (simple-string name) (type class-info class))
(dolist (type (class-info-types class) nil)
(when (string= (type-info-name type) name)
(return type))))
;;; Class-Info-Or-Lose, Type-Info-Or-Lose -- Internal
;;;
;;; Return the info structure for an info class or type, or die trying.
;;;
(proclaim '(function class-info-or-lose (string) class-info))
(defun class-info-or-lose (class)
(or (gethash class *info-classes*)
(error "~S is not a defined info class." class)))
;;;
(proclaim '(function type-info-or-lose (string string) type-info))
(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)))
;;; Define-Info-Class -- Public
;;;
;;; 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.
;;;
(defmacro define-info-class (class)
"Define-Info-Class Class
Define a new class of global information."
`(progn
(eval-when (compile load eval)
(%define-info-class ',(symbol-name class)))
',class))
;;; %Define-Info-Class -- Internal
;;;
;;; If there is no info for the class, then create it, otherwise do nothing.
;;;
(proclaim '(function %define-info-class (string) void))
(defun %define-info-class (class)
(unless (gethash class *info-classes*)
(setf (gethash class *info-classes*) (make-class-info class))))
;;; FIND-UNUSED-TYPE-NUMBER -- Internal
;;;
;;; Find a type number not already in use by looking for a null entry in
;;; *TYPE-NUMBERS*.
;;;
(defun find-unused-type-number ()
(or (position nil *type-numbers*)
(error "Out of INFO type numbers!")))
;;; Define-Info-Type -- Public
;;;
;;; 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.
;;;
(defmacro define-info-type (class type type-spec &optional default)
"Define-Info-Type Class Type default Type-Spec
Define a new type of global information for Class. Type is the symbol 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."
(let* ((class (symbol-name class))
(type (symbol-name type))
(old (find-type-info type (class-info-or-lose class))))
`(progn
(eval-when (compile load eval)
(%define-info-type ',class ',type ',type-spec
,(if old
(type-info-number old)
(find-unused-type-number))))
(eval-when (load eval)
(setf (type-info-default (type-info-or-lose ',class ',type))
#'(lambda (name) name ,default)))
',type)))
;;; %Define-Info-Type -- Internal
;;;
;;; If there is no such type, create it. In any case, set the type
;;; specifier for the value. The class must exist.
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
;;;
(defun %define-info-type (class type type-spec number)
(declare (simple-string class type) (type type-number number))
(let* ((class-info (class-info-or-lose class))
(old (find-type-info type class-info))
(res (or old
(make-type-info :name type
:class class-info
:number number
:type type-spec)))
(num-old (svref *type-numbers* number)))
(cond (old
(setf (type-info-type res) type-spec)
(unless (= (type-info-number res) number)
(cerror "Redefine it." "Changing type number for ~A ~A."
class type)
(setf (type-info-number res) number)))
(t
(push res (class-info-types class-info))))
(unless (eq num-old res)
(when num-old
(cerror "Go for it." "Reusing type number for ~A ~A."
(class-info-name (type-info-class num-old))
(type-info-name num-old)))
(setf (svref *type-numbers* number) res)))
(undefined-value))
); eval-when (compile load eval)
;;;; Info environments:
;;;
;;; We do info access relative to the current *info-environment*. This is a
;;; list of INFO-ENVIRONMENT structures we search. The variable is actually
;;; initialized in GLOBALDB-INIT.
(defvar *info-environment*)
(proclaim '(type list *info-environment*))
(defun %print-info-environment (s stream d)
(declare (ignore d) (stream stream))
(format stream "#<~S ~S>" (type-of s) (info-env-name s)))
;;; 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 (:print-function %print-info-environment))
;;
;; Some string describing what is in this environment, for printing purposes
;; only.
(name (required-argument) :type string))
;;; INFO-HASH -- Internal
;;;
;;; Semantically equivalent to SXHASH, but optimized for legal function
;;; names. Note: semantically equivalent does *not* mean that it always
;;; returns the same value as SXHASH, just that it satisfies the formal
;;; definition of SXHASH.
;;;
;;; All we do for now is pick off the cases of a symbol and a list of two
;;; symbols [e.g. (SETF FOO)]. The symbol case is the same as what SXHASH
;;; does, but we get there more expeditiously. With the two-list, we LOGXOR a
;;; random constant with the hash of the second symbol.
;;;
(proclaim '(inline info-hash))
(defun info-hash (x)
(cond
((symbolp x)
(%sxhash-simple-string (symbol-name x)))
((and (listp x)
(eq (car x) 'setf))
(let ((next (cdr x)))
(when (listp next)
(let ((name (car next)))
(when (and (symbolp name) (null (cdr next)))
(return-from info-hash
(logxor (%sxhash-simple-string (symbol-name name))
110680597))))))
(sxhash x))
(t
(sxhash x))))
;;;; Generic interfaces:
;;; Info -- Public
;;;
;;; This is a macro so that we can resolve the Class and Type to a type
;;; number at compile time. When we check the new-value's type directly in the
;;; SETF expansion, since the check can be done much more efficiently when the
;;; type is constant.
;;;
(defmacro info (class type name)
"Return the information of the specified Type and Class for Name.
The second value is true if there is any such information recorded. If there
is no information, the first value is the default and the second value is NIL."
;;
;; ### Should be a values type, but interpreter can't hack that now.
(let* ((class (symbol-name class))
(type (symbol-name type))
(info (type-info-or-lose class type)))
`(truly-the ,(type-info-type info)
(get-info-value ,name ,(type-info-number info)))))
;;;
(define-setf-method info (class type name)
"Set the global information for Name."
(let* ((n-name (gensym))
(n-value (gensym))
(class-str (symbol-name class))
(type-str (symbol-name type))
(info (type-info-or-lose class-str type-str)))
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
(values
`(,n-name)
`(,name)
`(,n-value)
`(progn
(check-type ,n-value ,(type-info-type info))
(set-info-value ,n-name ,(type-info-number info) ,n-value))
`(info ,class ,type ,n-name))))
;;; DO-INFO -- Public
;;;
(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
(type-number (gensym)) (value (gensym)))
&body body)
"DO-INFO (Env &Key Name Class Type Value) Form*
Iterate over all the values stored in the Info-Env Env. Name is bound to
the entry's name, Class and Type are bound to the class and type
(represented as strings), and Value is bound to the entry's value."
(once-only ((n-env env))
`(if (typep ,n-env 'volatile-info-env)
,(do-volatile-info name class type type-number value n-env body)
,(do-compact-info name class type type-number value n-env body))))
(eval-when (compile load eval)
;;; DO-COMPACT-INFO -- Internal
;;;
;;; Return code to iterate over a compact info environment.
;;;
(defun do-compact-info (name-var class-var type-var type-number-var value-var
n-env body)
(let ((n-index (gensym)) (n-type (gensym)) (punt (gensym)))
(once-only ((n-table `(compact-info-env-table ,n-env))
(n-entries-index `(compact-info-env-index ,n-env))
(n-entries `(compact-info-env-entries ,n-env))
(n-entries-info `(compact-info-env-entries-info ,n-env))
(n-type-numbers '*type-numbers*))
`(dotimes (,n-index (length ,n-table))
(declare (type index ,n-index))
(block ,PUNT
(let ((,name-var (svref ,n-table ,n-index)))
(unless (eql ,name-var 0)
(do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
(1+ ,n-type)))
(nil)
(declare (type index ,n-type))
,(once-only ((n-info `(aref ,n-entries-info ,n-type)))
`(let ((,type-number-var
(logand ,n-info compact-info-entry-type-mask)))
,(once-only ((n-type-info
`(svref ,n-type-numbers
,type-number-var)))
`(let ((,type-var (type-info-name ,n-type-info))
(,class-var (class-info-name
(type-info-class ,n-type-info)))
(,value-var (svref ,n-entries ,n-type)))
(declare (ignorable ,type-var ,class-var
,value-var))
,@body
(unless (zerop (logand ,n-info compact-info-entry-last))
(return-from ,PUNT))))))))))))))
;;; DO-VOLATILE-INFO -- Internal
;;;
;;; Return code to iterate over a volatile info environment.
;;;
(defun do-volatile-info (name-var class-var type-var type-number-var value-var
n-env body)
(let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
(once-only ((n-table `(volatile-info-env-table ,n-env))
(n-type-numbers '*type-numbers*))
`(dotimes (,n-index (length ,n-table))
(do-anonymous ((,n-names (svref ,n-table ,n-index)
(cdr ,n-names)))
((null ,n-names))
(let ((,name-var (caar ,n-names)))
(declare (ignorable ,name-var))
(do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
((null ,n-types))
(let ((,type-number-var (caar ,n-types)))
,(once-only ((n-type `(svref ,n-type-numbers
,type-number-var)))
`(let ((,type-var (type-info-name ,n-type))
(,class-var (class-info-name
(type-info-class ,n-type)))
(,value-var (cdar ,n-types)))
(declare (ignorable ,type-var ,class-var ,value-var))
,@body))))))))))
); Eval-When (Compile Load Eval)
;;;; 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 nevern be destructively modified, so it is EQ to this, then the
;;; cache is valid.
;;;
(defvar *cached-info-environment*)
;;; INFO-CACHE-HASH -- Internal
;;;
;;; Hash function used for INFO cache.
;;;
(defmacro info-cache-hash (name type)
`(the fixnum
(logand
(the fixnum
(logxor (the fixnum (cache-hash-eq ,name))
(the fixnum (ash (the fixnum ,type) 7))))
#x3FF)))
(define-hash-cache info ((name eq) (type eq))
:values 2
:hash-function info-cache-hash
:hash-bits 10
:default (values nil :empty))
;;; INFO-CACHE-INIT -- Internal
;;;
;;; Set up the info cache. The top-level code of DEFINE-HASH-CACHE can't
;;; initialize the cache, since it must be initialized before we run any
;;; top-level forms. This is called in GLOBALDB-INIT.
(defun info-cache-init ()
(setq *cached-info-environment* nil)
(setq *info-cache-vector* (make-array (* 4 (ash 1 10))))
(info-cache-clear)
(undefined-value))
;;; Whenever we GC, we must blow away the INFO cache, otherwise values might
;;; become unreachable (and hence not be updated), and then could become
;;; reachable again in a future GC.
;;;
(defun info-cache-gc-hook ()
(setq *cached-info-environment* nil))
;;;
(pushnew 'info-cache-gc-hook *after-gc-hooks*)
;;; CLEAR-INVALID-INFO-CACHE -- Internal
;;;
;;; If the info cache is invalid, then clear it.
;;;
(proclaim '(inline clear-invalid-info-cache))
(defun clear-invalid-info-cache ()
(unless (eq *info-environment* *cached-info-environment*)
(without-interrupts
(info-cache-clear)
(setq *cached-info-environment* *info-environment*))))
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
;;;; Compact environments:
;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
;;;
(defconstant compact-info-env-entries-bits 16)
(deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
;;; Type of the values in COMPACT-INFO-ENTRIES-INFO.
;;;
(deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits)))
;;; This is an open hashtable with rehashing. Since modification is not
;;; allowed, we don't have to worry about deleted entries. We 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)
(:print-function %print-info-environment))
;;
;; 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 (required-argument) :type simple-vector)
;;
;; 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 (*)))
;;
;; 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 (*))))
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
(defconstant compact-info-entry-last (ash 1 type-number-bits))
;;; COMPACT-INFO-CACHE-HIT -- Internal
;;;
;;; Return the value of the type corresponding to Number for the currently
;;; cached name in Env.
;;;
(proclaim '(inline compact-info-cache-hit))
(defun compact-info-cache-hit (env number)
(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)))
(if index
(do ((index index (1+ index)))
(nil)
(declare (type index index))
(let ((info (aref entries-info index)))
(when (= (logand info compact-info-entry-type-mask) number)
(return (values (svref (compact-info-env-entries env) index)
t)))
(unless (zerop (logand compact-info-entry-last info))
(return (values nil nil)))))
(values nil nil))))
;;; COMPACT-INFO-LOOKUP -- Internal
;;;
;;; Encache Name in the compact environment Env. Hash is the INFO-HASH 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))
(len (length table))
(len-2 (- len 2))
(hash2 (- len-2 (rem hash len-2))))
(macrolet ((lookup (test)
`(do ((probe (rem hash len)
(rem (+ probe hash2) len)))
(nil)
(let ((entry (svref table probe)))
(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)))
(undefined-value))
;;; Exact density (modulo rounding) of the hashtable in a compact info
;;; environment in names/bucket.
;;;
(defconstant compact-info-environment-density 65)
;;; COMPACT-INFO-ENVIRONMENT -- Public
;;;
;;; 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.
;;;
(defun compact-info-environment (env &key (name (info-env-name env)))
"Return a new compact info environment that holds the same information as
Env."
(let ((name-count 0)
(prev-name 0)
(entry-count 0))
(collect ((names))
(let ((types ()))
(unless (eq name prev-name)
(incf name-count)
(unless (eql prev-name 0)
(names (cons prev-name types)))
(setq types ()))
(incf entry-count)
(push (cons num value) types))
(unless (eql prev-name 0)
(names (cons prev-name types))))
(let* ((table-size
(primify
(+ (truncate (* name-count 100)
compact-info-environment-density)
3)))
(table (make-array table-size :initial-element 0))
(index (make-array table-size
:element-type 'compact-info-entries-index))
(entries (make-array entry-count))
(entries-info (make-array entry-count
:element-type 'compact-info-entry))
(sorted (sort (names) #'(lambda (x y)
(< (%primitive make-fixnum x)
(%primitive make-fixnum y))))))
(let ((entries-idx 0))
(dolist (types sorted)
(let* ((name (first types))
(hash (info-hash name))
(len-2 (- table-size 2))
(hash2 (- len-2 (rem hash len-2))))
(do ((probe (rem hash table-size)
(rem (+ probe hash2) table-size)))
(nil)
(let ((entry (svref table probe)))
(when (eql entry 0)
(setf (svref table probe) name)
(setf (aref index probe) entries-idx)
(return))
(assert (not (equal entry name))))))
(unless (zerop entries-idx)
(setf (aref entries-info (1- entries-idx))
(logior (aref entries-info (1- entries-idx))
compact-info-entry-last)))
(loop for (num . value) in (rest types) do
(setf (aref entries-info entries-idx) num)
(setf (aref entries entries-idx) value)
(incf entries-idx)))
(unless (zerop entry-count)
(setf (aref entries-info (1- entry-count))
(logior (aref entries-info (1- entry-count))
compact-info-entry-last)))
(make-compact-info-env :name name
:table table
:index index
:entries entries
:entries-info entries-info))))))
;;;; Volatile environments:
;;; This is a closed hashtable, with the bucket being computed by taking the
;;; INFO-HASH of the Name mod the table size.
;;;
(defstruct (volatile-info-env
(:include info-env)
(:print-function %print-info-environment))
;;
;; 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 (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.
(count 0 :type index)
;;
;; The number of names at which we should grow the table and rehash.
(threshold 0 :type index))
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
;;; VOLATILE-INFO-CACHE-HIT -- Internal
;;;
;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
;;;
(proclaim '(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)))))
;;; VOLATILE-INFO-LOOKUP -- Internal
;;;
;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
;;;
(defun volatile-info-lookup (env name hash)
(declare (type volatile-info-env env) (type index hash))
(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)))
(undefined-value))
;;; WITH-INFO-BUCKET -- Internal
;;;
;;; 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 eval)
(defmacro with-info-bucket ((table-var index-var name env) &body body)
(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 (info-hash ,n-name) (length ,table-var))))
,@body)))))
;;; GET-WRITE-INFO-ENV -- Internal
;;;
;;; Get the info environment that we use for write/modification operations.
;;; This is always the first environment in the list, and must be a
;;; VOLATILE-INFO-ENV.
;;;
(proclaim '(inline get-write-info-env))
(defun get-write-info-env ()
(let ((env (car *info-environment*)))
(unless env
(error "No info environment?"))
(unless (typep env 'volatile-info-env)
(error "Cannot modify this environment: ~S." env))
(the volatile-info-env env)))
;;; SET-INFO-VALUE -- Internal
;;;
;;; If Name is already present in the table, then just create or modify the
;;; specified type. Otherwise, add the new name and type, checking for
;;; rehashing.
;;;
;;; We rehash by making a new larger environment, copying all of the entries
;;; into it, then clobbering the old environment with the new environment's
;;; table. We clear the old table to prevent it from holding onto garbage if
;;; it is statically allocated.
;;;
(defun set-info-value (name type new-value &optional
(env (get-write-info-env)))
(declare (type type-number type) (type volatile-info-env env)
(inline assoc))
(when (eql name 0)
(error "0 is not a legal INFO name."))
(clear-invalid-info-cache)
(info-cache-enter name type new-value t)
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
(with-info-bucket (table index name env)
(let ((types (if (symbolp name)
(assoc name (svref table index) :test #'eq)
(assoc name (svref table index) :test #'equal))))
(cond
(types
(let ((value (assoc type (cdr types))))
(if value
(setf (cdr value) new-value)
(push (cons type new-value) (cdr types)))))
(t
(push (cons name (list (cons type new-value)))
(svref table index))
(let ((count (incf (volatile-info-env-count env))))
(when (>= count (volatile-info-env-threshold env))
(let ((new (make-info-environment :size (* count 2))))
(do-info (env :name entry-name :type-number entry-num
:value entry-val)
(set-info-value entry-name entry-num entry-val new))
(fill (volatile-info-env-table env) nil)
(setf (volatile-info-env-table env)
(volatile-info-env-table new))
(setf (volatile-info-env-threshold env)
(volatile-info-env-threshold new)))))))))
new-value)
;;; The maximum density of the hashtable in a volatile env (in names/bucket).
;;;
(defconstant volatile-info-environment-density 50)
;;; MAKE-INFO-ENVIRONMENT -- Public
;;;
;;; Make a new volatile environment of the specified size.
;;;
(defun make-info-environment (&key (size 42) (name "Unknown"))
(declare (type (integer 1) size))
(let ((table-size
(primify (truncate (* size 100) volatile-info-environment-density))))
(make-volatile-info-env
:name name
:table (make-array table-size :initial-element nil)
:threshold size)))
;;; CLEAR-INFO -- Public
;;;
(defmacro clear-info (class type name)
"Clear the information of the 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* ((class (symbol-name class))
(type (symbol-name type))
(info (type-info-or-lose class type)))
`(clear-info-value ,name ,(type-info-number info))))
;;;
(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
(assoc type (cdr types)))
(setf (cdr types)
(delete type (cdr types) :key #'car))
t))))
;;;; GET-INFO-VALUE:
(eval-when (compile eval)
;;; GET-INFO-VALUE-SEARCH -- Internal
;;;
;;; 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.
;;;
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
(defmacro get-info-value-search ()
'(let ((hash nil))
(dolist (env *info-environment*
(multiple-value-bind
(val winp)
(funcall (type-info-default (svref *type-numbers* type))
name)
(values val winp)))
(macrolet ((frob (lookup cache slot)
`(progn
(unless (eq name (,slot env))
(unless hash
(setq hash (info-hash name)))
(setf (,slot env) 0)
(,lookup env name hash))
(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))))))
); Eval-When (Compile Eval)
;;; GET-INFO-VALUE -- Internal
;;;
;;; Check if the name and type is in our cache, if so return it. Otherwise,
;;; search for the value and encache it.
;;;
(defun get-info-value (name type)
(declare (type type-number type))
(clear-invalid-info-cache)
(multiple-value-bind (val winp)
(info-cache-lookup name type)
(if (eq winp :empty)
(multiple-value-bind (val winp)
(get-info-value-search)
(info-cache-enter name type val winp)
(values val winp))
(values val winp))))
;;;; Initialization:
;;; GLOBALDB-INIT -- Interface
;;;
;;; Since the global enviornment database is used by top-level forms in this
;;; file, we must initialize the database before processing any top-level
;;; forms. This requires a special initialization function that is called from
;;; %INITIAL-FUNCTION. We replicate the init forms of the variables that
;;; maintain the class/type namespace. We also initialize the info cache.
(unless (boundp '*info-environment*)
(setq *info-environment*
(list (make-info-environment :name "Initial Global"))))
(unless (boundp '*info-classes*)
(setq *info-classes* (make-hash-table :test #'equal))
(setq *type-numbers*
(make-array (ash 1 type-number-bits) :initial-element nil)))
(info-cache-init)
(function-info-init)
(other-info-init))
;;;; Definitions for function information.
(defun function-info-init ()
(define-info-class function)
;;; The kind of functional object being described. If null, Name isn't a known
;;; functional object.
(define-info-type function kind (member nil :function :macro :special-form)
;;; The type specifier for this function.
(define-info-type function type ctype
(if (fboundp name)
(let ((def (fdefinition name)))
(if (eval:interpreted-function-p def)
(eval:interpreted-function-type def)
(specifier-type (%primitive function-type
(%primitive closure-function def)))))
;;; The Assumed-Type for this function, if we have to infer the type due to not
;;; having a declaration or definition.
(define-info-type function assumed-type (or approximate-function-type null))
;;; Where this information came from:
;;; :declared, from a declaration.
;;; :assumed, from uses of the object.
;;; :defined, from examination of the definition.
(define-info-type function where-from (member :declared :assumed :defined)