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
  15 (file-comment
  16   "$Header$")
  17 \f
  18 ;;;; the PACKAGE-HASHTABLE structure
  19
  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.
  35
  36 (sb!xc:deftype hash-vector () '(simple-array (unsigned-byte 8) (*)))
  37
  38 (sb!xc:defstruct (package-hashtable (:constructor %make-package-hashtable ())
  39                                     (:copier nil))
  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.
  47   ;;
  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.)
  51   (size 0 :type index)
  52   ;; The remaining number of entries that can be made before we have to rehash.
  53   (free 0 :type index)
  54   ;; The number of deleted entries.
  55   (deleted 0 :type index))
  56 \f
  57 ;;;; the PACKAGE structure
  58
  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
  72                                               ',(package-name p))
  73                                             nil)))
  74              (:predicate sb!xc:packagep))
  75   #!+sb-doc
  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))
  79   ;; nickname strings
  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.)
  87   ;;
  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)
 101   ;; shadowing symbols
 102   (%shadowing-symbols () :type list)
 103   ;; documentation string for this package
 104   (doc-string nil :type (or simple-string null)))
 105 \f
 106 ;;;; iteration macros
 107
 108 (defmacro-mundanely do-symbols ((var &optional
 109                                      (package '*package*)
 110                                      result-form)
 111                                 &body body-decls)
 112   #!+sb-doc
 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-")))
 118       `(block nil
 119          (flet ((,flet-name (,var)
 120                   ,@decls
 121                   (tagbody ,@body)))
 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) (*))
 128                                        hash-vec)
 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)
 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) (parse-body body-decls nil)
 155     (let ((flet-name (gensym "DO-SYMBOLS-")))
 156       `(block nil
 157          (flet ((,flet-name (,var)
 158                   ,@decls
 159                   (tagbody ,@body)))
 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) (*))
 165                             hash-vec)
 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))))))
 170          (let ((,var nil))
 171            (declare (ignorable ,var))
 172            ,@decls
 173            ,result-form)))))
 174
 175 (defmacro-mundanely do-all-symbols ((var &optional
 176                                          result-form)
 177                                     &body body-decls)
 178   #!+sb-doc
 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-")))
 184       `(block nil
 185          (flet ((,flet-name (,var)
 186                   ,@decls
 187                   (tagbody ,@body)))
 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) (*))
 193                                        hash-vec)
 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)))))
 200          (let ((,var nil))
 201            (declare (ignorable ,var))
 202            ,@decls
 203            ,result-form)))))
 204 \f
 205 ;;;; WITH-PACKAGE-ITERATOR
 206
 207 (defmacro-mundanely with-package-iterator ((mname package-list
 208                                                   &rest symbol-types)
 209                                            &body body)
 210   #!+sb-doc
 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)
 219                                         res)
 220                             (when (member kind symbol-types)
 221                               (push kind res)))))  ; Order SYMBOL-TYPES.
 222          (counter (gensym))
 223          (kind (gensym))
 224          (hash-vector (gensym))
 225          (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))
 231          (BLOCK (gensym)))
 232     `(let* ((,these-packages ,package-list)
 233             (,packages `,(mapcar #'(lambda (package)
 234                                      (if (packagep package)
 235                                          package
 236                                          (find-package package)))
 237                                  (if (consp ,these-packages)
 238                                      ,these-packages
 239                                      (list ,these-packages))))
 240             (,counter nil)
 241             (,kind (car ,packages))
 242             (,hash-vector nil)
 243             (,vector nil)
 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)))
 250            `(progn
 251               (setf ,',kind ,next-kind)
 252               (setf ,',counter nil)
 253               ,(case next-kind
 254                  (:internal
 255                   `(let ((,symbols (package-internal-symbols
 256                                     (car ,',packages))))
 257                      (when ,symbols
 258                        (setf ,',vector (package-hashtable-table ,symbols))
 259                        (setf ,',hash-vector (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 'program-error
 286                      :format-control
 287                      "Must supply at least one of :internal, :external, or ~
 288                       :inherited."))
 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               `(block ,',BLOCK
 300                  (loop
 301                    (case ,',kind
 302                      ,@(when (member :internal ',ordered-types)
 303                          `((:internal
 304                             (setf ,',counter
 305                                   (position-if #',',real-symbol-p ,',hash-vector
 306                                                :start (if ,',counter
 307                                                           (1+ ,',counter)
 308                                                           0)))
 309                             (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)
 315                          `((:external
 316                             (setf ,',counter
 317                                   (position-if #',',real-symbol-p ,',hash-vector
 318                                                :start (if ,',counter
 319                                                           (1+ ,',counter)
 320                                                           0)))
 321                             (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)
 327                          `((:inherited
 328                             (flet ((,',inherited-symbol-p (number)
 329                                      (when (,',real-symbol-p number)
 330                                        (let* ((p (position
 331                                                   number ,',hash-vector
 332                                                   :start (if ,',counter
 333                                                              (1+ ,',counter)
 334                                                              0)))
 335                                               (s (svref ,',vector p)))
 336                                          (eql (nth-value
 337                                                1 (find-symbol
 338                                                   (symbol-name s)
 339                                                   (car ,',packages)))
 340                                               :inherited)))))
 341                               (setf ,',counter
 342                                     (position-if #',',inherited-symbol-p
 343                                                  ,',hash-vector
 344                                                  :start (if ,',counter
 345                                                             (1+ ,',counter)
 346                                                             0))))
 347                             (cond (,',counter
 348                                    (return-from
 349                                     ,',BLOCK
 350                                     (values t (svref ,',vector ,',counter)
 351                                             ,',kind (car ,',packages))
 352                                     ))
 353                                   (t
 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
 361                                                 (package-%use-list
 362                                                  (car ,',packages)))
 363                                           (,',init-macro ,(car
 364                                                            ',ordered-types)))
 365                                          (t (,',init-macro :inherited)
 366                                             (setf ,',counter nil)))))))))))))
 367                ,@body)))))))