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 ;;; Packages are implemented using a special kind of hashtable -
  18 ;;; the storage is a single vector in which each cell is both key and value.
  19 ;;; While previously we also used a parallel vector of 8-bit hash codes,
  20 ;;; that turned out to be a pessimization on modern systems, where memory
  21 ;;; can be be read faster than it was 27 years ago. (That's when it was
  22 ;;; discovered - so it is claimed - that without a comparison for hash,
  23 ;;; the majority of time loading fasls was due to paging in symbol names)
  24 ;;;
  25 ;;; But hardware-based prefetch makes it so that it costs no more to compare
  26 ;;; a symbol's hash code than to first compare a smaller hash that doesn't
  27 ;;; require dereferencing the symbol, only to use it as the guard condition
  28 ;;; to compare the full symbol-hash, and only then the symbol-name.
  29 ;;;
  30 ;;; In fairness to the former implementation, for technical reasons
  31 ;;; it was not possible to use SYMBOL-HASH as the hash value by which
  32 ;;; to avoid spurious STRING= calls that would definitely fail.
  33 ;;; Prior to change 06ccf13ed3, there were two reasons for that:
  34 ;;;   (1) we didn't force interned symbols to have a precomputed hash
  35 ;;;   (2) NIL has a strange hash. That was resolved by making any random
  36 ;;;       symbol whose name is spelled "NIL" have the identical strange hash
  37 ;;;       so that the hash is a pure function of the name's characters.
  38
  39 (sb!xc:defstruct (package-hashtable
  40                   (:constructor %make-package-hashtable
  41                                 (cells size &aux (free size)))
  42                   (:copier nil))
  43   ;; The general-vector of symbols, with a hash-vector in its last cell.
  44   (cells (missing-arg) :type simple-vector)
  45   ;; The total number of entries allowed before resizing.
  46   ;;
  47   ;; FIXME: CAPACITY would be a more descriptive name. (This is
  48   ;; related to but not quite the same as HASH-TABLE-SIZE, so calling
  49   ;; it SIZE seems somewhat misleading.)
  50   (size (missing-arg) :type index)
  51   ;; The remaining number of entries that can be made before we have to rehash.
  52   (free (missing-arg) :type index)
  53   ;; The number of deleted entries.
  54   (deleted 0 :type index))
  55 \f
  56 ;;;; the PACKAGE structure
  57
  58 (sb!xc:defstruct (package
  59                   (:constructor %make-package
  60                                 (%name internal-symbols external-symbols))
  61                   (:copier nil)
  62                   (:predicate packagep))
  63   "the standard structure for the description of a package"
  64   ;; the name of the package, or NIL for a deleted package
  65   (%name nil :type (or simple-string null))
  66   ;; nickname strings
  67   (%nicknames () :type list)
  68   ;; packages used by this package
  69   (%use-list () :type list)
  70   ;; a simple-vector of the external symbol hashtables for used packages.
  71   ;; Derived from %USE-LIST, but maintained separately.
  72   (tables #() :type simple-vector)
  73   ;; index into TABLES of the table in which an inherited symbol was most
  74   ;; recently found. On the next %FIND-SYMBOL operation, the indexed table
  75   ;; is tested first.
  76   (mru-table-index 0 :type index)
  77   ;; packages that use this package
  78   (%used-by-list () :type list)
  79   ;; PACKAGE-HASHTABLEs of internal & external symbols
  80   (internal-symbols nil :type package-hashtable)
  81   (external-symbols nil :type package-hashtable)
  82   ;; shadowing symbols
  83   ;; Todo: dynamically changeover to a PACKAGE-HASHTABLE if list gets long
  84   (%shadowing-symbols () :type list)
  85   ;; documentation string for this package
  86   (doc-string nil :type (or simple-string null))
  87   ;; package locking
  88   #!+sb-package-locks
  89   (lock nil :type boolean)
  90   #!+sb-package-locks
  91   (%implementation-packages nil :type list)
  92   ;; Definition source location
  93   (source-location nil :type (or null sb!c:definition-source-location))
  94   ;; Local package nicknames.
  95   (%local-nicknames nil :type list)
  96   (%locally-nicknamed-by nil :type list))
  97
  98 #-sb-xc-host
  99 (defmethod make-load-form ((p package) &optional environment)
 100   (declare (ignore environment))
 101   `(find-undeleted-package-or-lose ,(package-name p)))
 102 \f
 103 ;;;; iteration macros
 104
 105 (flet ((expand-iterator (range var body result-form)
 106          (multiple-value-bind (forms decls) (parse-body body nil)
 107            (with-unique-names (iterator winp next)
 108              `(block nil
 109                 (with-package-iterator (,iterator ,@range)
 110                  (tagbody
 111                   ,next
 112                   (multiple-value-bind (,winp ,var) (,iterator)
 113                     ;; I don't think this VAR is automatically ignorable.
 114                     ;; The user should use it, or declare IGNORE/IGNORABLE.
 115                     ,@decls
 116                     (if ,winp
 117                         (tagbody ,@forms (go ,next))
 118                         (return ,result-form))))))))))
 119
 120 (sb!xc:defmacro do-symbols ((var &optional
 121                                      (package '*package*)
 122                                      result-form)
 123                                 &body body-decls)
 124   "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
 125    Executes the FORMs at least once for each symbol accessible in the given
 126    PACKAGE with VAR bound to the current symbol."
 127   (expand-iterator `((find-undeleted-package-or-lose ,package)
 128                      :internal :external :inherited)
 129                    var body-decls result-form))
 130
 131 (sb!xc:defmacro do-external-symbols ((var &optional
 132                                               (package '*package*)
 133                                               result-form)
 134                                          &body body-decls)
 135   "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
 136    Executes the FORMs once for each external symbol in the given PACKAGE with
 137    VAR bound to the current symbol."
 138   (expand-iterator `((find-undeleted-package-or-lose ,package) :external)
 139                    var body-decls result-form))
 140
 141 (sb!xc:defmacro do-all-symbols ((var &optional
 142                                          result-form)
 143                                     &body body-decls)
 144   "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
 145    Executes the FORMs once for each symbol in every package with VAR bound
 146    to the current symbol."
 147   (expand-iterator '((list-all-packages) :internal :external)
 148                    var body-decls result-form)))
 149
 150 \f
 151 ;;;; WITH-PACKAGE-ITERATOR
 152
 153 (sb!xc:defmacro with-package-iterator ((mname package-list
 154                                                   &rest symbol-types)
 155                                            &body body)
 156   "Within the lexical scope of the body forms, MNAME is defined via macrolet
 157 such that successive invocations of (MNAME) will return the symbols, one by
 158 one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any
 159 of :INHERITED :EXTERNAL :INTERNAL."
 160   ;; SYMBOL-TYPES should really be named ACCESSIBILITY-TYPES.
 161   (when (null symbol-types)
 162     (error 'simple-program-error
 163            :format-control
 164            "At least one of :INTERNAL, :EXTERNAL, or :INHERITED must be supplied."))
 165   (dolist (symbol symbol-types)
 166     (unless (member symbol '(:internal :external :inherited))
 167       (error 'simple-program-error
 168              :format-control
 169              "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
 170              :format-arguments (list symbol))))
 171   (with-unique-names (bits index sym-vec pkglist symbol kind)
 172     (let ((state (list bits index sym-vec pkglist))
 173           (select (logior (if (member :internal  symbol-types) 1 0)
 174                           (if (member :external  symbol-types) 2 0)
 175                           (if (member :inherited symbol-types) 4 0))))
 176       `(multiple-value-bind ,state (package-iter-init ,select ,package-list)
 177          (let (,symbol ,kind)
 178            (macrolet
 179                ((,mname ()
 180                    '(if (eql 0 (multiple-value-setq (,@state ,symbol ,kind)
 181                                  (package-iter-step ,@state)))
 182                         nil
 183                         (values t ,symbol ,kind
 184                                 (car (truly-the list ,pkglist))))))
 185              ,@body))))))
 186
 187 (sb!xc:defmacro with-package-graph ((&key) &body forms)
 188   `(flet ((thunk () ,@forms))
 189      (declare (dynamic-extent #'thunk))
 190      (call-with-package-graph #'thunk)))