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-base-string null))
  77   ;; nickname strings
  78   (%nicknames () :type list)
  79   ;; packages used by this package
  80   (%use-list () :type list)
  81   ;; a list of all the hashtables for inherited symbols. This is
  82   ;; derived from %USE-LIST, but maintained separately from %USE-LIST
  83   ;; for some reason. (Perhaps the reason is that when FIND-SYMBOL*
  84   ;; hits an inherited symbol, it pulls it to the head of the list.)
  85   ;;
  86   ;; FIXME: This needs a more-descriptive name
  87   ;; (USED-PACKAGE-HASH-TABLES?). It also needs an explanation of why
  88   ;; the last entry is NIL. Perhaps it should even just go away and
  89   ;; let us do indirection on the fly through %USE-LIST. (If so,
  90   ;; benchmark to make sure that performance doesn't get stomped..)
  91   ;; (If benchmark performance is important, this should prob'ly
  92   ;; become a vector instead of a list.)
  93   (tables (list nil) :type list)
  94   ;; packages that use this package
  95   (%used-by-list () :type list)
  96   ;; PACKAGE-HASHTABLEs of internal & external symbols
  97   (internal-symbols (missing-arg) :type package-hashtable)
  98   (external-symbols (missing-arg) :type package-hashtable)
  99   ;; shadowing symbols
 100   (%shadowing-symbols () :type list)
 101   ;; documentation string for this package
 102   (doc-string nil :type (or simple-base-string null)))
 103 \f
 104 ;;;; iteration macros
 105
 106 (defmacro-mundanely do-symbols ((var &optional
 107                                      (package '*package*)
 108                                      result-form)
 109                                 &body body-decls)
 110   #!+sb-doc
 111   "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
 112    Executes the FORMs at least once for each symbol accessible in the given
 113    PACKAGE with VAR bound to the current symbol."
 114   (multiple-value-bind (body decls)
 115       (parse-body body-decls :doc-string-allowed nil)
 116     (let ((flet-name (gensym "DO-SYMBOLS-")))
 117       `(block nil
 118          (flet ((,flet-name (,var)
 119                   ,@decls
 120                   (tagbody ,@body)))
 121            (let* ((package (find-undeleted-package-or-lose ,package))
 122                   (shadows (package-%shadowing-symbols package)))
 123              (flet ((iterate-over-hash-table (table ignore)
 124                       (let ((hash-vec (package-hashtable-hash table))
 125                             (sym-vec (package-hashtable-table table)))
 126                         (dotimes (i (length sym-vec))
 127                           (when (>= (aref hash-vec i) 2)
 128                             (let ((sym (aref sym-vec i)))
 129                               (declare (inline member))
 130                               (unless (member sym ignore :test #'string=)
 131                                 (,flet-name sym))))))))
 132                (iterate-over-hash-table (package-internal-symbols package) nil)
 133                (iterate-over-hash-table (package-external-symbols package) nil)
 134                (dolist (use (package-%use-list package))
 135                  (iterate-over-hash-table (package-external-symbols use)
 136                                           shadows)))))
 137          (let ((,var nil))
 138            (declare (ignorable ,var))
 139            ,@decls
 140            ,result-form)))))
 141
 142 (defmacro-mundanely do-external-symbols ((var &optional
 143                                               (package '*package*)
 144                                               result-form)
 145                                          &body body-decls)
 146   #!+sb-doc
 147   "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
 148    Executes the FORMs once for each external symbol in the given PACKAGE with
 149    VAR bound to the current symbol."
 150   (multiple-value-bind (body decls)
 151       (parse-body body-decls :doc-string-allowed nil)
 152     (let ((flet-name (gensym "DO-SYMBOLS-")))
 153       `(block nil
 154          (flet ((,flet-name (,var)
 155                   ,@decls
 156                   (tagbody ,@body)))
 157            (let* ((package (find-undeleted-package-or-lose ,package))
 158                   (table (package-external-symbols package))
 159                   (hash-vec (package-hashtable-hash table))
 160                   (sym-vec (package-hashtable-table table)))
 161              (dotimes (i (length sym-vec))
 162                (when (>= (aref hash-vec i) 2)
 163                  (,flet-name (aref sym-vec i))))))
 164          (let ((,var nil))
 165            (declare (ignorable ,var))
 166            ,@decls
 167            ,result-form)))))
 168
 169 (defmacro-mundanely do-all-symbols ((var &optional
 170                                          result-form)
 171                                     &body body-decls)
 172   #!+sb-doc
 173   "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
 174    Executes the FORMs once for each symbol in every package with VAR bound
 175    to the current symbol."
 176   (multiple-value-bind (body decls)
 177       (parse-body body-decls :doc-string-allowed nil)
 178     (let ((flet-name (gensym "DO-SYMBOLS-")))
 179       `(block nil
 180          (flet ((,flet-name (,var)
 181                   ,@decls
 182                   (tagbody ,@body)))
 183            (dolist (package (list-all-packages))
 184              (flet ((iterate-over-hash-table (table)
 185                       (let ((hash-vec (package-hashtable-hash table))
 186                             (sym-vec (package-hashtable-table table)))
 187                         (dotimes (i (length sym-vec))
 188                           (when (>= (aref hash-vec i) 2)
 189                             (,flet-name (aref sym-vec i)))))))
 190                (iterate-over-hash-table (package-internal-symbols package))
 191                (iterate-over-hash-table (package-external-symbols package)))))
 192          (let ((,var nil))
 193            (declare (ignorable ,var))
 194            ,@decls
 195            ,result-form)))))
 196 \f
 197 ;;;; WITH-PACKAGE-ITERATOR
 198
 199 (defmacro-mundanely with-package-iterator ((mname package-list
 200                                                   &rest symbol-types)
 201                                            &body body)
 202   #!+sb-doc
 203   "Within the lexical scope of the body forms, MNAME is defined via macrolet
 204    such that successive invocations of (MNAME) will return the symbols,
 205    one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be
 206    any of :INHERITED :EXTERNAL :INTERNAL."
 207   (let* ((packages (gensym))
 208          (these-packages (gensym))
 209          (ordered-types (let ((res nil))
 210                           (dolist (kind '(:inherited :external :internal)
 211                                         res)
 212                             (when (member kind symbol-types)
 213                               (push kind res)))))  ; Order SYMBOL-TYPES.
 214          (counter (gensym))
 215          (kind (gensym))
 216          (hash-vector (gensym))
 217          (vector (gensym))
 218          (package-use-list (gensym))
 219          (init-macro (gensym))
 220          (end-test-macro (gensym))
 221          (real-symbol-p (gensym))
 222          (inherited-symbol-p (gensym))
 223          (BLOCK (gensym)))
 224     `(let* ((,these-packages ,package-list)
 225             (,packages `,(mapcar (lambda (package)
 226                                    (if (packagep package)
 227                                        package
 228                                        ;; Maybe FIND-PACKAGE-OR-DIE?
 229                                        (or (find-package package)
 230                                            (error 'simple-package-error
 231                                                   ;; could be a character
 232                                                   :name (string package)
 233                                                   :format-control "~@<~S does not name a package ~:>"
 234                                                   :format-arguments (list package)))))
 235                                  (if (consp ,these-packages)
 236                                      ,these-packages
 237                                      (list ,these-packages))))
 238             (,counter nil)
 239             (,kind (car ,packages))
 240             (,hash-vector nil)
 241             (,vector nil)
 242             (,package-use-list nil))
 243        ,(if (member :inherited ordered-types)
 244             `(setf ,package-use-list (package-%use-list (car ,packages)))
 245             `(declare (ignore ,package-use-list)))
 246        (macrolet ((,init-macro (next-kind)
 247          (declare (optimize (inhibit-warnings 3)))
 248          (let ((symbols (gensym)))
 249            `(progn
 250               (setf ,',kind ,next-kind)
 251               (setf ,',counter nil)
 252               ,(case next-kind
 253                  (:internal
 254                   `(let ((,symbols (package-internal-symbols
 255                                     (car ,',packages))))
 256                      (when ,symbols
 257                        (setf ,',vector (package-hashtable-table ,symbols))
 258                        (setf ,',hash-vector
 259                              (package-hashtable-hash ,symbols)))))
 260                  (:external
 261                   `(let ((,symbols (package-external-symbols
 262                                     (car ,',packages))))
 263                      (when ,symbols
 264                        (setf ,',vector (package-hashtable-table ,symbols))
 265                        (setf ,',hash-vector
 266                              (package-hashtable-hash ,symbols)))))
 267                  (:inherited
 268                   `(let ((,symbols (and ,',package-use-list
 269                                         (package-external-symbols
 270                                          (car ,',package-use-list)))))
 271                      (when ,symbols
 272                        (setf ,',vector (package-hashtable-table ,symbols))
 273                        (setf ,',hash-vector
 274                              (package-hashtable-hash ,symbols)))))))))
 275                   (,end-test-macro (this-kind)
 276                      `,(let ((next-kind (cadr (member this-kind
 277                                                       ',ordered-types))))
 278                          (if next-kind
 279                              `(,',init-macro ,next-kind)
 280                              `(if (endp (setf ,',packages (cdr ,',packages)))
 281                                   (return-from ,',BLOCK)
 282                                   (,',init-macro ,(car ',ordered-types)))))))
 283          (when ,packages
 284            ,(when (null symbol-types)
 285               (error 'simple-program-error
 286                      :format-control
 287                      "At least one of :INTERNAL, :EXTERNAL, or ~
 288                       :INHERITED must be supplied."))
 289            ,(dolist (symbol symbol-types)
 290               (unless (member symbol '(:internal :external :inherited))
 291                 (error 'program-error
 292                        :format-control
 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)
 297                     (> number 1)))
 298              (macrolet ((,mname ()
 299               (declare (optimize (inhibit-warnings 3)))
 300               `(block ,',BLOCK
 301                  (loop
 302                    (case ,',kind
 303                      ,@(when (member :internal ',ordered-types)
 304                          `((:internal
 305                             (setf ,',counter
 306                                   (position-if #',',real-symbol-p
 307                                                (the hash-vector ,',hash-vector)
 308                                                :start (if ,',counter
 309                                                           (1+ ,',counter)
 310                                                           0)))
 311                             (if ,',counter
 312                                 (return-from ,',BLOCK
 313                                  (values t (svref ,',vector ,',counter)
 314                                          ,',kind (car ,',packages)))
 315                                 (,',end-test-macro :internal)))))
 316                      ,@(when (member :external ',ordered-types)
 317                          `((:external
 318                             (setf ,',counter
 319                                   (position-if #',',real-symbol-p
 320                                                (the hash-vector ,',hash-vector)
 321                                                :start (if ,',counter
 322                                                           (1+ ,',counter)
 323                                                           0)))
 324                             (if ,',counter
 325                                 (return-from ,',BLOCK
 326                                  (values t (svref ,',vector ,',counter)
 327                                          ,',kind (car ,',packages)))
 328                                 (,',end-test-macro :external)))))
 329                      ,@(when (member :inherited ',ordered-types)
 330                          `((:inherited
 331                             (flet ((,',inherited-symbol-p (number)
 332                                      (when (,',real-symbol-p number)
 333                                        (let* ((p (position
 334                                                   number
 335                                                   (the hash-vector
 336                                                     ,',hash-vector)
 337                                                   :start (if ,',counter
 338                                                              (1+ ,',counter)
 339                                                              0)))
 340                                               (s (svref ,',vector p)))
 341                                          (eql (nth-value
 342                                                1 (find-symbol
 343                                                   (symbol-name s)
 344                                                   (car ,',packages)))
 345                                               :inherited)))))
 346                               (setf ,',counter
 347                                     (when ,',hash-vector
 348                                       (position-if #',',inherited-symbol-p
 349                                                    (the hash-vector
 350                                                      ,',hash-vector)
 351                                                    :start (if ,',counter
 352                                                               (1+ ,',counter)
 353                                                               0)))))
 354                             (cond (,',counter
 355                                    (return-from
 356                                     ,',BLOCK
 357                                     (values t (svref ,',vector ,',counter)
 358                                             ,',kind (car ,',packages))
 359                                     ))
 360                                   (t
 361                                    (setf ,',package-use-list
 362                                          (cdr ,',package-use-list))
 363                                    (cond ((endp ,',package-use-list)
 364                                           (setf ,',packages (cdr ,',packages))
 365                                           (when (endp ,',packages)
 366                                             (return-from ,',BLOCK))
 367                                           (setf ,',package-use-list
 368                                                 (package-%use-list
 369                                                  (car ,',packages)))
 370                                           (,',init-macro ,(car
 371                                                            ',ordered-types)))
 372                                          (t (,',init-macro :inherited)
 373                                             (setf ,',counter nil)))))))))))))
 374                ,@body)))))))