src/code/package.lisp

   1 ;;;; that part of the CMU CL package.lisp file which can run on the
   2 ;;;; cross-compilation host
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   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.
  12
  13 (in-package "SB!IMPL")
  14 \f
  15 ;;;; the PACKAGE-HASHTABLE structure
  16
  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.
  32
  33 (def!type hash-vector () '(simple-array (unsigned-byte 8) (*)))
  34
  35 (def!struct (package-hashtable
  36              (:constructor %make-package-hashtable
  37                            (table hash size &aux (free size)))
  38              (:copier nil))
  39   ;; The g-vector of symbols.
  40   (table (missing-arg) :type simple-vector)
  41   ;; The i-vector of pname hash values.
  42   (hash (missing-arg) :type hash-vector)
  43   ;; The total number of entries allowed before resizing.
  44   ;;
  45   ;; FIXME: CAPACITY would be a more descriptive name. (This is
  46   ;; related to but not quite the same as HASH-TABLE-SIZE, so calling
  47   ;; it SIZE seems somewhat misleading.)
  48   (size (missing-arg) :type index)
  49   ;; The remaining number of entries that can be made before we have to rehash.
  50   (free (missing-arg) :type index)
  51   ;; The number of deleted entries.
  52   (deleted 0 :type index))
  53 \f
  54 ;;;; the PACKAGE structure
  55
  56 ;;; KLUDGE: We use DEF!STRUCT to define this not because we need to
  57 ;;; manipulate target package objects on the cross-compilation host,
  58 ;;; but only because its MAKE-LOAD-FORM function needs to be hooked
  59 ;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system so that we can
  60 ;;; compile things like IN-PACKAGE in warm init before CLOS is set up.
  61 ;;; The DEF!STRUCT side effect of defining a new PACKAGE type on the
  62 ;;; cross-compilation host is just a nuisance, and in order to avoid
  63 ;;; breaking the cross-compilation host, we need to work around it
  64 ;;; around by putting the new PACKAGE type (and the PACKAGEP predicate
  65 ;;; too..) into SB!XC. -- WHN 20000309
  66 (def!struct (sb!xc:package
  67              (:constructor internal-make-package)
  68              (:make-load-form-fun (lambda (p)
  69                                     (values `(find-undeleted-package-or-lose
  70                                               ',(package-name p))
  71                                             nil)))
  72              (:predicate sb!xc:packagep))
  73   #!+sb-doc
  74   "the standard structure for the description of a package"
  75   ;; the name of the package, or NIL for a deleted package
  76   (%name nil :type (or simple-string null))
  77   ;; nickname strings
  78   (%nicknames () :type list)
  79   ;; packages used by this package
  80   (%use-list () :type list)
  81   ;; a simple-vector of the external symbol hashtables for used packages.
  82   ;; Derived from %USE-LIST, but maintained separately.
  83   (tables #() :type simple-vector)
  84   ;; index into TABLES of the table in which an inherited symbol was most
  85   ;; recently found. On the next FIND-SYMBOL* operation, the indexed table
  86   ;; is tested first.
  87   (mru-table-index 0 :type index)
  88   ;; packages that use this package
  89   (%used-by-list () :type list)
  90   ;; PACKAGE-HASHTABLEs of internal & external symbols
  91   (internal-symbols (missing-arg) :type package-hashtable)
  92   (external-symbols (missing-arg) :type package-hashtable)
  93   ;; shadowing symbols
  94   (%shadowing-symbols () :type list)
  95   ;; documentation string for this package
  96   (doc-string nil :type (or simple-string null))
  97   ;; package locking
  98   #!+sb-package-locks
  99   (lock nil :type boolean)
 100   #!+sb-package-locks
 101   (%implementation-packages nil :type list)
 102   ;; Definition source location
 103   (source-location nil :type (or null sb!c:definition-source-location))
 104   ;; Local package nicknames.
 105   (%local-nicknames nil :type list)
 106   (%locally-nicknamed-by nil :type list))
 107 \f
 108 ;;;; iteration macros
 109
 110 (defmacro-mundanely do-symbols ((var &optional
 111                                      (package '*package*)
 112                                      result-form)
 113                                 &body body-decls)
 114   #!+sb-doc
 115   "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
 116    Executes the FORMs at least once for each symbol accessible in the given
 117    PACKAGE with VAR bound to the current symbol."
 118   (multiple-value-bind (body decls)
 119       (parse-body body-decls :doc-string-allowed nil)
 120     (let ((flet-name (sb!xc:gensym "DO-SYMBOLS-")))
 121       `(block nil
 122          (flet ((,flet-name (,var)
 123                   ,@decls
 124                   (tagbody ,@body)))
 125            (let* ((package (find-undeleted-package-or-lose ,package))
 126                   (shadows (package-%shadowing-symbols package)))
 127              (flet ((iterate-over-hash-table (table ignore)
 128                       (let ((hash-vec (package-hashtable-hash table))
 129                             (sym-vec (package-hashtable-table table)))
 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)
 140                                           shadows)))))
 141          (let ((,var nil))
 142            (declare (ignorable ,var))
 143            ,@decls
 144            ,result-form)))))
 145
 146 (defmacro-mundanely do-external-symbols ((var &optional
 147                                               (package '*package*)
 148                                               result-form)
 149                                          &body body-decls)
 150   #!+sb-doc
 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)
 155       (parse-body body-decls :doc-string-allowed nil)
 156     (let ((flet-name (sb!xc:gensym "DO-SYMBOLS-")))
 157       `(block nil
 158          (flet ((,flet-name (,var)
 159                   ,@decls
 160                   (tagbody ,@body)))
 161            (let* ((package (find-undeleted-package-or-lose ,package))
 162                   (table (package-external-symbols package))
 163                   (hash-vec (package-hashtable-hash table))
 164                   (sym-vec (package-hashtable-table table)))
 165              (dotimes (i (length sym-vec))
 166                (when (>= (aref hash-vec i) 2)
 167                  (,flet-name (aref sym-vec i))))))
 168          (let ((,var nil))
 169            (declare (ignorable ,var))
 170            ,@decls
 171            ,result-form)))))
 172
 173 (defmacro-mundanely do-all-symbols ((var &optional
 174                                          result-form)
 175                                     &body body-decls)
 176   #!+sb-doc
 177   "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
 178    Executes the FORMs once for each symbol in every package with VAR bound
 179    to the current symbol."
 180   (multiple-value-bind (body decls)
 181       (parse-body body-decls :doc-string-allowed nil)
 182     (let ((flet-name (sb!xc:gensym "DO-SYMBOLS-")))
 183       `(block nil
 184          (flet ((,flet-name (,var)
 185                   ,@decls
 186                   (tagbody ,@body)))
 187            (dolist (package (list-all-packages))
 188              (flet ((iterate-over-hash-table (table)
 189                       (let ((hash-vec (package-hashtable-hash table))
 190                             (sym-vec (package-hashtable-table table)))
 191                         (dotimes (i (length sym-vec))
 192                           (when (>= (aref hash-vec i) 2)
 193                             (,flet-name (aref sym-vec i)))))))
 194                (iterate-over-hash-table (package-internal-symbols package))
 195                (iterate-over-hash-table (package-external-symbols package)))))
 196          (let ((,var nil))
 197            (declare (ignorable ,var))
 198            ,@decls
 199            ,result-form)))))
 200 \f
 201 ;;;; WITH-PACKAGE-ITERATOR
 202
 203 (defmacro-mundanely with-package-iterator ((mname package-list
 204                                                   &rest symbol-types)
 205                                            &body body)
 206   #!+sb-doc
 207   "Within the lexical scope of the body forms, MNAME is defined via macrolet
 208 such that successive invocations of (MNAME) will return the symbols, one by
 209 one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any
 210 of :INHERITED :EXTERNAL :INTERNAL."
 211   (with-unique-names (packages these-packages counter kind hash-vector vector
 212                       package-use-list init-macro end-test-macro real-symbol-p
 213                       inherited-symbol-p BLOCK)
 214     (let ((ordered-types (let ((res nil))
 215                            (dolist (kind '(:inherited :external :internal) res)
 216                              (when (member kind symbol-types)
 217                                (push kind res))))))  ; Order SYMBOL-TYPES.
 218       `(let* ((,these-packages ,package-list)
 219               (,packages `,(mapcar (lambda (package)
 220                                      (if (packagep package)
 221                                          package
 222                                          ;; Maybe FIND-PACKAGE-OR-DIE?
 223                                          (or (find-package package)
 224                                              (error 'simple-package-error
 225                                                     ;; could be a character
 226                                                     :package (string package)
 227                                                     :format-control "~@<~S does not name a package ~:>"
 228                                                     :format-arguments (list package)))))
 229                                    (if (consp ,these-packages)
 230                                        ,these-packages
 231                                        (list ,these-packages))))
 232               (,counter nil)
 233               (,kind (car ,packages))
 234               (,hash-vector nil)
 235               (,vector nil)
 236               (,package-use-list nil))
 237         ,(if (member :inherited ordered-types)
 238              `(setf ,package-use-list (package-%use-list (car ,packages)))
 239              `(declare (ignore ,package-use-list)))
 240         (macrolet ((,init-macro (next-kind)
 241                      (declare (optimize (inhibit-warnings 3)))
 242                      (let ((symbols (gensym)))
 243                        `(progn
 244                          (setf ,',kind ,next-kind)
 245                          (setf ,',counter nil)
 246                          ,(case next-kind
 247                                 (:internal
 248                                  `(let ((,symbols (package-internal-symbols
 249                                                    (car ,',packages))))
 250                                    (when ,symbols
 251                                      (setf ,',vector (package-hashtable-table ,symbols))
 252                                      (setf ,',hash-vector
 253                                            (package-hashtable-hash ,symbols)))))
 254                                 (:external
 255                                  `(let ((,symbols (package-external-symbols
 256                                                    (car ,',packages))))
 257                                    (when ,symbols
 258                                      (setf ,',vector (package-hashtable-table ,symbols))
 259                                      (setf ,',hash-vector
 260                                            (package-hashtable-hash ,symbols)))))
 261                                 (:inherited
 262                                  `(let ((,symbols (and ,',package-use-list
 263                                                        (package-external-symbols
 264                                                         (car ,',package-use-list)))))
 265                                    (when ,symbols
 266                                      (setf ,',vector (package-hashtable-table ,symbols))
 267                                      (setf ,',hash-vector
 268                                            (package-hashtable-hash ,symbols)))))))))
 269                    (,end-test-macro (this-kind)
 270                      `,(let ((next-kind (cadr (member this-kind
 271                                                       ',ordered-types))))
 272                             (if next-kind
 273                                 `(,',init-macro ,next-kind)
 274                                 `(if (endp (setf ,',packages (cdr ,',packages)))
 275                                   (return-from ,',BLOCK)
 276                                   (,',init-macro ,(car ',ordered-types)))))))
 277           (when ,packages
 278             ,(when (null symbol-types)
 279                    (error 'simple-program-error
 280                           :format-control
 281                           "At least one of :INTERNAL, :EXTERNAL, or ~
 282                       :INHERITED must be supplied."))
 283             ,(dolist (symbol symbol-types)
 284                      (unless (member symbol '(:internal :external :inherited))
 285                        (error 'simple-program-error
 286                               :format-control
 287                               "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
 288                               :format-arguments (list symbol))))
 289             (,init-macro ,(car ordered-types))
 290             (flet ((,real-symbol-p (number)
 291                      (> number 1)))
 292               (macrolet ((,mname ()
 293                            (declare (optimize (inhibit-warnings 3)))
 294                            `(block ,',BLOCK
 295                              (loop
 296                               (case ,',kind
 297                                 ,@(when (member :internal ',ordered-types)
 298                                         `((:internal
 299                                            (setf ,',counter
 300                                             (position-if #',',real-symbol-p
 301                                                          (the hash-vector ,',hash-vector)
 302                                                          :start (if ,',counter
 303                                                                     (1+ ,',counter)
 304                                                                     0)))
 305                                            (if ,',counter
 306                                                (return-from ,',BLOCK
 307                                                  (values t (svref ,',vector ,',counter)
 308                                                          ,',kind (car ,',packages)))
 309                                                (,',end-test-macro :internal)))))
 310                                 ,@(when (member :external ',ordered-types)
 311                                         `((:external
 312                                            (setf ,',counter
 313                                             (position-if #',',real-symbol-p
 314                                                          (the hash-vector ,',hash-vector)
 315                                                          :start (if ,',counter
 316                                                                     (1+ ,',counter)
 317                                                                     0)))
 318                                            (if ,',counter
 319                                                (return-from ,',BLOCK
 320                                                  (values t (svref ,',vector ,',counter)
 321                                                          ,',kind (car ,',packages)))
 322                                                (,',end-test-macro :external)))))
 323                                 ,@(when (member :inherited ',ordered-types)
 324                                         `((:inherited
 325                                            (flet ((,',inherited-symbol-p (number)
 326                                                     (when (,',real-symbol-p number)
 327                                                       (let* ((p (position
 328                                                                  number
 329                                                                  (the hash-vector
 330                                                                    ,',hash-vector)
 331                                                                  :start (if ,',counter
 332                                                                             (1+ ,',counter)
 333                                                                             0)))
 334                                                              (s (svref ,',vector p)))
 335                                                         (eql (nth-value
 336                                                               1 (find-symbol
 337                                                                  (symbol-name s)
 338                                                                  (car ,',packages)))
 339                                                              :inherited)))))
 340                                              (setf ,',counter
 341                                                    (when ,',hash-vector
 342                                                      (position-if #',',inherited-symbol-p
 343                                                                   (the hash-vector
 344                                                                     ,',hash-vector)
 345                                                                   :start (if ,',counter
 346                                                                              (1+ ,',counter)
 347                                                                              0)))))
 348                                            (cond (,',counter
 349                                                   (return-from
 350                                                    ,',BLOCK
 351                                                     (values t (svref ,',vector ,',counter)
 352                                                             ,',kind (car ,',packages))
 353                                                     ))
 354                                                  (t
 355                                                   (setf ,',package-use-list
 356                                                         (cdr ,',package-use-list))
 357                                                   (cond ((endp ,',package-use-list)
 358                                                          (setf ,',packages (cdr ,',packages))
 359                                                          (when (endp ,',packages)
 360                                                            (return-from ,',BLOCK))
 361                                                          (setf ,',package-use-list
 362                                                                (package-%use-list
 363                                                                 (car ,',packages)))
 364                                                          (,',init-macro ,(car
 365                                                                           ',ordered-types)))
 366                                                         (t (,',init-macro :inherited)
 367                                                            (setf ,',counter nil)))))))))))))
 368                 ,@body))))))))
 369
 370 (defmacro-mundanely with-package-graph ((&key) &body forms)
 371   `(flet ((thunk () ,@forms))
 372      (declare (dynamic-extent #'thunk))
 373      (call-with-package-graph #'thunk)))