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")
15 ;;;; the PACKAGE-HASHTABLE structure
17 ;;; comment from CMU CL:
18 ;;; Packages are implemented using a special kind of hashtable. It is
19 ;;; an open hashtable with a parallel 8-bit I-vector of hash-codes. The
20 ;;; primary purpose of the hash for each entry is to reduce paging by
21 ;;; allowing collisions and misses to be detected without paging in the
22 ;;; symbol and pname for an entry. If the hash for an entry doesn't
23 ;;; match that for the symbol that we are looking for, then we can
24 ;;; go on without touching the symbol, pname, or even hastable vector.
25 ;;; It turns out that, contrary to my expectations, paging is a very
26 ;;; important consideration the design of the package representation.
27 ;;; Using a similar scheme without the entry hash, the fasloader was
28 ;;; spending more than half its time paging in INTERN.
29 ;;; The hash code also indicates the status of an entry. If it zero,
30 ;;; the entry is unused. If it is one, then it is deleted.
31 ;;; Double-hashing is used for collision resolution.
33 ;; FIXME: too vaguely named. Should be PACKAGE-HASH-VECTOR.
34 (def!type hash-vector
() '(simple-array (unsigned-byte 8) (*)))
36 (def!struct
(package-hashtable
37 (:constructor %make-package-hashtable
38 (cells size
&aux
(free size
)))
40 ;; The general-vector of symbols, with a hash-vector in its last cell.
41 (cells (missing-arg) :type simple-vector
)
42 ;; The total number of entries allowed before resizing.
44 ;; FIXME: CAPACITY would be a more descriptive name. (This is
45 ;; related to but not quite the same as HASH-TABLE-SIZE, so calling
46 ;; it SIZE seems somewhat misleading.)
47 (size (missing-arg) :type index
)
48 ;; The remaining number of entries that can be made before we have to rehash.
49 (free (missing-arg) :type index
)
50 ;; The number of deleted entries.
51 (deleted 0 :type index
))
53 ;;;; the PACKAGE structure
55 ;;; Meta: IN-PACKAGE references a string constant, not a package.
56 ;;; But we need this to be a DEF!STRUCT to emit 'package.h'
57 ;;; during first genesis.
58 ;;; KLUDGE: We use DEF!STRUCT to define this not because we need to
59 ;;; manipulate target package objects on the cross-compilation host,
60 ;;; but only because its MAKE-LOAD-FORM function needs to be hooked
61 ;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system so that we can
62 ;;; compile things like IN-PACKAGE in warm init before CLOS is set up.
63 ;;; The DEF!STRUCT 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 simple-vector of the external symbol hashtables for used packages.
84 ;; Derived from %USE-LIST, but maintained separately.
85 (tables #() :type simple-vector
)
86 ;; index into TABLES of the table in which an inherited symbol was most
87 ;; recently found. On the next FIND-SYMBOL* operation, the indexed table
89 (mru-table-index 0 :type index
)
90 ;; packages that use this package
91 (%used-by-list
() :type list
)
92 ;; PACKAGE-HASHTABLEs of internal & external symbols
93 (internal-symbols (missing-arg) :type package-hashtable
)
94 (external-symbols (missing-arg) :type package-hashtable
)
96 ;; Todo: dynamically changeover to a PACKAGE-HASHTABLE if list gets long
97 (%shadowing-symbols
() :type list
)
98 ;; documentation string for this package
99 (doc-string nil
:type
(or simple-string null
))
102 (lock nil
:type boolean
)
104 (%implementation-packages nil
:type list
)
105 ;; Definition source location
106 (source-location nil
:type
(or null sb
!c
:definition-source-location
))
107 ;; Local package nicknames.
108 (%local-nicknames nil
:type list
)
109 (%locally-nicknamed-by nil
:type list
))
111 ;;;; iteration macros
113 (flet ((expand-iterator (range var body result-form
)
114 (multiple-value-bind (forms decls
)
115 (parse-body body
:doc-string-allowed nil
)
116 (with-unique-names (iterator winp next
)
118 (with-package-iterator (,iterator
,@range
)
121 (multiple-value-bind (,winp
,var
) (,iterator
)
122 ;; I don't think this VAR is automatically ignorable.
123 ;; The user should use it, or declare IGNORE/IGNORABLE.
126 (tagbody ,@forms
(go ,next
))
127 (return ,result-form
))))))))))
129 (defmacro-mundanely do-symbols
((var &optional
134 "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
135 Executes the FORMs at least once for each symbol accessible in the given
136 PACKAGE with VAR bound to the current symbol."
137 (expand-iterator `((find-undeleted-package-or-lose ,package
)
138 :internal
:external
:inherited
)
139 var body-decls result-form
))
141 (defmacro-mundanely do-external-symbols
((var &optional
146 "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
147 Executes the FORMs once for each external symbol in the given PACKAGE with
148 VAR bound to the current symbol."
149 (expand-iterator `((find-undeleted-package-or-lose ,package
) :external
)
150 var body-decls result-form
))
152 (defmacro-mundanely do-all-symbols
((var &optional
156 "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
157 Executes the FORMs once for each symbol in every package with VAR bound
158 to the current symbol."
159 (expand-iterator '((list-all-packages) :internal
:external
)
160 var body-decls result-form
)))
163 ;;;; WITH-PACKAGE-ITERATOR
165 (defun package-iter-init (access-types pkg-designator-list
)
166 (declare (type (integer 1 7) access-types
)) ; a nonzero bitmask over types
167 (values (logior (ash access-types
3) #b11
) 0 #()
168 (package-listify pkg-designator-list
)))
170 (declaim (inline pkg-symbol-valid-p
))
171 (defun pkg-symbol-valid-p (x) (not (fixnump x
)))
173 ;; The STATE parameter is comprised of 4 packed fields
174 ;; [0:1] = substate {0=internal,1=external,2=inherited,3=initial}
175 ;; [2] = package with inherited symbols has shadowing symbols
176 ;; [3:5] = enabling bits for {internal,external,inherited}
177 ;; [6:] = index into 'package-tables'
179 (defconstant +package-iter-check-shadows
+ #b000100
)
181 (defun package-iter-step (start-state index sym-vec pkglist
)
182 ;; the defknown isn't enough
183 (declare (type fixnum start-state
) (type index index
)
184 (type simple-vector sym-vec
) (type list pkglist
))
185 (declare (optimize speed
))
187 ((advance (state) ; STATE is the one just completed
188 (case (logand state
#b11
)
189 ;; Test :INHERITED first because the state repeats for a package
190 ;; as many times as there are packages it uses. There are enough
191 ;; bits to count up to 2^23 packages if fixnums are 30 bits.
193 (when (desired-state-p 2)
194 (let* ((tables (package-tables (this-package)))
195 (next-state (the fixnum
(+ state
(ash 1 6))))
196 (table-idx (ash next-state -
6)))
197 (when (< table-idx
(length tables
))
198 (return-from advance
; remain in state 2
199 (start next-state
(svref tables table-idx
))))))
201 (advance 3)) ; start on next package
202 (1 ; finished externals, switch to inherited if desired
203 (when (desired-state-p 2)
204 (let ((tables (package-tables (this-package))))
205 (when (plusp (length tables
)) ; inherited symbols
206 (return-from advance
; enter state 2
207 (start (if (package-%shadowing-symbols
(this-package))
208 (logior 2 +package-iter-check-shadows
+) 2)
209 (svref tables
0))))))
210 (advance 2)) ; skip state 2
211 (0 ; finished internals, switch to externals if desired
212 (if (desired-state-p 1) ; enter state 1
213 (start 1 (package-external-symbols (this-package)))
214 (advance 1))) ; skip state 1
216 (cond ((endp pkglist
) ; latch into returning NIL forever more
217 (values 0 0 #() '() nil nil
))
218 ((desired-state-p 0) ; enter state 0
219 (start 0 (package-internal-symbols (this-package))))
220 (t (advance 0)))))) ; skip state 0
221 (desired-state-p (target-state)
222 (logtest start-state
(ash 1 (+ target-state
3))))
224 (truly-the sb
!xc
:package
(car pkglist
)))
225 (start (next-state new-table
)
226 (let ((symbols (package-hashtable-cells new-table
)))
227 (package-iter-step (logior (mask-field (byte 3 3) start-state
)
229 ;; assert that physical length was nonzero
230 (the index
(1- (length symbols
)))
232 (declare (inline desired-state-p this-package
))
234 (advance start-state
)
235 (macrolet ((scan (&optional
(guard t
))
237 (let ((sym (aref sym-vec
(decf index
))))
238 (when (and (pkg-symbol-valid-p sym
) ,guard
)
239 (return (values start-state index sym-vec pkglist sym
240 (aref #(:internal
:external
:inherited
)
241 (logand start-state
3))))))
243 (return (advance start-state
))))))
244 (declare #-sb-xc-host
(optimize (sb!c
::insert-array-bounds-checks
0)))
245 (if (logtest start-state
+package-iter-check-shadows
+)
246 (let ((shadows (package-%shadowing-symbols
(this-package))))
247 (scan (not (member sym shadows
:test
#'string
=))))
250 (defmacro-mundanely with-package-iterator
((mname package-list
254 "Within the lexical scope of the body forms, MNAME is defined via macrolet
255 such that successive invocations of (MNAME) will return the symbols, one by
256 one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any
257 of :INHERITED :EXTERNAL :INTERNAL."
258 ;; SYMBOL-TYPES should really be named ACCESSIBILITY-TYPES.
259 (when (null symbol-types
)
260 (error 'simple-program-error
262 "At least one of :INTERNAL, :EXTERNAL, or :INHERITED must be supplied."))
263 (dolist (symbol symbol-types
)
264 (unless (member symbol
'(:internal
:external
:inherited
))
265 (error 'simple-program-error
267 "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
268 :format-arguments
(list symbol
))))
269 (with-unique-names (bits index sym-vec pkglist symbol kind
)
270 (let ((state (list bits index sym-vec pkglist
))
271 (select (logior (if (member :internal symbol-types
) 1 0)
272 (if (member :external symbol-types
) 2 0)
273 (if (member :inherited symbol-types
) 4 0))))
274 `(multiple-value-bind ,state
(package-iter-init ,select
,package-list
)
278 '(if (eql 0 (multiple-value-setq (,@state
,symbol
,kind
)
279 (package-iter-step ,@state
)))
281 (values t
,symbol
,kind
282 (car (truly-the list
,pkglist
))))))
285 (defmacro-mundanely with-package-graph
((&key
) &body forms
)
286 `(flet ((thunk () ,@forms
))
287 (declare (dynamic-extent #'thunk
))
288 (call-with-package-graph #'thunk
)))