1 ;;;; that part of the CMU CL package.lisp file which can run on the
2 ;;;; cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!IMPL")
18 ;;;; the PACKAGE-HASHTABLE structure
20 ;;; comment from CMU CL:
21 ;;; Packages are implemented using a special kind of hashtable. It is
22 ;;; an open hashtable with a parallel 8-bit I-vector of hash-codes. The
23 ;;; primary purpose of the hash for each entry is to reduce paging by
24 ;;; allowing collisions and misses to be detected without paging in the
25 ;;; symbol and pname for an entry. If the hash for an entry doesn't
26 ;;; match that for the symbol that we are looking for, then we can
27 ;;; go on without touching the symbol, pname, or even hastable vector.
28 ;;; It turns out that, contrary to my expectations, paging is a very
29 ;;; important consideration the design of the package representation.
30 ;;; Using a similar scheme without the entry hash, the fasloader was
31 ;;; spending more than half its time paging in INTERN.
32 ;;; The hash code also indicates the status of an entry. If it zero,
33 ;;; the entry is unused. If it is one, then it is deleted.
34 ;;; Double-hashing is used for collision resolution.
36 (sb!xc:deftype hash-vector () '(simple-array (unsigned-byte 8) (*)))
38 (sb!xc:defstruct (package-hashtable (:constructor %make-package-hashtable ())
40 ;; The g-vector of symbols.
41 ;; FIXME: could just be type SIMPLE-VECTOR, with REQUIRED-ARGUMENT
42 (table nil :type (or simple-vector null))
43 ;; The i-vector of pname hash values.
44 ;; FIXME: could just be type HASH-VECTOR, with REQUIRED-ARGUMENT
45 (hash nil :type (or hash-vector null))
46 ;; The total number of entries allowed before resizing.
48 ;; FIXME: CAPACITY would be a more descriptive name. (This is
49 ;; related to but not quite the same as HASH-TABLE-SIZE, so calling
50 ;; it SIZE seems somewhat misleading.)
52 ;; The remaining number of entries that can be made before we have to rehash.
54 ;; The number of deleted entries.
55 (deleted 0 :type index))
57 ;;;; the PACKAGE structure
59 ;;; KLUDGE: We use DEF!STRUCT to define this not because we need to
60 ;;; manipulate target package objects on the cross-compilation host,
61 ;;; but only because its MAKE-LOAD-FORM function needs to be hooked
62 ;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system. The DEF!STRUCT
63 ;;; side-effect of defining a new PACKAGE type on the
64 ;;; cross-compilation host is just a nuisance, and in order to avoid
65 ;;; breaking the cross-compilation host, we need to work around it
66 ;;; around by putting the new PACKAGE type (and the PACKAGEP predicate
67 ;;; too..) into SB!XC. -- WHN 20000309
68 (def!struct (sb!xc:package
69 (:constructor internal-make-package)
70 (:make-load-form-fun (lambda (p)
71 (values `(find-undeleted-package-or-lose
74 (:predicate sb!xc:packagep))
76 "the standard structure for the description of a package"
77 ;; the name of the package, or NIL for a deleted package
78 (%name nil :type (or simple-string null))
80 (%nicknames () :type list)
81 ;; packages used by this package
82 (%use-list () :type list)
83 ;; a list of all the hashtables for inherited symbols. This is
84 ;; derived from %USE-LIST, but maintained separately from %USE-LIST
85 ;; for some reason. (Perhaps the reason is that when FIND-SYMBOL*
86 ;; hits an inherited symbol, it pulls it to the head of the list.)
88 ;; FIXME: This needs a more-descriptive name
89 ;; (USED-PACKAGE-HASH-TABLES?). It also needs an explanation of why
90 ;; the last entry is NIL. Perhaps it should even just go away and
91 ;; let us do indirection on the fly through %USE-LIST. (If so,
92 ;; benchmark to make sure that performance doesn't get stomped..)
93 ;; (If benchmark performance is important, this should prob'ly
94 ;; become a vector instead of a list.)
95 (tables (list nil) :type list)
96 ;; packages that use this package
97 (%used-by-list () :type list)
98 ;; PACKAGE-HASHTABLEs of internal & external symbols
99 (internal-symbols (required-argument) :type package-hashtable)
100 (external-symbols (required-argument) :type package-hashtable)
102 (%shadowing-symbols () :type list)
103 ;; documentation string for this package
104 (doc-string nil :type (or simple-string null)))
106 ;;;; iteration macros
108 (defmacro-mundanely do-symbols ((var &optional
113 "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
114 Executes the FORMs at least once for each symbol accessible in the given
115 PACKAGE with VAR bound to the current symbol."
116 (multiple-value-bind (body decls) body-decls
117 (let ((flet-name (gensym "DO-SYMBOLS-")))
119 (flet ((,flet-name (,var)
122 (let* ((package (find-undeleted-package-or-lose ,package))
123 (shadows (package-%shadowing-symbols package)))
124 (flet ((iterate-over-hash-table (table ignore)
125 (let ((hash-vec (package-hashtable-hash table))
126 (sym-vec (package-hashtable-table table)))
127 (declare (type (simple-array (unsigned-byte 8) (*))
129 (type simple-vector sym-vec))
130 (dotimes (i (length sym-vec))
131 (when (>= (aref hash-vec i) 2)
132 (let ((sym (aref sym-vec i)))
133 (declare (inline member))
134 (unless (member sym ignore :test #'string=)
135 (,flet-name sym))))))))
136 (iterate-over-hash-table (package-internal-symbols package) nil)
137 (iterate-over-hash-table (package-external-symbols package) nil)
138 (dolist (use (package-%use-list package))
139 (iterate-over-hash-table (package-external-symbols use)
142 (declare (ignorable ,var))
146 (defmacro-mundanely do-external-symbols ((var &optional
151 "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
152 Executes the FORMs once for each external symbol in the given PACKAGE with
153 VAR bound to the current symbol."
154 (multiple-value-bind (body decls) (parse-body body-decls nil)
155 (let ((flet-name (gensym "DO-SYMBOLS-")))
157 (flet ((,flet-name (,var)
160 (let* ((package (find-undeleted-package-or-lose ,package))
161 (table (package-external-symbols package))
162 (hash-vec (package-hashtable-hash table))
163 (sym-vec (package-hashtable-table table)))
164 (declare (type (simple-array (unsigned-byte 8) (*))
166 (type simple-vector sym-vec))
167 (dotimes (i (length sym-vec))
168 (when (>= (aref hash-vec i) 2)
169 (,flet-name (aref sym-vec i))))))
171 (declare (ignorable ,var))
175 (defmacro-mundanely do-all-symbols ((var &optional
179 "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
180 Executes the FORMs once for each symbol in every package with VAR bound
181 to the current symbol."
182 (multiple-value-bind (body decls) (parse-body body-decls nil)
183 (let ((flet-name (gensym "DO-SYMBOLS-")))
185 (flet ((,flet-name (,var)
188 (dolist (package (list-all-packages))
189 (flet ((iterate-over-hash-table (table)
190 (let ((hash-vec (package-hashtable-hash table))
191 (sym-vec (package-hashtable-table table)))
192 (declare (type (simple-array (unsigned-byte 8) (*))
194 (type simple-vector sym-vec))
195 (dotimes (i (length sym-vec))
196 (when (>= (aref hash-vec i) 2)
197 (,flet-name (aref sym-vec i)))))))
198 (iterate-over-hash-table (package-internal-symbols package))
199 (iterate-over-hash-table (package-external-symbols package)))))
201 (declare (ignorable ,var))
205 ;;;; WITH-PACKAGE-ITERATOR
207 (defmacro-mundanely with-package-iterator ((mname package-list
211 "Within the lexical scope of the body forms, MNAME is defined via macrolet
212 such that successive invocations of (MNAME) will return the symbols,
213 one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be
214 any of :INHERITED :EXTERNAL :INTERNAL."
215 (let* ((packages (gensym))
216 (these-packages (gensym))
217 (ordered-types (let ((res nil))
218 (dolist (kind '(:inherited :external :internal)
220 (when (member kind symbol-types)
221 (push kind res))))) ; Order SYMBOL-TYPES.
224 (hash-vector (gensym))
226 (package-use-list (gensym))
227 (init-macro (gensym))
228 (end-test-macro (gensym))
229 (real-symbol-p (gensym))
230 (inherited-symbol-p (gensym))
232 `(let* ((,these-packages ,package-list)
233 (,packages `,(mapcar #'(lambda (package)
234 (if (packagep package)
236 (find-package package)))
237 (if (consp ,these-packages)
239 (list ,these-packages))))
241 (,kind (car ,packages))
244 (,package-use-list nil))
245 ,(if (member :inherited ordered-types)
246 `(setf ,package-use-list (package-%use-list (car ,packages)))
247 `(declare (ignore ,package-use-list)))
248 (macrolet ((,init-macro (next-kind)
249 (let ((symbols (gensym)))
251 (setf ,',kind ,next-kind)
252 (setf ,',counter nil)
255 `(let ((,symbols (package-internal-symbols
258 (setf ,',vector (package-hashtable-table ,symbols))
259 (setf ,',hash-vector (package-hashtable-hash ,symbols)))))
261 `(let ((,symbols (package-external-symbols
264 (setf ,',vector (package-hashtable-table ,symbols))
266 (package-hashtable-hash ,symbols)))))
268 `(let ((,symbols (and ,',package-use-list
269 (package-external-symbols
270 (car ,',package-use-list)))))
272 (setf ,',vector (package-hashtable-table ,symbols))
274 (package-hashtable-hash ,symbols)))))))))
275 (,end-test-macro (this-kind)
276 `,(let ((next-kind (cadr (member this-kind
279 `(,',init-macro ,next-kind)
280 `(if (endp (setf ,',packages (cdr ,',packages)))
281 (return-from ,',BLOCK)
282 (,',init-macro ,(car ',ordered-types)))))))
284 ,(when (null symbol-types)
285 (error 'program-error
287 "Must supply at least one of :internal, :external, or ~
289 ,(dolist (symbol symbol-types)
290 (unless (member symbol '(:internal :external :inherited))
291 (error 'program-error
293 "~S is not one of :internal, :external, or :inherited."
294 :format-argument symbol)))
295 (,init-macro ,(car ordered-types))
296 (flet ((,real-symbol-p (number)
298 (macrolet ((,mname ()
302 ,@(when (member :internal ',ordered-types)
305 (position-if #',',real-symbol-p ,',hash-vector
306 :start (if ,',counter
310 (return-from ,',BLOCK
311 (values t (svref ,',vector ,',counter)
312 ,',kind (car ,',packages)))
313 (,',end-test-macro :internal)))))
314 ,@(when (member :external ',ordered-types)
317 (position-if #',',real-symbol-p ,',hash-vector
318 :start (if ,',counter
322 (return-from ,',BLOCK
323 (values t (svref ,',vector ,',counter)
324 ,',kind (car ,',packages)))
325 (,',end-test-macro :external)))))
326 ,@(when (member :inherited ',ordered-types)
328 (flet ((,',inherited-symbol-p (number)
329 (when (,',real-symbol-p number)
331 number ,',hash-vector
332 :start (if ,',counter
335 (s (svref ,',vector p)))
342 (position-if #',',inherited-symbol-p
344 :start (if ,',counter
350 (values t (svref ,',vector ,',counter)
351 ,',kind (car ,',packages))
354 (setf ,',package-use-list
355 (cdr ,',package-use-list))
356 (cond ((endp ,',package-use-list)
357 (setf ,',packages (cdr ,',packages))
358 (when (endp ,',packages)
359 (return-from ,',BLOCK))
360 (setf ,',package-use-list
365 (t (,',init-macro :inherited)
366 (setf ,',counter nil)))))))))))))