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 (sb!xc:deftype hash-vector () '(simple-array (unsigned-byte 8) (*)))
  34
  35 (sb!xc:defstruct (package-hashtable (:constructor %make-package-hashtable ())
  36                                     (:copier nil))
  37   ;; The g-vector of symbols.
  38   ;; FIXME: could just be type SIMPLE-VECTOR, with REQUIRED-ARG
  39   (table nil :type (or simple-vector null))
  40   ;; The i-vector of pname hash values.
  41   ;; FIXME: could just be type HASH-VECTOR, with REQUIRED-ARG
  42   (hash nil :type (or hash-vector null))
  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 0 :type index)
  49   ;; The remaining number of entries that can be made before we have to rehash.
  50   (free 0 :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. The DEF!STRUCT
  60 ;;; side-effect of defining a new PACKAGE type on the
  61 ;;; cross-compilation host is just a nuisance, and in order to avoid
  62 ;;; breaking the cross-compilation host, we need to work around it
  63 ;;; around by putting the new PACKAGE type (and the PACKAGEP predicate
  64 ;;; too..) into SB!XC. -- WHN 20000309
  65 (def!struct (sb!xc:package
  66              (:constructor internal-make-package)
  67              (:make-load-form-fun (lambda (p)
  68                                     (values `(find-undeleted-package-or-lose
  69                                               ',(package-name p))
  70                                             nil)))
  71              (:predicate sb!xc:packagep))
  72   #!+sb-doc
  73   "the standard structure for the description of a package"
  74   ;; the name of the package, or NIL for a deleted package
  75   (%name nil :type (or simple-string null))
  76   ;; nickname strings
  77   (%nicknames () :type list)
  78   ;; packages used by this package
  79   (%use-list () :type list)
  80   ;; a list of all the hashtables for inherited symbols. This is
  81   ;; derived from %USE-LIST, but maintained separately from %USE-LIST
  82   ;; for some reason. (Perhaps the reason is that when FIND-SYMBOL*
  83   ;; hits an inherited symbol, it pulls it to the head of the list.)
  84   ;;
  85   ;; FIXME: This needs a more-descriptive name
  86   ;; (USED-PACKAGE-HASH-TABLES?). It also needs an explanation of why
  87   ;; the last entry is NIL. Perhaps it should even just go away and
  88   ;; let us do indirection on the fly through %USE-LIST. (If so,
  89   ;; benchmark to make sure that performance doesn't get stomped..)
  90   ;; (If benchmark performance is important, this should prob'ly
  91   ;; become a vector instead of a list.)
  92   (tables (list nil) :type list)
  93   ;; packages that use this package
  94   (%used-by-list () :type list)
  95   ;; PACKAGE-HASHTABLEs of internal & external symbols
  96   (internal-symbols (missing-arg) :type package-hashtable)
  97   (external-symbols (missing-arg) :type package-hashtable)
  98   ;; shadowing symbols
  99   (%shadowing-symbols () :type list)
 100   ;; documentation string for this package
 101   (doc-string nil :type (or simple-string null)))
 102 \f
 103 ;;;; iteration macros
 104
 105 (defmacro-mundanely do-symbols ((var &optional
 106                                      (package '*package*)
 107                                      result-form)
 108                                 &body body-decls)
 109   #!+sb-doc
 110   "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
 111    Executes the FORMs at least once for each symbol accessible in the given
 112    PACKAGE with VAR bound to the current symbol."
 113   (multiple-value-bind (body decls) body-decls
 114     (let ((flet-name (gensym "DO-SYMBOLS-")))
 115       `(block nil
 116          (flet ((,flet-name (,var)
 117                   ,@decls
 118                   (tagbody ,@body)))
 119            (let* ((package (find-undeleted-package-or-lose ,package))
 120                   (shadows (package-%shadowing-symbols package)))
 121              (flet ((iterate-over-hash-table (table ignore)
 122                       (let ((hash-vec (package-hashtable-hash table))
 123                             (sym-vec (package-hashtable-table table)))
 124                         (declare (type (simple-array (unsigned-byte 8) (*))
 125                                        hash-vec)
 126                                  (type simple-vector sym-vec))
 127                         (dotimes (i (length sym-vec))
 128                           (when (>= (aref hash-vec i) 2)
 129                             (let ((sym (aref sym-vec i)))
 130                               (declare (inline member))
 131                               (unless (member sym ignore :test #'string=)
 132                                 (,flet-name sym))))))))
 133                (iterate-over-hash-table (package-internal-symbols package) nil)
 134                (iterate-over-hash-table (package-external-symbols package) nil)
 135                (dolist (use (package-%use-list package))
 136                  (iterate-over-hash-table (package-external-symbols use)
 137                                           shadows)))))
 138          (let ((,var nil))
 139            (declare (ignorable ,var))
 140            ,@decls
 141            ,result-form)))))
 142
 143 (defmacro-mundanely do-external-symbols ((var &optional
 144                                               (package '*package*)
 145                                               result-form)
 146                                          &body body-decls)
 147   #!+sb-doc
 148   "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
 149    Executes the FORMs once for each external symbol in the given PACKAGE with
 150    VAR bound to the current symbol."
 151   (multiple-value-bind (body decls) (parse-body body-decls 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              (declare (type (simple-array (unsigned-byte 8) (*))
 162                             hash-vec)
 163                       (type simple-vector sym-vec))
 164              (dotimes (i (length sym-vec))
 165                (when (>= (aref hash-vec i) 2)
 166                  (,flet-name (aref sym-vec i))))))
 167          (let ((,var nil))
 168            (declare (ignorable ,var))
 169            ,@decls
 170            ,result-form)))))
 171
 172 (defmacro-mundanely do-all-symbols ((var &optional
 173                                          result-form)
 174                                     &body body-decls)
 175   #!+sb-doc
 176   "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
 177    Executes the FORMs once for each symbol in every package with VAR bound
 178    to the current symbol."
 179   (multiple-value-bind (body decls) (parse-body body-decls nil)
 180     (let ((flet-name (gensym "DO-SYMBOLS-")))
 181       `(block nil
 182          (flet ((,flet-name (,var)
 183                   ,@decls
 184                   (tagbody ,@body)))
 185            (dolist (package (list-all-packages))
 186              (flet ((iterate-over-hash-table (table)
 187                       (let ((hash-vec (package-hashtable-hash table))
 188                             (sym-vec (package-hashtable-table table)))
 189                         (declare (type (simple-array (unsigned-byte 8) (*))
 190                                        hash-vec)
 191                                  (type simple-vector sym-vec))
 192                         (dotimes (i (length sym-vec))
 193                           (when (>= (aref hash-vec i) 2)
 194                             (,flet-name (aref sym-vec i)))))))
 195                (iterate-over-hash-table (package-internal-symbols package))
 196                (iterate-over-hash-table (package-external-symbols package)))))
 197          (let ((,var nil))
 198            (declare (ignorable ,var))
 199            ,@decls
 200            ,result-form)))))
 201 \f
 202 ;;;; WITH-PACKAGE-ITERATOR
 203
 204 (defmacro-mundanely with-package-iterator ((mname package-list
 205                                                   &rest symbol-types)
 206                                            &body body)
 207   #!+sb-doc
 208   "Within the lexical scope of the body forms, MNAME is defined via macrolet
 209    such that successive invocations of (MNAME) will return the symbols,
 210    one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be
 211    any of :INHERITED :EXTERNAL :INTERNAL."
 212   (let* ((packages (gensym))
 213          (these-packages (gensym))
 214          (ordered-types (let ((res nil))
 215                           (dolist (kind '(:inherited :external :internal)
 216                                         res)
 217                             (when (member kind symbol-types)
 218                               (push kind res)))))  ; Order SYMBOL-TYPES.
 219          (counter (gensym))
 220          (kind (gensym))
 221          (hash-vector (gensym))
 222          (vector (gensym))
 223          (package-use-list (gensym))
 224          (init-macro (gensym))
 225          (end-test-macro (gensym))
 226          (real-symbol-p (gensym))
 227          (inherited-symbol-p (gensym))
 228          (BLOCK (gensym)))
 229     `(let* ((,these-packages ,package-list)
 230             (,packages `,(mapcar #'(lambda (package)
 231                                      (if (packagep package)
 232                                          package
 233                                          (find-package package)))
 234                                  (if (consp ,these-packages)
 235                                      ,these-packages
 236                                      (list ,these-packages))))
 237             (,counter nil)
 238             (,kind (car ,packages))
 239             (,hash-vector nil)
 240             (,vector nil)
 241             (,package-use-list nil))
 242        ,(if (member :inherited ordered-types)
 243             `(setf ,package-use-list (package-%use-list (car ,packages)))
 244             `(declare (ignore ,package-use-list)))
 245        (macrolet ((,init-macro (next-kind)
 246          (let ((symbols (gensym)))
 247            `(progn
 248               (setf ,',kind ,next-kind)
 249               (setf ,',counter nil)
 250               ,(case next-kind
 251                  (:internal
 252                   `(let ((,symbols (package-internal-symbols
 253                                     (car ,',packages))))
 254                      (when ,symbols
 255                        (setf ,',vector (package-hashtable-table ,symbols))
 256                        (setf ,',hash-vector (package-hashtable-hash ,symbols)))))
 257                  (:external
 258                   `(let ((,symbols (package-external-symbols
 259                                     (car ,',packages))))
 260                      (when ,symbols
 261                        (setf ,',vector (package-hashtable-table ,symbols))
 262                        (setf ,',hash-vector
 263                              (package-hashtable-hash ,symbols)))))
 264                  (:inherited
 265                   `(let ((,symbols (and ,',package-use-list
 266                                         (package-external-symbols
 267                                          (car ,',package-use-list)))))
 268                      (when ,symbols
 269                        (setf ,',vector (package-hashtable-table ,symbols))
 270                        (setf ,',hash-vector
 271                              (package-hashtable-hash ,symbols)))))))))
 272                   (,end-test-macro (this-kind)
 273                      `,(let ((next-kind (cadr (member this-kind
 274                                                       ',ordered-types))))
 275                          (if next-kind
 276                              `(,',init-macro ,next-kind)
 277                              `(if (endp (setf ,',packages (cdr ,',packages)))
 278                                   (return-from ,',BLOCK)
 279                                   (,',init-macro ,(car ',ordered-types)))))))
 280          (when ,packages
 281            ,(when (null symbol-types)
 282               (error 'simple-program-error
 283                      :format-control
 284                      "At least one of :INTERNAL, :EXTERNAL, or ~
 285                       :INHERITED must be supplied."))
 286            ,(dolist (symbol symbol-types)
 287               (unless (member symbol '(:internal :external :inherited))
 288                 (error 'program-error
 289                        :format-control
 290                        "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
 291                        :format-argument symbol)))
 292            (,init-macro ,(car ordered-types))
 293            (flet ((,real-symbol-p (number)
 294                     (> number 1)))
 295              (macrolet ((,mname ()
 296               `(block ,',BLOCK
 297                  (loop
 298                    (case ,',kind
 299                      ,@(when (member :internal ',ordered-types)
 300                          `((:internal
 301                             (setf ,',counter
 302                                   (position-if #',',real-symbol-p
 303                                                ,',hash-vector
 304                                                :start (if ,',counter
 305                                                           (1+ ,',counter)
 306                                                           0)))
 307                             (if ,',counter
 308                                 (return-from ,',BLOCK
 309                                  (values t (svref ,',vector ,',counter)
 310                                          ,',kind (car ,',packages)))
 311                                 (,',end-test-macro :internal)))))
 312                      ,@(when (member :external ',ordered-types)
 313                          `((:external
 314                             (setf ,',counter
 315                                   (position-if #',',real-symbol-p
 316                                                ,',hash-vector
 317                                                :start (if ,',counter
 318                                                           (1+ ,',counter)
 319                                                           0)))
 320                             (if ,',counter
 321                                 (return-from ,',BLOCK
 322                                  (values t (svref ,',vector ,',counter)
 323                                          ,',kind (car ,',packages)))
 324                                 (,',end-test-macro :external)))))
 325                      ,@(when (member :inherited ',ordered-types)
 326                          `((:inherited
 327                             (flet ((,',inherited-symbol-p (number)
 328                                      (when (,',real-symbol-p number)
 329                                        (let* ((p (position
 330                                                   number ,',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                                     (position-if #',',inherited-symbol-p
 342                                                  ,',hash-vector
 343                                                  :start (if ,',counter
 344                                                             (1+ ,',counter)
 345                                                             0))))
 346                             (cond (,',counter
 347                                    (return-from
 348                                     ,',BLOCK
 349                                     (values t (svref ,',vector ,',counter)
 350                                             ,',kind (car ,',packages))
 351                                     ))
 352                                   (t
 353                                    (setf ,',package-use-list
 354                                          (cdr ,',package-use-list))
 355                                    (cond ((endp ,',package-use-list)
 356                                           (setf ,',packages (cdr ,',packages))
 357                                           (when (endp ,',packages)
 358                                             (return-from ,',BLOCK))
 359                                           (setf ,',package-use-list
 360                                                 (package-%use-list
 361                                                  (car ,',packages)))
 362                                           (,',init-macro ,(car
 363                                                            ',ordered-types)))
 364                                          (t (,',init-macro :inherited)
 365                                             (setf ,',counter nil)))))))))))))
 366                ,@body)))))))